diff options
| author | Shashank | 2017-05-29 12:40:26 +0530 |
|---|---|---|
| committer | Shashank | 2017-05-29 12:40:26 +0530 |
| commit | 0345245e860375a32c9a437c4a9d9cae807134e9 (patch) | |
| tree | ad51ecbfa7bcd3cc5f09834f1bb8c08feaa526a4 /modules/elementary_functions/src | |
| download | scilab_for_xcos_on_cloud-0345245e860375a32c9a437c4a9d9cae807134e9.tar.gz scilab_for_xcos_on_cloud-0345245e860375a32c9a437c4a9d9cae807134e9.tar.bz2 scilab_for_xcos_on_cloud-0345245e860375a32c9a437c4a9d9cae807134e9.zip | |
CMSCOPE changed
Diffstat (limited to 'modules/elementary_functions/src')
824 files changed, 49774 insertions, 0 deletions
diff --git a/modules/elementary_functions/src/c/.deps/.dirstamp b/modules/elementary_functions/src/c/.deps/.dirstamp new file mode 100755 index 000000000..e69de29bb --- /dev/null +++ b/modules/elementary_functions/src/c/.deps/.dirstamp diff --git a/modules/elementary_functions/src/c/.deps/libdummy_elementary_functions_la-unsfdcopy.Plo b/modules/elementary_functions/src/c/.deps/libdummy_elementary_functions_la-unsfdcopy.Plo new file mode 100755 index 000000000..70371a693 --- /dev/null +++ b/modules/elementary_functions/src/c/.deps/libdummy_elementary_functions_la-unsfdcopy.Plo @@ -0,0 +1,61 @@ +src/c/libdummy_elementary_functions_la-unsfdcopy.lo: src/c/unsfdcopy.c \ + /usr/include/stdc-predef.h /usr/include/string.h /usr/include/features.h \ + /usr/include/x86_64-linux-gnu/sys/cdefs.h \ + /usr/include/x86_64-linux-gnu/bits/wordsize.h \ + /usr/include/x86_64-linux-gnu/gnu/stubs.h \ + /usr/include/x86_64-linux-gnu/gnu/stubs-64.h \ + /usr/lib/gcc/x86_64-linux-gnu/5/include/stddef.h /usr/include/xlocale.h \ + /usr/include/x86_64-linux-gnu/bits/string.h \ + /usr/include/x86_64-linux-gnu/bits/string2.h /usr/include/endian.h \ + /usr/include/x86_64-linux-gnu/bits/endian.h \ + /usr/include/x86_64-linux-gnu/bits/byteswap.h \ + /usr/include/x86_64-linux-gnu/bits/types.h \ + /usr/include/x86_64-linux-gnu/bits/typesizes.h \ + /usr/include/x86_64-linux-gnu/bits/byteswap-16.h /usr/include/stdlib.h \ + /usr/include/x86_64-linux-gnu/bits/string3.h \ + ../../modules/core/includes/machine.h includes/unsfdcopy.h \ + includes/dynlib_elementary_functions.h + +/usr/include/stdc-predef.h: + +/usr/include/string.h: + +/usr/include/features.h: + +/usr/include/x86_64-linux-gnu/sys/cdefs.h: + +/usr/include/x86_64-linux-gnu/bits/wordsize.h: + +/usr/include/x86_64-linux-gnu/gnu/stubs.h: + +/usr/include/x86_64-linux-gnu/gnu/stubs-64.h: + +/usr/lib/gcc/x86_64-linux-gnu/5/include/stddef.h: + +/usr/include/xlocale.h: + +/usr/include/x86_64-linux-gnu/bits/string.h: + +/usr/include/x86_64-linux-gnu/bits/string2.h: + +/usr/include/endian.h: + +/usr/include/x86_64-linux-gnu/bits/endian.h: + +/usr/include/x86_64-linux-gnu/bits/byteswap.h: + +/usr/include/x86_64-linux-gnu/bits/types.h: + +/usr/include/x86_64-linux-gnu/bits/typesizes.h: + +/usr/include/x86_64-linux-gnu/bits/byteswap-16.h: + +/usr/include/stdlib.h: + +/usr/include/x86_64-linux-gnu/bits/string3.h: + +../../modules/core/includes/machine.h: + +includes/unsfdcopy.h: + +includes/dynlib_elementary_functions.h: diff --git a/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-IsEqualVar.Plo b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-IsEqualVar.Plo new file mode 100755 index 000000000..e12f8afd9 --- /dev/null +++ b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-IsEqualVar.Plo @@ -0,0 +1,216 @@ +src/c/libscielementary_functions_algo_la-IsEqualVar.lo: \ + src/c/IsEqualVar.c /usr/include/stdc-predef.h src/c/IsEqualVar.h \ + /usr/include/string.h /usr/include/features.h \ + /usr/include/x86_64-linux-gnu/sys/cdefs.h \ + /usr/include/x86_64-linux-gnu/bits/wordsize.h \ + /usr/include/x86_64-linux-gnu/gnu/stubs.h \ + /usr/include/x86_64-linux-gnu/gnu/stubs-64.h \ + /usr/lib/gcc/x86_64-linux-gnu/5/include/stddef.h /usr/include/xlocale.h \ + /usr/include/x86_64-linux-gnu/bits/string.h \ + /usr/include/x86_64-linux-gnu/bits/string2.h /usr/include/endian.h \ + /usr/include/x86_64-linux-gnu/bits/endian.h \ + /usr/include/x86_64-linux-gnu/bits/byteswap.h \ + /usr/include/x86_64-linux-gnu/bits/types.h \ + /usr/include/x86_64-linux-gnu/bits/typesizes.h \ + /usr/include/x86_64-linux-gnu/bits/byteswap-16.h /usr/include/stdlib.h \ + /usr/include/x86_64-linux-gnu/bits/string3.h \ + ../../modules/core/includes/stack-c.h \ + ../../modules/core/includes/core_math.h \ + /usr/lib/gcc/x86_64-linux-gnu/5/include-fixed/limits.h \ + /usr/lib/gcc/x86_64-linux-gnu/5/include-fixed/syslimits.h \ + /usr/include/limits.h /usr/include/x86_64-linux-gnu/bits/posix1_lim.h \ + /usr/include/x86_64-linux-gnu/bits/local_lim.h \ + /usr/include/linux/limits.h \ + /usr/include/x86_64-linux-gnu/bits/posix2_lim.h /usr/include/math.h \ + /usr/include/x86_64-linux-gnu/bits/math-vector.h \ + /usr/include/x86_64-linux-gnu/bits/libm-simd-decl-stubs.h \ + /usr/include/x86_64-linux-gnu/bits/huge_val.h \ + /usr/include/x86_64-linux-gnu/bits/huge_valf.h \ + /usr/include/x86_64-linux-gnu/bits/huge_vall.h \ + /usr/include/x86_64-linux-gnu/bits/inf.h \ + /usr/include/x86_64-linux-gnu/bits/nan.h \ + /usr/include/x86_64-linux-gnu/bits/mathdef.h \ + /usr/include/x86_64-linux-gnu/bits/mathcalls.h \ + /usr/include/x86_64-linux-gnu/bits/mathinline.h \ + /usr/include/x86_64-linux-gnu/bits/waitflags.h \ + /usr/include/x86_64-linux-gnu/bits/waitstatus.h \ + /usr/include/x86_64-linux-gnu/sys/types.h /usr/include/time.h \ + /usr/include/x86_64-linux-gnu/sys/select.h \ + /usr/include/x86_64-linux-gnu/bits/select.h \ + /usr/include/x86_64-linux-gnu/bits/sigset.h \ + /usr/include/x86_64-linux-gnu/bits/time.h \ + /usr/include/x86_64-linux-gnu/bits/select2.h \ + /usr/include/x86_64-linux-gnu/sys/sysmacros.h \ + /usr/include/x86_64-linux-gnu/bits/pthreadtypes.h /usr/include/alloca.h \ + /usr/include/x86_64-linux-gnu/bits/stdlib-bsearch.h \ + /usr/include/x86_64-linux-gnu/bits/stdlib-float.h \ + /usr/include/x86_64-linux-gnu/bits/stdlib.h \ + ../../modules/core/includes/stack-def.h \ + ../../modules/core/includes/machine.h \ + ../../modules/core/includes/stackTypeVariable.h \ + ../../modules/core/includes/BOOL.h \ + ../../modules/core/includes/doublecomplex.h \ + ../../modules/core/includes/stack1.h \ + ../../modules/core/includes/scisparse.h \ + ../../modules/core/includes/stack2.h \ + ../../modules/core/includes/stack3.h \ + ../../modules/core/includes/stack-optional.h \ + ../../modules/core/includes/sci_types.h \ + ../../modules/core/includes/MALLOC.h \ + ../../modules/core/includes/sci_mem_alloc.h \ + ../../modules/core/includes/stack-def.h \ + ../../modules/output_stream/includes/Scierror.h \ + /usr/lib/gcc/x86_64-linux-gnu/5/include/stdarg.h \ + ../../modules/output_stream/includes/do_error_number.h \ + ../../modules/core/includes/machine.h ../../modules/core/includes/BOOL.h \ + ../../modules/core/src/c/parse.h + +/usr/include/stdc-predef.h: + +src/c/IsEqualVar.h: + +/usr/include/string.h: + +/usr/include/features.h: + +/usr/include/x86_64-linux-gnu/sys/cdefs.h: + +/usr/include/x86_64-linux-gnu/bits/wordsize.h: + +/usr/include/x86_64-linux-gnu/gnu/stubs.h: + +/usr/include/x86_64-linux-gnu/gnu/stubs-64.h: + +/usr/lib/gcc/x86_64-linux-gnu/5/include/stddef.h: + +/usr/include/xlocale.h: + +/usr/include/x86_64-linux-gnu/bits/string.h: + +/usr/include/x86_64-linux-gnu/bits/string2.h: + +/usr/include/endian.h: + +/usr/include/x86_64-linux-gnu/bits/endian.h: + +/usr/include/x86_64-linux-gnu/bits/byteswap.h: + +/usr/include/x86_64-linux-gnu/bits/types.h: + +/usr/include/x86_64-linux-gnu/bits/typesizes.h: + +/usr/include/x86_64-linux-gnu/bits/byteswap-16.h: + +/usr/include/stdlib.h: + +/usr/include/x86_64-linux-gnu/bits/string3.h: + +../../modules/core/includes/stack-c.h: + +../../modules/core/includes/core_math.h: + +/usr/lib/gcc/x86_64-linux-gnu/5/include-fixed/limits.h: + +/usr/lib/gcc/x86_64-linux-gnu/5/include-fixed/syslimits.h: + +/usr/include/limits.h: + +/usr/include/x86_64-linux-gnu/bits/posix1_lim.h: + +/usr/include/x86_64-linux-gnu/bits/local_lim.h: + +/usr/include/linux/limits.h: + +/usr/include/x86_64-linux-gnu/bits/posix2_lim.h: + +/usr/include/math.h: + +/usr/include/x86_64-linux-gnu/bits/math-vector.h: + +/usr/include/x86_64-linux-gnu/bits/libm-simd-decl-stubs.h: + +/usr/include/x86_64-linux-gnu/bits/huge_val.h: + +/usr/include/x86_64-linux-gnu/bits/huge_valf.h: + +/usr/include/x86_64-linux-gnu/bits/huge_vall.h: + +/usr/include/x86_64-linux-gnu/bits/inf.h: + +/usr/include/x86_64-linux-gnu/bits/nan.h: + +/usr/include/x86_64-linux-gnu/bits/mathdef.h: + +/usr/include/x86_64-linux-gnu/bits/mathcalls.h: + +/usr/include/x86_64-linux-gnu/bits/mathinline.h: + +/usr/include/x86_64-linux-gnu/bits/waitflags.h: + +/usr/include/x86_64-linux-gnu/bits/waitstatus.h: + +/usr/include/x86_64-linux-gnu/sys/types.h: + +/usr/include/time.h: + +/usr/include/x86_64-linux-gnu/sys/select.h: + +/usr/include/x86_64-linux-gnu/bits/select.h: + +/usr/include/x86_64-linux-gnu/bits/sigset.h: + +/usr/include/x86_64-linux-gnu/bits/time.h: + +/usr/include/x86_64-linux-gnu/bits/select2.h: + +/usr/include/x86_64-linux-gnu/sys/sysmacros.h: + +/usr/include/x86_64-linux-gnu/bits/pthreadtypes.h: + +/usr/include/alloca.h: + +/usr/include/x86_64-linux-gnu/bits/stdlib-bsearch.h: + +/usr/include/x86_64-linux-gnu/bits/stdlib-float.h: + +/usr/include/x86_64-linux-gnu/bits/stdlib.h: + +../../modules/core/includes/stack-def.h: + +../../modules/core/includes/machine.h: + +../../modules/core/includes/stackTypeVariable.h: + +../../modules/core/includes/BOOL.h: + +../../modules/core/includes/doublecomplex.h: + +../../modules/core/includes/stack1.h: + +../../modules/core/includes/scisparse.h: + +../../modules/core/includes/stack2.h: + +../../modules/core/includes/stack3.h: + +../../modules/core/includes/stack-optional.h: + +../../modules/core/includes/sci_types.h: + +../../modules/core/includes/MALLOC.h: + +../../modules/core/includes/sci_mem_alloc.h: + +../../modules/core/includes/stack-def.h: + +../../modules/output_stream/includes/Scierror.h: + +/usr/lib/gcc/x86_64-linux-gnu/5/include/stdarg.h: + +../../modules/output_stream/includes/do_error_number.h: + +../../modules/core/includes/machine.h: + +../../modules/core/includes/BOOL.h: + +../../modules/core/src/c/parse.h: diff --git a/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-cmp.Plo b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-cmp.Plo new file mode 100755 index 000000000..92340e764 --- /dev/null +++ b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-cmp.Plo @@ -0,0 +1,18 @@ +src/c/libscielementary_functions_algo_la-cmp.lo: src/c/cmp.c \ + /usr/include/stdc-predef.h src/c/cmp.h \ + ../../modules/core/includes/machine.h \ + includes/dynlib_elementary_functions.h \ + ../../modules/core/includes/isanan.h \ + ../../modules/core/includes/machine.h + +/usr/include/stdc-predef.h: + +src/c/cmp.h: + +../../modules/core/includes/machine.h: + +includes/dynlib_elementary_functions.h: + +../../modules/core/includes/isanan.h: + +../../modules/core/includes/machine.h: diff --git a/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-convertbase.Plo b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-convertbase.Plo new file mode 100755 index 000000000..2f931e3d6 --- /dev/null +++ b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-convertbase.Plo @@ -0,0 +1,178 @@ +src/c/libscielementary_functions_algo_la-convertbase.lo: \ + src/c/convertbase.c /usr/include/stdc-predef.h /usr/include/string.h \ + /usr/include/features.h /usr/include/x86_64-linux-gnu/sys/cdefs.h \ + /usr/include/x86_64-linux-gnu/bits/wordsize.h \ + /usr/include/x86_64-linux-gnu/gnu/stubs.h \ + /usr/include/x86_64-linux-gnu/gnu/stubs-64.h \ + /usr/lib/gcc/x86_64-linux-gnu/5/include/stddef.h /usr/include/xlocale.h \ + /usr/include/x86_64-linux-gnu/bits/string.h \ + /usr/include/x86_64-linux-gnu/bits/string2.h /usr/include/endian.h \ + /usr/include/x86_64-linux-gnu/bits/endian.h \ + /usr/include/x86_64-linux-gnu/bits/byteswap.h \ + /usr/include/x86_64-linux-gnu/bits/types.h \ + /usr/include/x86_64-linux-gnu/bits/typesizes.h \ + /usr/include/x86_64-linux-gnu/bits/byteswap-16.h /usr/include/stdlib.h \ + /usr/include/x86_64-linux-gnu/bits/string3.h /usr/include/math.h \ + /usr/include/x86_64-linux-gnu/bits/math-vector.h \ + /usr/include/x86_64-linux-gnu/bits/libm-simd-decl-stubs.h \ + /usr/include/x86_64-linux-gnu/bits/huge_val.h \ + /usr/include/x86_64-linux-gnu/bits/huge_valf.h \ + /usr/include/x86_64-linux-gnu/bits/huge_vall.h \ + /usr/include/x86_64-linux-gnu/bits/inf.h \ + /usr/include/x86_64-linux-gnu/bits/nan.h \ + /usr/include/x86_64-linux-gnu/bits/mathdef.h \ + /usr/include/x86_64-linux-gnu/bits/mathcalls.h \ + /usr/include/x86_64-linux-gnu/bits/mathinline.h /usr/include/stdio.h \ + /usr/include/libio.h /usr/include/_G_config.h /usr/include/wchar.h \ + /usr/lib/gcc/x86_64-linux-gnu/5/include/stdarg.h \ + /usr/include/x86_64-linux-gnu/bits/stdio_lim.h \ + /usr/include/x86_64-linux-gnu/bits/sys_errlist.h \ + /usr/include/x86_64-linux-gnu/bits/stdio.h \ + /usr/include/x86_64-linux-gnu/bits/stdio2.h \ + /usr/include/x86_64-linux-gnu/bits/waitflags.h \ + /usr/include/x86_64-linux-gnu/bits/waitstatus.h \ + /usr/include/x86_64-linux-gnu/sys/types.h /usr/include/time.h \ + /usr/include/x86_64-linux-gnu/sys/select.h \ + /usr/include/x86_64-linux-gnu/bits/select.h \ + /usr/include/x86_64-linux-gnu/bits/sigset.h \ + /usr/include/x86_64-linux-gnu/bits/time.h \ + /usr/include/x86_64-linux-gnu/bits/select2.h \ + /usr/include/x86_64-linux-gnu/sys/sysmacros.h \ + /usr/include/x86_64-linux-gnu/bits/pthreadtypes.h /usr/include/alloca.h \ + /usr/include/x86_64-linux-gnu/bits/stdlib-bsearch.h \ + /usr/include/x86_64-linux-gnu/bits/stdlib-float.h \ + /usr/include/x86_64-linux-gnu/bits/stdlib.h src/c/convertbase.h \ + ../../modules/core/includes/MALLOC.h \ + ../../modules/core/includes/sci_mem_alloc.h \ + ../../modules/core/includes/freeArrayOfString.h \ + /usr/include/x86_64-linux-gnu/bits/wchar.h \ + /usr/include/x86_64-linux-gnu/bits/wchar2.h \ + ../../modules/core/includes/BOOL.h \ + ../../modules/core/includes/stack-def.h \ + ../../modules/core/includes/machine.h + +/usr/include/stdc-predef.h: + +/usr/include/string.h: + +/usr/include/features.h: + +/usr/include/x86_64-linux-gnu/sys/cdefs.h: + +/usr/include/x86_64-linux-gnu/bits/wordsize.h: + +/usr/include/x86_64-linux-gnu/gnu/stubs.h: + +/usr/include/x86_64-linux-gnu/gnu/stubs-64.h: + +/usr/lib/gcc/x86_64-linux-gnu/5/include/stddef.h: + +/usr/include/xlocale.h: + +/usr/include/x86_64-linux-gnu/bits/string.h: + +/usr/include/x86_64-linux-gnu/bits/string2.h: + +/usr/include/endian.h: + +/usr/include/x86_64-linux-gnu/bits/endian.h: + +/usr/include/x86_64-linux-gnu/bits/byteswap.h: + +/usr/include/x86_64-linux-gnu/bits/types.h: + +/usr/include/x86_64-linux-gnu/bits/typesizes.h: + +/usr/include/x86_64-linux-gnu/bits/byteswap-16.h: + +/usr/include/stdlib.h: + +/usr/include/x86_64-linux-gnu/bits/string3.h: + +/usr/include/math.h: + +/usr/include/x86_64-linux-gnu/bits/math-vector.h: + +/usr/include/x86_64-linux-gnu/bits/libm-simd-decl-stubs.h: + +/usr/include/x86_64-linux-gnu/bits/huge_val.h: + +/usr/include/x86_64-linux-gnu/bits/huge_valf.h: + +/usr/include/x86_64-linux-gnu/bits/huge_vall.h: + +/usr/include/x86_64-linux-gnu/bits/inf.h: + +/usr/include/x86_64-linux-gnu/bits/nan.h: + +/usr/include/x86_64-linux-gnu/bits/mathdef.h: + +/usr/include/x86_64-linux-gnu/bits/mathcalls.h: + +/usr/include/x86_64-linux-gnu/bits/mathinline.h: + +/usr/include/stdio.h: + +/usr/include/libio.h: + +/usr/include/_G_config.h: + +/usr/include/wchar.h: + +/usr/lib/gcc/x86_64-linux-gnu/5/include/stdarg.h: + +/usr/include/x86_64-linux-gnu/bits/stdio_lim.h: + +/usr/include/x86_64-linux-gnu/bits/sys_errlist.h: + +/usr/include/x86_64-linux-gnu/bits/stdio.h: + +/usr/include/x86_64-linux-gnu/bits/stdio2.h: + +/usr/include/x86_64-linux-gnu/bits/waitflags.h: + +/usr/include/x86_64-linux-gnu/bits/waitstatus.h: + +/usr/include/x86_64-linux-gnu/sys/types.h: + +/usr/include/time.h: + +/usr/include/x86_64-linux-gnu/sys/select.h: + +/usr/include/x86_64-linux-gnu/bits/select.h: + +/usr/include/x86_64-linux-gnu/bits/sigset.h: + +/usr/include/x86_64-linux-gnu/bits/time.h: + +/usr/include/x86_64-linux-gnu/bits/select2.h: + +/usr/include/x86_64-linux-gnu/sys/sysmacros.h: + +/usr/include/x86_64-linux-gnu/bits/pthreadtypes.h: + +/usr/include/alloca.h: + +/usr/include/x86_64-linux-gnu/bits/stdlib-bsearch.h: + +/usr/include/x86_64-linux-gnu/bits/stdlib-float.h: + +/usr/include/x86_64-linux-gnu/bits/stdlib.h: + +src/c/convertbase.h: + +../../modules/core/includes/MALLOC.h: + +../../modules/core/includes/sci_mem_alloc.h: + +../../modules/core/includes/freeArrayOfString.h: + +/usr/include/x86_64-linux-gnu/bits/wchar.h: + +/usr/include/x86_64-linux-gnu/bits/wchar2.h: + +../../modules/core/includes/BOOL.h: + +../../modules/core/includes/stack-def.h: + +../../modules/core/includes/machine.h: diff --git a/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-dscal.Plo b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-dscal.Plo new file mode 100755 index 000000000..9ce06a81e --- /dev/null +++ b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-dscal.Plo @@ -0,0 +1 @@ +# dummy diff --git a/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-finite.Plo b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-finite.Plo new file mode 100755 index 000000000..14649039a --- /dev/null +++ b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-finite.Plo @@ -0,0 +1,154 @@ +src/c/libscielementary_functions_algo_la-finite.lo: src/c/finite.c \ + /usr/include/stdc-predef.h ../../modules/core/includes/machine.h \ + ../../modules/core/includes/core_math.h \ + /usr/lib/gcc/x86_64-linux-gnu/5/include-fixed/limits.h \ + /usr/lib/gcc/x86_64-linux-gnu/5/include-fixed/syslimits.h \ + /usr/include/limits.h /usr/include/features.h \ + /usr/include/x86_64-linux-gnu/sys/cdefs.h \ + /usr/include/x86_64-linux-gnu/bits/wordsize.h \ + /usr/include/x86_64-linux-gnu/gnu/stubs.h \ + /usr/include/x86_64-linux-gnu/gnu/stubs-64.h \ + /usr/include/x86_64-linux-gnu/bits/posix1_lim.h \ + /usr/include/x86_64-linux-gnu/bits/local_lim.h \ + /usr/include/linux/limits.h \ + /usr/include/x86_64-linux-gnu/bits/posix2_lim.h /usr/include/math.h \ + /usr/include/x86_64-linux-gnu/bits/math-vector.h \ + /usr/include/x86_64-linux-gnu/bits/libm-simd-decl-stubs.h \ + /usr/include/x86_64-linux-gnu/bits/huge_val.h \ + /usr/include/x86_64-linux-gnu/bits/huge_valf.h \ + /usr/include/x86_64-linux-gnu/bits/huge_vall.h \ + /usr/include/x86_64-linux-gnu/bits/inf.h \ + /usr/include/x86_64-linux-gnu/bits/nan.h \ + /usr/include/x86_64-linux-gnu/bits/mathdef.h \ + /usr/include/x86_64-linux-gnu/bits/mathcalls.h \ + /usr/include/x86_64-linux-gnu/bits/mathinline.h /usr/include/stdlib.h \ + /usr/lib/gcc/x86_64-linux-gnu/5/include/stddef.h \ + /usr/include/x86_64-linux-gnu/bits/waitflags.h \ + /usr/include/x86_64-linux-gnu/bits/waitstatus.h /usr/include/endian.h \ + /usr/include/x86_64-linux-gnu/bits/endian.h \ + /usr/include/x86_64-linux-gnu/bits/byteswap.h \ + /usr/include/x86_64-linux-gnu/bits/types.h \ + /usr/include/x86_64-linux-gnu/bits/typesizes.h \ + /usr/include/x86_64-linux-gnu/bits/byteswap-16.h \ + /usr/include/x86_64-linux-gnu/sys/types.h /usr/include/time.h \ + /usr/include/x86_64-linux-gnu/sys/select.h \ + /usr/include/x86_64-linux-gnu/bits/select.h \ + /usr/include/x86_64-linux-gnu/bits/sigset.h \ + /usr/include/x86_64-linux-gnu/bits/time.h \ + /usr/include/x86_64-linux-gnu/bits/select2.h \ + /usr/include/x86_64-linux-gnu/sys/sysmacros.h \ + /usr/include/x86_64-linux-gnu/bits/pthreadtypes.h /usr/include/alloca.h \ + /usr/include/x86_64-linux-gnu/bits/stdlib-bsearch.h \ + /usr/include/x86_64-linux-gnu/bits/stdlib-float.h \ + /usr/include/x86_64-linux-gnu/bits/stdlib.h /usr/include/values.h \ + /usr/lib/gcc/x86_64-linux-gnu/5/include/float.h includes/finite.h \ + ../../modules/core/includes/doublecomplex.h \ + includes/dynlib_elementary_functions.h + +/usr/include/stdc-predef.h: + +../../modules/core/includes/machine.h: + +../../modules/core/includes/core_math.h: + +/usr/lib/gcc/x86_64-linux-gnu/5/include-fixed/limits.h: + +/usr/lib/gcc/x86_64-linux-gnu/5/include-fixed/syslimits.h: + +/usr/include/limits.h: + +/usr/include/features.h: + +/usr/include/x86_64-linux-gnu/sys/cdefs.h: + +/usr/include/x86_64-linux-gnu/bits/wordsize.h: + +/usr/include/x86_64-linux-gnu/gnu/stubs.h: + +/usr/include/x86_64-linux-gnu/gnu/stubs-64.h: + +/usr/include/x86_64-linux-gnu/bits/posix1_lim.h: + +/usr/include/x86_64-linux-gnu/bits/local_lim.h: + +/usr/include/linux/limits.h: + +/usr/include/x86_64-linux-gnu/bits/posix2_lim.h: + +/usr/include/math.h: + +/usr/include/x86_64-linux-gnu/bits/math-vector.h: + +/usr/include/x86_64-linux-gnu/bits/libm-simd-decl-stubs.h: + +/usr/include/x86_64-linux-gnu/bits/huge_val.h: + +/usr/include/x86_64-linux-gnu/bits/huge_valf.h: + +/usr/include/x86_64-linux-gnu/bits/huge_vall.h: + +/usr/include/x86_64-linux-gnu/bits/inf.h: + +/usr/include/x86_64-linux-gnu/bits/nan.h: + +/usr/include/x86_64-linux-gnu/bits/mathdef.h: + +/usr/include/x86_64-linux-gnu/bits/mathcalls.h: + +/usr/include/x86_64-linux-gnu/bits/mathinline.h: + +/usr/include/stdlib.h: + +/usr/lib/gcc/x86_64-linux-gnu/5/include/stddef.h: + +/usr/include/x86_64-linux-gnu/bits/waitflags.h: + +/usr/include/x86_64-linux-gnu/bits/waitstatus.h: + +/usr/include/endian.h: + +/usr/include/x86_64-linux-gnu/bits/endian.h: + +/usr/include/x86_64-linux-gnu/bits/byteswap.h: + +/usr/include/x86_64-linux-gnu/bits/types.h: + +/usr/include/x86_64-linux-gnu/bits/typesizes.h: + +/usr/include/x86_64-linux-gnu/bits/byteswap-16.h: + +/usr/include/x86_64-linux-gnu/sys/types.h: + +/usr/include/time.h: + +/usr/include/x86_64-linux-gnu/sys/select.h: + +/usr/include/x86_64-linux-gnu/bits/select.h: + +/usr/include/x86_64-linux-gnu/bits/sigset.h: + +/usr/include/x86_64-linux-gnu/bits/time.h: + +/usr/include/x86_64-linux-gnu/bits/select2.h: + +/usr/include/x86_64-linux-gnu/sys/sysmacros.h: + +/usr/include/x86_64-linux-gnu/bits/pthreadtypes.h: + +/usr/include/alloca.h: + +/usr/include/x86_64-linux-gnu/bits/stdlib-bsearch.h: + +/usr/include/x86_64-linux-gnu/bits/stdlib-float.h: + +/usr/include/x86_64-linux-gnu/bits/stdlib.h: + +/usr/include/values.h: + +/usr/lib/gcc/x86_64-linux-gnu/5/include/float.h: + +includes/finite.h: + +../../modules/core/includes/doublecomplex.h: + +includes/dynlib_elementary_functions.h: diff --git a/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-gsort.Plo b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-gsort.Plo new file mode 100755 index 000000000..31527fc65 --- /dev/null +++ b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-gsort.Plo @@ -0,0 +1,206 @@ +src/c/libscielementary_functions_algo_la-gsort.lo: src/c/gsort.c \ + /usr/include/stdc-predef.h /usr/include/stdio.h /usr/include/features.h \ + /usr/include/x86_64-linux-gnu/sys/cdefs.h \ + /usr/include/x86_64-linux-gnu/bits/wordsize.h \ + /usr/include/x86_64-linux-gnu/gnu/stubs.h \ + /usr/include/x86_64-linux-gnu/gnu/stubs-64.h \ + /usr/lib/gcc/x86_64-linux-gnu/5/include/stddef.h \ + /usr/include/x86_64-linux-gnu/bits/types.h \ + /usr/include/x86_64-linux-gnu/bits/typesizes.h /usr/include/libio.h \ + /usr/include/_G_config.h /usr/include/wchar.h \ + /usr/lib/gcc/x86_64-linux-gnu/5/include/stdarg.h \ + /usr/include/x86_64-linux-gnu/bits/stdio_lim.h \ + /usr/include/x86_64-linux-gnu/bits/sys_errlist.h \ + /usr/include/x86_64-linux-gnu/bits/stdio.h \ + /usr/include/x86_64-linux-gnu/bits/stdio2.h /usr/include/string.h \ + /usr/include/xlocale.h /usr/include/x86_64-linux-gnu/bits/string.h \ + /usr/include/x86_64-linux-gnu/bits/string2.h /usr/include/endian.h \ + /usr/include/x86_64-linux-gnu/bits/endian.h \ + /usr/include/x86_64-linux-gnu/bits/byteswap.h \ + /usr/include/x86_64-linux-gnu/bits/byteswap-16.h /usr/include/stdlib.h \ + /usr/include/x86_64-linux-gnu/bits/string3.h /usr/include/math.h \ + /usr/include/x86_64-linux-gnu/bits/math-vector.h \ + /usr/include/x86_64-linux-gnu/bits/libm-simd-decl-stubs.h \ + /usr/include/x86_64-linux-gnu/bits/huge_val.h \ + /usr/include/x86_64-linux-gnu/bits/huge_valf.h \ + /usr/include/x86_64-linux-gnu/bits/huge_vall.h \ + /usr/include/x86_64-linux-gnu/bits/inf.h \ + /usr/include/x86_64-linux-gnu/bits/nan.h \ + /usr/include/x86_64-linux-gnu/bits/mathdef.h \ + /usr/include/x86_64-linux-gnu/bits/mathcalls.h \ + /usr/include/x86_64-linux-gnu/bits/mathinline.h \ + ../../modules/core/includes/core_math.h \ + /usr/lib/gcc/x86_64-linux-gnu/5/include-fixed/limits.h \ + /usr/lib/gcc/x86_64-linux-gnu/5/include-fixed/syslimits.h \ + /usr/include/limits.h /usr/include/x86_64-linux-gnu/bits/posix1_lim.h \ + /usr/include/x86_64-linux-gnu/bits/local_lim.h \ + /usr/include/linux/limits.h \ + /usr/include/x86_64-linux-gnu/bits/posix2_lim.h \ + /usr/include/x86_64-linux-gnu/bits/waitflags.h \ + /usr/include/x86_64-linux-gnu/bits/waitstatus.h \ + /usr/include/x86_64-linux-gnu/sys/types.h /usr/include/time.h \ + /usr/include/x86_64-linux-gnu/sys/select.h \ + /usr/include/x86_64-linux-gnu/bits/select.h \ + /usr/include/x86_64-linux-gnu/bits/sigset.h \ + /usr/include/x86_64-linux-gnu/bits/time.h \ + /usr/include/x86_64-linux-gnu/bits/select2.h \ + /usr/include/x86_64-linux-gnu/sys/sysmacros.h \ + /usr/include/x86_64-linux-gnu/bits/pthreadtypes.h /usr/include/alloca.h \ + /usr/include/x86_64-linux-gnu/bits/stdlib-bsearch.h \ + /usr/include/x86_64-linux-gnu/bits/stdlib-float.h \ + /usr/include/x86_64-linux-gnu/bits/stdlib.h src/c/gsort.h \ + ../../modules/core/includes/machine.h \ + src/c/../../../string/includes/men_Sutils.h \ + src/c/../../../string/includes/dynlib_string.h \ + ../../modules/core/includes/MALLOC.h \ + ../../modules/core/includes/sci_mem_alloc.h src/c/qsort.h \ + src/c/qsort-string.h src/c/qsort-short.h src/c/qsort-int.h \ + src/c/qsort-double.h src/c/qsort-char.h + +/usr/include/stdc-predef.h: + +/usr/include/stdio.h: + +/usr/include/features.h: + +/usr/include/x86_64-linux-gnu/sys/cdefs.h: + +/usr/include/x86_64-linux-gnu/bits/wordsize.h: + +/usr/include/x86_64-linux-gnu/gnu/stubs.h: + +/usr/include/x86_64-linux-gnu/gnu/stubs-64.h: + +/usr/lib/gcc/x86_64-linux-gnu/5/include/stddef.h: + +/usr/include/x86_64-linux-gnu/bits/types.h: + +/usr/include/x86_64-linux-gnu/bits/typesizes.h: + +/usr/include/libio.h: + +/usr/include/_G_config.h: + +/usr/include/wchar.h: + +/usr/lib/gcc/x86_64-linux-gnu/5/include/stdarg.h: + +/usr/include/x86_64-linux-gnu/bits/stdio_lim.h: + +/usr/include/x86_64-linux-gnu/bits/sys_errlist.h: + +/usr/include/x86_64-linux-gnu/bits/stdio.h: + +/usr/include/x86_64-linux-gnu/bits/stdio2.h: + +/usr/include/string.h: + +/usr/include/xlocale.h: + +/usr/include/x86_64-linux-gnu/bits/string.h: + +/usr/include/x86_64-linux-gnu/bits/string2.h: + +/usr/include/endian.h: + +/usr/include/x86_64-linux-gnu/bits/endian.h: + +/usr/include/x86_64-linux-gnu/bits/byteswap.h: + +/usr/include/x86_64-linux-gnu/bits/byteswap-16.h: + +/usr/include/stdlib.h: + +/usr/include/x86_64-linux-gnu/bits/string3.h: + +/usr/include/math.h: + +/usr/include/x86_64-linux-gnu/bits/math-vector.h: + +/usr/include/x86_64-linux-gnu/bits/libm-simd-decl-stubs.h: + +/usr/include/x86_64-linux-gnu/bits/huge_val.h: + +/usr/include/x86_64-linux-gnu/bits/huge_valf.h: + +/usr/include/x86_64-linux-gnu/bits/huge_vall.h: + +/usr/include/x86_64-linux-gnu/bits/inf.h: + +/usr/include/x86_64-linux-gnu/bits/nan.h: + +/usr/include/x86_64-linux-gnu/bits/mathdef.h: + +/usr/include/x86_64-linux-gnu/bits/mathcalls.h: + +/usr/include/x86_64-linux-gnu/bits/mathinline.h: + +../../modules/core/includes/core_math.h: + +/usr/lib/gcc/x86_64-linux-gnu/5/include-fixed/limits.h: + +/usr/lib/gcc/x86_64-linux-gnu/5/include-fixed/syslimits.h: + +/usr/include/limits.h: + +/usr/include/x86_64-linux-gnu/bits/posix1_lim.h: + +/usr/include/x86_64-linux-gnu/bits/local_lim.h: + +/usr/include/linux/limits.h: + +/usr/include/x86_64-linux-gnu/bits/posix2_lim.h: + +/usr/include/x86_64-linux-gnu/bits/waitflags.h: + +/usr/include/x86_64-linux-gnu/bits/waitstatus.h: + +/usr/include/x86_64-linux-gnu/sys/types.h: + +/usr/include/time.h: + +/usr/include/x86_64-linux-gnu/sys/select.h: + +/usr/include/x86_64-linux-gnu/bits/select.h: + +/usr/include/x86_64-linux-gnu/bits/sigset.h: + +/usr/include/x86_64-linux-gnu/bits/time.h: + +/usr/include/x86_64-linux-gnu/bits/select2.h: + +/usr/include/x86_64-linux-gnu/sys/sysmacros.h: + +/usr/include/x86_64-linux-gnu/bits/pthreadtypes.h: + +/usr/include/alloca.h: + +/usr/include/x86_64-linux-gnu/bits/stdlib-bsearch.h: + +/usr/include/x86_64-linux-gnu/bits/stdlib-float.h: + +/usr/include/x86_64-linux-gnu/bits/stdlib.h: + +src/c/gsort.h: + +../../modules/core/includes/machine.h: + +src/c/../../../string/includes/men_Sutils.h: + +src/c/../../../string/includes/dynlib_string.h: + +../../modules/core/includes/MALLOC.h: + +../../modules/core/includes/sci_mem_alloc.h: + +src/c/qsort.h: + +src/c/qsort-string.h: + +src/c/qsort-short.h: + +src/c/qsort-int.h: + +src/c/qsort-double.h: + +src/c/qsort-char.h: diff --git a/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-idmax.Plo b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-idmax.Plo new file mode 100755 index 000000000..da5cb7fa9 --- /dev/null +++ b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-idmax.Plo @@ -0,0 +1,18 @@ +src/c/libscielementary_functions_algo_la-idmax.lo: src/c/idmax.c \ + /usr/include/stdc-predef.h includes/idmax.h \ + ../../modules/core/includes/machine.h \ + includes/dynlib_elementary_functions.h \ + ../../modules/core/includes/isanan.h \ + ../../modules/core/includes/machine.h + +/usr/include/stdc-predef.h: + +includes/idmax.h: + +../../modules/core/includes/machine.h: + +includes/dynlib_elementary_functions.h: + +../../modules/core/includes/isanan.h: + +../../modules/core/includes/machine.h: diff --git a/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-idmin.Plo b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-idmin.Plo new file mode 100755 index 000000000..5c55f8ced --- /dev/null +++ b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-idmin.Plo @@ -0,0 +1,18 @@ +src/c/libscielementary_functions_algo_la-idmin.lo: src/c/idmin.c \ + /usr/include/stdc-predef.h includes/idmin.h \ + ../../modules/core/includes/machine.h \ + includes/dynlib_elementary_functions.h \ + ../../modules/core/includes/isanan.h \ + ../../modules/core/includes/machine.h + +/usr/include/stdc-predef.h: + +includes/idmin.h: + +../../modules/core/includes/machine.h: + +includes/dynlib_elementary_functions.h: + +../../modules/core/includes/isanan.h: + +../../modules/core/includes/machine.h: diff --git a/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-int2db.Plo b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-int2db.Plo new file mode 100755 index 000000000..c999d604b --- /dev/null +++ b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-int2db.Plo @@ -0,0 +1,12 @@ +src/c/libscielementary_functions_algo_la-int2db.lo: src/c/int2db.c \ + /usr/include/stdc-predef.h includes/int2db.h \ + ../../modules/core/includes/machine.h \ + includes/dynlib_elementary_functions.h + +/usr/include/stdc-predef.h: + +includes/int2db.h: + +../../modules/core/includes/machine.h: + +includes/dynlib_elementary_functions.h: diff --git a/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-qsort-char.Plo b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-qsort-char.Plo new file mode 100755 index 000000000..2c5908ca5 --- /dev/null +++ b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-qsort-char.Plo @@ -0,0 +1,9 @@ +src/c/libscielementary_functions_algo_la-qsort-char.lo: \ + src/c/qsort-char.c /usr/include/stdc-predef.h src/c/qsort.h \ + src/c/qsort-char.h + +/usr/include/stdc-predef.h: + +src/c/qsort.h: + +src/c/qsort-char.h: diff --git a/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-qsort-double.Plo b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-qsort-double.Plo new file mode 100755 index 000000000..388d48fc5 --- /dev/null +++ b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-qsort-double.Plo @@ -0,0 +1,14 @@ +src/c/libscielementary_functions_algo_la-qsort-double.lo: \ + src/c/qsort-double.c /usr/include/stdc-predef.h src/c/qsort.h \ + src/c/qsort-double.h ../../modules/core/includes/isanan.h \ + ../../modules/core/includes/machine.h + +/usr/include/stdc-predef.h: + +src/c/qsort.h: + +src/c/qsort-double.h: + +../../modules/core/includes/isanan.h: + +../../modules/core/includes/machine.h: diff --git a/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-qsort-int.Plo b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-qsort-int.Plo new file mode 100755 index 000000000..24c5e437d --- /dev/null +++ b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-qsort-int.Plo @@ -0,0 +1,8 @@ +src/c/libscielementary_functions_algo_la-qsort-int.lo: src/c/qsort-int.c \ + /usr/include/stdc-predef.h src/c/qsort.h src/c/qsort-int.h + +/usr/include/stdc-predef.h: + +src/c/qsort.h: + +src/c/qsort-int.h: diff --git a/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-qsort-short.Plo b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-qsort-short.Plo new file mode 100755 index 000000000..74d473998 --- /dev/null +++ b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-qsort-short.Plo @@ -0,0 +1,9 @@ +src/c/libscielementary_functions_algo_la-qsort-short.lo: \ + src/c/qsort-short.c /usr/include/stdc-predef.h src/c/qsort.h \ + src/c/qsort-short.h + +/usr/include/stdc-predef.h: + +src/c/qsort.h: + +src/c/qsort-short.h: diff --git a/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-qsort-string.Plo b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-qsort-string.Plo new file mode 100755 index 000000000..cbc59976c --- /dev/null +++ b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-qsort-string.Plo @@ -0,0 +1,58 @@ +src/c/libscielementary_functions_algo_la-qsort-string.lo: \ + src/c/qsort-string.c /usr/include/stdc-predef.h /usr/include/string.h \ + /usr/include/features.h /usr/include/x86_64-linux-gnu/sys/cdefs.h \ + /usr/include/x86_64-linux-gnu/bits/wordsize.h \ + /usr/include/x86_64-linux-gnu/gnu/stubs.h \ + /usr/include/x86_64-linux-gnu/gnu/stubs-64.h \ + /usr/lib/gcc/x86_64-linux-gnu/5/include/stddef.h /usr/include/xlocale.h \ + /usr/include/x86_64-linux-gnu/bits/string.h \ + /usr/include/x86_64-linux-gnu/bits/string2.h /usr/include/endian.h \ + /usr/include/x86_64-linux-gnu/bits/endian.h \ + /usr/include/x86_64-linux-gnu/bits/byteswap.h \ + /usr/include/x86_64-linux-gnu/bits/types.h \ + /usr/include/x86_64-linux-gnu/bits/typesizes.h \ + /usr/include/x86_64-linux-gnu/bits/byteswap-16.h /usr/include/stdlib.h \ + /usr/include/x86_64-linux-gnu/bits/string3.h src/c/qsort.h \ + src/c/qsort-string.h + +/usr/include/stdc-predef.h: + +/usr/include/string.h: + +/usr/include/features.h: + +/usr/include/x86_64-linux-gnu/sys/cdefs.h: + +/usr/include/x86_64-linux-gnu/bits/wordsize.h: + +/usr/include/x86_64-linux-gnu/gnu/stubs.h: + +/usr/include/x86_64-linux-gnu/gnu/stubs-64.h: + +/usr/lib/gcc/x86_64-linux-gnu/5/include/stddef.h: + +/usr/include/xlocale.h: + +/usr/include/x86_64-linux-gnu/bits/string.h: + +/usr/include/x86_64-linux-gnu/bits/string2.h: + +/usr/include/endian.h: + +/usr/include/x86_64-linux-gnu/bits/endian.h: + +/usr/include/x86_64-linux-gnu/bits/byteswap.h: + +/usr/include/x86_64-linux-gnu/bits/types.h: + +/usr/include/x86_64-linux-gnu/bits/typesizes.h: + +/usr/include/x86_64-linux-gnu/bits/byteswap-16.h: + +/usr/include/stdlib.h: + +/usr/include/x86_64-linux-gnu/bits/string3.h: + +src/c/qsort.h: + +src/c/qsort-string.h: diff --git a/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-qsort.Plo b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-qsort.Plo new file mode 100755 index 000000000..906cf1470 --- /dev/null +++ b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-qsort.Plo @@ -0,0 +1,165 @@ +src/c/libscielementary_functions_algo_la-qsort.lo: src/c/qsort.c \ + /usr/include/stdc-predef.h /usr/include/stdlib.h /usr/include/features.h \ + /usr/include/x86_64-linux-gnu/sys/cdefs.h \ + /usr/include/x86_64-linux-gnu/bits/wordsize.h \ + /usr/include/x86_64-linux-gnu/gnu/stubs.h \ + /usr/include/x86_64-linux-gnu/gnu/stubs-64.h \ + /usr/lib/gcc/x86_64-linux-gnu/5/include/stddef.h \ + /usr/include/x86_64-linux-gnu/bits/waitflags.h \ + /usr/include/x86_64-linux-gnu/bits/waitstatus.h /usr/include/endian.h \ + /usr/include/x86_64-linux-gnu/bits/endian.h \ + /usr/include/x86_64-linux-gnu/bits/byteswap.h \ + /usr/include/x86_64-linux-gnu/bits/types.h \ + /usr/include/x86_64-linux-gnu/bits/typesizes.h \ + /usr/include/x86_64-linux-gnu/bits/byteswap-16.h \ + /usr/include/x86_64-linux-gnu/sys/types.h /usr/include/time.h \ + /usr/include/x86_64-linux-gnu/sys/select.h \ + /usr/include/x86_64-linux-gnu/bits/select.h \ + /usr/include/x86_64-linux-gnu/bits/sigset.h \ + /usr/include/x86_64-linux-gnu/bits/time.h \ + /usr/include/x86_64-linux-gnu/bits/select2.h \ + /usr/include/x86_64-linux-gnu/sys/sysmacros.h \ + /usr/include/x86_64-linux-gnu/bits/pthreadtypes.h /usr/include/alloca.h \ + /usr/include/x86_64-linux-gnu/bits/stdlib-bsearch.h \ + /usr/include/x86_64-linux-gnu/bits/stdlib-float.h \ + /usr/include/x86_64-linux-gnu/bits/stdlib.h /usr/include/string.h \ + /usr/include/xlocale.h /usr/include/x86_64-linux-gnu/bits/string.h \ + /usr/include/x86_64-linux-gnu/bits/string2.h \ + /usr/include/x86_64-linux-gnu/bits/string3.h src/c/qsort.h \ + src/c/qsort-int.h src/c/qsort-short.h src/c/qsort-char.h \ + src/c/qsort-double.h src/c/qsort-string.h \ + ../../modules/core/includes/core_math.h \ + /usr/lib/gcc/x86_64-linux-gnu/5/include-fixed/limits.h \ + /usr/lib/gcc/x86_64-linux-gnu/5/include-fixed/syslimits.h \ + /usr/include/limits.h /usr/include/x86_64-linux-gnu/bits/posix1_lim.h \ + /usr/include/x86_64-linux-gnu/bits/local_lim.h \ + /usr/include/linux/limits.h \ + /usr/include/x86_64-linux-gnu/bits/posix2_lim.h /usr/include/math.h \ + /usr/include/x86_64-linux-gnu/bits/math-vector.h \ + /usr/include/x86_64-linux-gnu/bits/libm-simd-decl-stubs.h \ + /usr/include/x86_64-linux-gnu/bits/huge_val.h \ + /usr/include/x86_64-linux-gnu/bits/huge_valf.h \ + /usr/include/x86_64-linux-gnu/bits/huge_vall.h \ + /usr/include/x86_64-linux-gnu/bits/inf.h \ + /usr/include/x86_64-linux-gnu/bits/nan.h \ + /usr/include/x86_64-linux-gnu/bits/mathdef.h \ + /usr/include/x86_64-linux-gnu/bits/mathcalls.h \ + /usr/include/x86_64-linux-gnu/bits/mathinline.h + +/usr/include/stdc-predef.h: + +/usr/include/stdlib.h: + +/usr/include/features.h: + +/usr/include/x86_64-linux-gnu/sys/cdefs.h: + +/usr/include/x86_64-linux-gnu/bits/wordsize.h: + +/usr/include/x86_64-linux-gnu/gnu/stubs.h: + +/usr/include/x86_64-linux-gnu/gnu/stubs-64.h: + +/usr/lib/gcc/x86_64-linux-gnu/5/include/stddef.h: + +/usr/include/x86_64-linux-gnu/bits/waitflags.h: + +/usr/include/x86_64-linux-gnu/bits/waitstatus.h: + +/usr/include/endian.h: + +/usr/include/x86_64-linux-gnu/bits/endian.h: + +/usr/include/x86_64-linux-gnu/bits/byteswap.h: + +/usr/include/x86_64-linux-gnu/bits/types.h: + +/usr/include/x86_64-linux-gnu/bits/typesizes.h: + +/usr/include/x86_64-linux-gnu/bits/byteswap-16.h: + +/usr/include/x86_64-linux-gnu/sys/types.h: + +/usr/include/time.h: + +/usr/include/x86_64-linux-gnu/sys/select.h: + +/usr/include/x86_64-linux-gnu/bits/select.h: + +/usr/include/x86_64-linux-gnu/bits/sigset.h: + +/usr/include/x86_64-linux-gnu/bits/time.h: + +/usr/include/x86_64-linux-gnu/bits/select2.h: + +/usr/include/x86_64-linux-gnu/sys/sysmacros.h: + +/usr/include/x86_64-linux-gnu/bits/pthreadtypes.h: + +/usr/include/alloca.h: + +/usr/include/x86_64-linux-gnu/bits/stdlib-bsearch.h: + +/usr/include/x86_64-linux-gnu/bits/stdlib-float.h: + +/usr/include/x86_64-linux-gnu/bits/stdlib.h: + +/usr/include/string.h: + +/usr/include/xlocale.h: + +/usr/include/x86_64-linux-gnu/bits/string.h: + +/usr/include/x86_64-linux-gnu/bits/string2.h: + +/usr/include/x86_64-linux-gnu/bits/string3.h: + +src/c/qsort.h: + +src/c/qsort-int.h: + +src/c/qsort-short.h: + +src/c/qsort-char.h: + +src/c/qsort-double.h: + +src/c/qsort-string.h: + +../../modules/core/includes/core_math.h: + +/usr/lib/gcc/x86_64-linux-gnu/5/include-fixed/limits.h: + +/usr/lib/gcc/x86_64-linux-gnu/5/include-fixed/syslimits.h: + +/usr/include/limits.h: + +/usr/include/x86_64-linux-gnu/bits/posix1_lim.h: + +/usr/include/x86_64-linux-gnu/bits/local_lim.h: + +/usr/include/linux/limits.h: + +/usr/include/x86_64-linux-gnu/bits/posix2_lim.h: + +/usr/include/math.h: + +/usr/include/x86_64-linux-gnu/bits/math-vector.h: + +/usr/include/x86_64-linux-gnu/bits/libm-simd-decl-stubs.h: + +/usr/include/x86_64-linux-gnu/bits/huge_val.h: + +/usr/include/x86_64-linux-gnu/bits/huge_valf.h: + +/usr/include/x86_64-linux-gnu/bits/huge_vall.h: + +/usr/include/x86_64-linux-gnu/bits/inf.h: + +/usr/include/x86_64-linux-gnu/bits/nan.h: + +/usr/include/x86_64-linux-gnu/bits/mathdef.h: + +/usr/include/x86_64-linux-gnu/bits/mathcalls.h: + +/usr/include/x86_64-linux-gnu/bits/mathinline.h: diff --git a/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-rea2db.Plo b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-rea2db.Plo new file mode 100755 index 000000000..a9c079a78 --- /dev/null +++ b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-rea2db.Plo @@ -0,0 +1,12 @@ +src/c/libscielementary_functions_algo_la-rea2db.lo: src/c/rea2db.c \ + /usr/include/stdc-predef.h includes/rea2db.h \ + ../../modules/core/includes/machine.h \ + includes/dynlib_elementary_functions.h + +/usr/include/stdc-predef.h: + +includes/rea2db.h: + +../../modules/core/includes/machine.h: + +includes/dynlib_elementary_functions.h: diff --git a/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-scidcopy.Plo b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-scidcopy.Plo new file mode 100755 index 000000000..7b8bb9d57 --- /dev/null +++ b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-scidcopy.Plo @@ -0,0 +1,61 @@ +src/c/libscielementary_functions_algo_la-scidcopy.lo: src/c/scidcopy.c \ + /usr/include/stdc-predef.h /usr/include/string.h /usr/include/features.h \ + /usr/include/x86_64-linux-gnu/sys/cdefs.h \ + /usr/include/x86_64-linux-gnu/bits/wordsize.h \ + /usr/include/x86_64-linux-gnu/gnu/stubs.h \ + /usr/include/x86_64-linux-gnu/gnu/stubs-64.h \ + /usr/lib/gcc/x86_64-linux-gnu/5/include/stddef.h /usr/include/xlocale.h \ + /usr/include/x86_64-linux-gnu/bits/string.h \ + /usr/include/x86_64-linux-gnu/bits/string2.h /usr/include/endian.h \ + /usr/include/x86_64-linux-gnu/bits/endian.h \ + /usr/include/x86_64-linux-gnu/bits/byteswap.h \ + /usr/include/x86_64-linux-gnu/bits/types.h \ + /usr/include/x86_64-linux-gnu/bits/typesizes.h \ + /usr/include/x86_64-linux-gnu/bits/byteswap-16.h /usr/include/stdlib.h \ + /usr/include/x86_64-linux-gnu/bits/string3.h \ + ../../modules/core/includes/machine.h includes/scidcopy.h \ + includes/dynlib_elementary_functions.h + +/usr/include/stdc-predef.h: + +/usr/include/string.h: + +/usr/include/features.h: + +/usr/include/x86_64-linux-gnu/sys/cdefs.h: + +/usr/include/x86_64-linux-gnu/bits/wordsize.h: + +/usr/include/x86_64-linux-gnu/gnu/stubs.h: + +/usr/include/x86_64-linux-gnu/gnu/stubs-64.h: + +/usr/lib/gcc/x86_64-linux-gnu/5/include/stddef.h: + +/usr/include/xlocale.h: + +/usr/include/x86_64-linux-gnu/bits/string.h: + +/usr/include/x86_64-linux-gnu/bits/string2.h: + +/usr/include/endian.h: + +/usr/include/x86_64-linux-gnu/bits/endian.h: + +/usr/include/x86_64-linux-gnu/bits/byteswap.h: + +/usr/include/x86_64-linux-gnu/bits/types.h: + +/usr/include/x86_64-linux-gnu/bits/typesizes.h: + +/usr/include/x86_64-linux-gnu/bits/byteswap-16.h: + +/usr/include/stdlib.h: + +/usr/include/x86_64-linux-gnu/bits/string3.h: + +../../modules/core/includes/machine.h: + +includes/scidcopy.h: + +includes/dynlib_elementary_functions.h: diff --git a/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-vceil.Plo b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-vceil.Plo new file mode 100755 index 000000000..92658e318 --- /dev/null +++ b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-vceil.Plo @@ -0,0 +1,58 @@ +src/c/libscielementary_functions_algo_la-vceil.lo: src/c/vceil.c \ + /usr/include/stdc-predef.h /usr/include/math.h /usr/include/features.h \ + /usr/include/x86_64-linux-gnu/sys/cdefs.h \ + /usr/include/x86_64-linux-gnu/bits/wordsize.h \ + /usr/include/x86_64-linux-gnu/gnu/stubs.h \ + /usr/include/x86_64-linux-gnu/gnu/stubs-64.h \ + /usr/include/x86_64-linux-gnu/bits/math-vector.h \ + /usr/include/x86_64-linux-gnu/bits/libm-simd-decl-stubs.h \ + /usr/include/x86_64-linux-gnu/bits/huge_val.h \ + /usr/include/x86_64-linux-gnu/bits/huge_valf.h \ + /usr/include/x86_64-linux-gnu/bits/huge_vall.h \ + /usr/include/x86_64-linux-gnu/bits/inf.h \ + /usr/include/x86_64-linux-gnu/bits/nan.h \ + /usr/include/x86_64-linux-gnu/bits/mathdef.h \ + /usr/include/x86_64-linux-gnu/bits/mathcalls.h \ + /usr/include/x86_64-linux-gnu/bits/mathinline.h \ + ../../modules/core/includes/machine.h src/c/vceil.h \ + includes/dynlib_elementary_functions.h + +/usr/include/stdc-predef.h: + +/usr/include/math.h: + +/usr/include/features.h: + +/usr/include/x86_64-linux-gnu/sys/cdefs.h: + +/usr/include/x86_64-linux-gnu/bits/wordsize.h: + +/usr/include/x86_64-linux-gnu/gnu/stubs.h: + +/usr/include/x86_64-linux-gnu/gnu/stubs-64.h: + +/usr/include/x86_64-linux-gnu/bits/math-vector.h: + +/usr/include/x86_64-linux-gnu/bits/libm-simd-decl-stubs.h: + +/usr/include/x86_64-linux-gnu/bits/huge_val.h: + +/usr/include/x86_64-linux-gnu/bits/huge_valf.h: + +/usr/include/x86_64-linux-gnu/bits/huge_vall.h: + +/usr/include/x86_64-linux-gnu/bits/inf.h: + +/usr/include/x86_64-linux-gnu/bits/nan.h: + +/usr/include/x86_64-linux-gnu/bits/mathdef.h: + +/usr/include/x86_64-linux-gnu/bits/mathcalls.h: + +/usr/include/x86_64-linux-gnu/bits/mathinline.h: + +../../modules/core/includes/machine.h: + +src/c/vceil.h: + +includes/dynlib_elementary_functions.h: diff --git a/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-vfinite.Plo b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-vfinite.Plo new file mode 100755 index 000000000..5b0cecb89 --- /dev/null +++ b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-vfinite.Plo @@ -0,0 +1,156 @@ +src/c/libscielementary_functions_algo_la-vfinite.lo: src/c/vfinite.c \ + /usr/include/stdc-predef.h ../../modules/core/includes/machine.h \ + ../../modules/core/includes/core_math.h \ + /usr/lib/gcc/x86_64-linux-gnu/5/include-fixed/limits.h \ + /usr/lib/gcc/x86_64-linux-gnu/5/include-fixed/syslimits.h \ + /usr/include/limits.h /usr/include/features.h \ + /usr/include/x86_64-linux-gnu/sys/cdefs.h \ + /usr/include/x86_64-linux-gnu/bits/wordsize.h \ + /usr/include/x86_64-linux-gnu/gnu/stubs.h \ + /usr/include/x86_64-linux-gnu/gnu/stubs-64.h \ + /usr/include/x86_64-linux-gnu/bits/posix1_lim.h \ + /usr/include/x86_64-linux-gnu/bits/local_lim.h \ + /usr/include/linux/limits.h \ + /usr/include/x86_64-linux-gnu/bits/posix2_lim.h /usr/include/math.h \ + /usr/include/x86_64-linux-gnu/bits/math-vector.h \ + /usr/include/x86_64-linux-gnu/bits/libm-simd-decl-stubs.h \ + /usr/include/x86_64-linux-gnu/bits/huge_val.h \ + /usr/include/x86_64-linux-gnu/bits/huge_valf.h \ + /usr/include/x86_64-linux-gnu/bits/huge_vall.h \ + /usr/include/x86_64-linux-gnu/bits/inf.h \ + /usr/include/x86_64-linux-gnu/bits/nan.h \ + /usr/include/x86_64-linux-gnu/bits/mathdef.h \ + /usr/include/x86_64-linux-gnu/bits/mathcalls.h \ + /usr/include/x86_64-linux-gnu/bits/mathinline.h /usr/include/stdlib.h \ + /usr/lib/gcc/x86_64-linux-gnu/5/include/stddef.h \ + /usr/include/x86_64-linux-gnu/bits/waitflags.h \ + /usr/include/x86_64-linux-gnu/bits/waitstatus.h /usr/include/endian.h \ + /usr/include/x86_64-linux-gnu/bits/endian.h \ + /usr/include/x86_64-linux-gnu/bits/byteswap.h \ + /usr/include/x86_64-linux-gnu/bits/types.h \ + /usr/include/x86_64-linux-gnu/bits/typesizes.h \ + /usr/include/x86_64-linux-gnu/bits/byteswap-16.h \ + /usr/include/x86_64-linux-gnu/sys/types.h /usr/include/time.h \ + /usr/include/x86_64-linux-gnu/sys/select.h \ + /usr/include/x86_64-linux-gnu/bits/select.h \ + /usr/include/x86_64-linux-gnu/bits/sigset.h \ + /usr/include/x86_64-linux-gnu/bits/time.h \ + /usr/include/x86_64-linux-gnu/bits/select2.h \ + /usr/include/x86_64-linux-gnu/sys/sysmacros.h \ + /usr/include/x86_64-linux-gnu/bits/pthreadtypes.h /usr/include/alloca.h \ + /usr/include/x86_64-linux-gnu/bits/stdlib-bsearch.h \ + /usr/include/x86_64-linux-gnu/bits/stdlib-float.h \ + /usr/include/x86_64-linux-gnu/bits/stdlib.h /usr/include/values.h \ + /usr/lib/gcc/x86_64-linux-gnu/5/include/float.h includes/vfinite.h \ + ../../modules/core/includes/doublecomplex.h \ + includes/dynlib_elementary_functions.h includes/finite.h + +/usr/include/stdc-predef.h: + +../../modules/core/includes/machine.h: + +../../modules/core/includes/core_math.h: + +/usr/lib/gcc/x86_64-linux-gnu/5/include-fixed/limits.h: + +/usr/lib/gcc/x86_64-linux-gnu/5/include-fixed/syslimits.h: + +/usr/include/limits.h: + +/usr/include/features.h: + +/usr/include/x86_64-linux-gnu/sys/cdefs.h: + +/usr/include/x86_64-linux-gnu/bits/wordsize.h: + +/usr/include/x86_64-linux-gnu/gnu/stubs.h: + +/usr/include/x86_64-linux-gnu/gnu/stubs-64.h: + +/usr/include/x86_64-linux-gnu/bits/posix1_lim.h: + +/usr/include/x86_64-linux-gnu/bits/local_lim.h: + +/usr/include/linux/limits.h: + +/usr/include/x86_64-linux-gnu/bits/posix2_lim.h: + +/usr/include/math.h: + +/usr/include/x86_64-linux-gnu/bits/math-vector.h: + +/usr/include/x86_64-linux-gnu/bits/libm-simd-decl-stubs.h: + +/usr/include/x86_64-linux-gnu/bits/huge_val.h: + +/usr/include/x86_64-linux-gnu/bits/huge_valf.h: + +/usr/include/x86_64-linux-gnu/bits/huge_vall.h: + +/usr/include/x86_64-linux-gnu/bits/inf.h: + +/usr/include/x86_64-linux-gnu/bits/nan.h: + +/usr/include/x86_64-linux-gnu/bits/mathdef.h: + +/usr/include/x86_64-linux-gnu/bits/mathcalls.h: + +/usr/include/x86_64-linux-gnu/bits/mathinline.h: + +/usr/include/stdlib.h: + +/usr/lib/gcc/x86_64-linux-gnu/5/include/stddef.h: + +/usr/include/x86_64-linux-gnu/bits/waitflags.h: + +/usr/include/x86_64-linux-gnu/bits/waitstatus.h: + +/usr/include/endian.h: + +/usr/include/x86_64-linux-gnu/bits/endian.h: + +/usr/include/x86_64-linux-gnu/bits/byteswap.h: + +/usr/include/x86_64-linux-gnu/bits/types.h: + +/usr/include/x86_64-linux-gnu/bits/typesizes.h: + +/usr/include/x86_64-linux-gnu/bits/byteswap-16.h: + +/usr/include/x86_64-linux-gnu/sys/types.h: + +/usr/include/time.h: + +/usr/include/x86_64-linux-gnu/sys/select.h: + +/usr/include/x86_64-linux-gnu/bits/select.h: + +/usr/include/x86_64-linux-gnu/bits/sigset.h: + +/usr/include/x86_64-linux-gnu/bits/time.h: + +/usr/include/x86_64-linux-gnu/bits/select2.h: + +/usr/include/x86_64-linux-gnu/sys/sysmacros.h: + +/usr/include/x86_64-linux-gnu/bits/pthreadtypes.h: + +/usr/include/alloca.h: + +/usr/include/x86_64-linux-gnu/bits/stdlib-bsearch.h: + +/usr/include/x86_64-linux-gnu/bits/stdlib-float.h: + +/usr/include/x86_64-linux-gnu/bits/stdlib.h: + +/usr/include/values.h: + +/usr/lib/gcc/x86_64-linux-gnu/5/include/float.h: + +includes/vfinite.h: + +../../modules/core/includes/doublecomplex.h: + +includes/dynlib_elementary_functions.h: + +includes/finite.h: diff --git a/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-vfloor.Plo b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-vfloor.Plo new file mode 100755 index 000000000..53ca62166 --- /dev/null +++ b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-vfloor.Plo @@ -0,0 +1,58 @@ +src/c/libscielementary_functions_algo_la-vfloor.lo: src/c/vfloor.c \ + /usr/include/stdc-predef.h /usr/include/math.h /usr/include/features.h \ + /usr/include/x86_64-linux-gnu/sys/cdefs.h \ + /usr/include/x86_64-linux-gnu/bits/wordsize.h \ + /usr/include/x86_64-linux-gnu/gnu/stubs.h \ + /usr/include/x86_64-linux-gnu/gnu/stubs-64.h \ + /usr/include/x86_64-linux-gnu/bits/math-vector.h \ + /usr/include/x86_64-linux-gnu/bits/libm-simd-decl-stubs.h \ + /usr/include/x86_64-linux-gnu/bits/huge_val.h \ + /usr/include/x86_64-linux-gnu/bits/huge_valf.h \ + /usr/include/x86_64-linux-gnu/bits/huge_vall.h \ + /usr/include/x86_64-linux-gnu/bits/inf.h \ + /usr/include/x86_64-linux-gnu/bits/nan.h \ + /usr/include/x86_64-linux-gnu/bits/mathdef.h \ + /usr/include/x86_64-linux-gnu/bits/mathcalls.h \ + /usr/include/x86_64-linux-gnu/bits/mathinline.h \ + ../../modules/core/includes/machine.h src/c/vfloor.h \ + includes/dynlib_elementary_functions.h + +/usr/include/stdc-predef.h: + +/usr/include/math.h: + +/usr/include/features.h: + +/usr/include/x86_64-linux-gnu/sys/cdefs.h: + +/usr/include/x86_64-linux-gnu/bits/wordsize.h: + +/usr/include/x86_64-linux-gnu/gnu/stubs.h: + +/usr/include/x86_64-linux-gnu/gnu/stubs-64.h: + +/usr/include/x86_64-linux-gnu/bits/math-vector.h: + +/usr/include/x86_64-linux-gnu/bits/libm-simd-decl-stubs.h: + +/usr/include/x86_64-linux-gnu/bits/huge_val.h: + +/usr/include/x86_64-linux-gnu/bits/huge_valf.h: + +/usr/include/x86_64-linux-gnu/bits/huge_vall.h: + +/usr/include/x86_64-linux-gnu/bits/inf.h: + +/usr/include/x86_64-linux-gnu/bits/nan.h: + +/usr/include/x86_64-linux-gnu/bits/mathdef.h: + +/usr/include/x86_64-linux-gnu/bits/mathcalls.h: + +/usr/include/x86_64-linux-gnu/bits/mathinline.h: + +../../modules/core/includes/machine.h: + +src/c/vfloor.h: + +includes/dynlib_elementary_functions.h: diff --git a/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-vfrexp.Plo b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-vfrexp.Plo new file mode 100755 index 000000000..dcfd6aa47 --- /dev/null +++ b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-vfrexp.Plo @@ -0,0 +1,58 @@ +src/c/libscielementary_functions_algo_la-vfrexp.lo: src/c/vfrexp.c \ + /usr/include/stdc-predef.h /usr/include/math.h /usr/include/features.h \ + /usr/include/x86_64-linux-gnu/sys/cdefs.h \ + /usr/include/x86_64-linux-gnu/bits/wordsize.h \ + /usr/include/x86_64-linux-gnu/gnu/stubs.h \ + /usr/include/x86_64-linux-gnu/gnu/stubs-64.h \ + /usr/include/x86_64-linux-gnu/bits/math-vector.h \ + /usr/include/x86_64-linux-gnu/bits/libm-simd-decl-stubs.h \ + /usr/include/x86_64-linux-gnu/bits/huge_val.h \ + /usr/include/x86_64-linux-gnu/bits/huge_valf.h \ + /usr/include/x86_64-linux-gnu/bits/huge_vall.h \ + /usr/include/x86_64-linux-gnu/bits/inf.h \ + /usr/include/x86_64-linux-gnu/bits/nan.h \ + /usr/include/x86_64-linux-gnu/bits/mathdef.h \ + /usr/include/x86_64-linux-gnu/bits/mathcalls.h \ + /usr/include/x86_64-linux-gnu/bits/mathinline.h \ + ../../modules/core/includes/machine.h src/c/vfrexp.h \ + includes/dynlib_elementary_functions.h + +/usr/include/stdc-predef.h: + +/usr/include/math.h: + +/usr/include/features.h: + +/usr/include/x86_64-linux-gnu/sys/cdefs.h: + +/usr/include/x86_64-linux-gnu/bits/wordsize.h: + +/usr/include/x86_64-linux-gnu/gnu/stubs.h: + +/usr/include/x86_64-linux-gnu/gnu/stubs-64.h: + +/usr/include/x86_64-linux-gnu/bits/math-vector.h: + +/usr/include/x86_64-linux-gnu/bits/libm-simd-decl-stubs.h: + +/usr/include/x86_64-linux-gnu/bits/huge_val.h: + +/usr/include/x86_64-linux-gnu/bits/huge_valf.h: + +/usr/include/x86_64-linux-gnu/bits/huge_vall.h: + +/usr/include/x86_64-linux-gnu/bits/inf.h: + +/usr/include/x86_64-linux-gnu/bits/nan.h: + +/usr/include/x86_64-linux-gnu/bits/mathdef.h: + +/usr/include/x86_64-linux-gnu/bits/mathcalls.h: + +/usr/include/x86_64-linux-gnu/bits/mathinline.h: + +../../modules/core/includes/machine.h: + +src/c/vfrexp.h: + +includes/dynlib_elementary_functions.h: diff --git a/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-xerhlt.Plo b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-xerhlt.Plo new file mode 100755 index 000000000..7887b9d7a --- /dev/null +++ b/modules/elementary_functions/src/c/.deps/libscielementary_functions_algo_la-xerhlt.Plo @@ -0,0 +1,72 @@ +src/c/libscielementary_functions_algo_la-xerhlt.lo: src/c/xerhlt.c \ + /usr/include/stdc-predef.h /usr/include/string.h /usr/include/features.h \ + /usr/include/x86_64-linux-gnu/sys/cdefs.h \ + /usr/include/x86_64-linux-gnu/bits/wordsize.h \ + /usr/include/x86_64-linux-gnu/gnu/stubs.h \ + /usr/include/x86_64-linux-gnu/gnu/stubs-64.h \ + /usr/lib/gcc/x86_64-linux-gnu/5/include/stddef.h /usr/include/xlocale.h \ + /usr/include/x86_64-linux-gnu/bits/string.h \ + /usr/include/x86_64-linux-gnu/bits/string2.h /usr/include/endian.h \ + /usr/include/x86_64-linux-gnu/bits/endian.h \ + /usr/include/x86_64-linux-gnu/bits/byteswap.h \ + /usr/include/x86_64-linux-gnu/bits/types.h \ + /usr/include/x86_64-linux-gnu/bits/typesizes.h \ + /usr/include/x86_64-linux-gnu/bits/byteswap-16.h /usr/include/stdlib.h \ + /usr/include/x86_64-linux-gnu/bits/string3.h /usr/include/setjmp.h \ + /usr/include/x86_64-linux-gnu/bits/setjmp.h \ + /usr/include/x86_64-linux-gnu/bits/sigset.h \ + /usr/include/x86_64-linux-gnu/bits/setjmp2.h includes/xerhlt.h \ + ../../modules/core/includes/machine.h \ + includes/dynlib_elementary_functions.h + +/usr/include/stdc-predef.h: + +/usr/include/string.h: + +/usr/include/features.h: + +/usr/include/x86_64-linux-gnu/sys/cdefs.h: + +/usr/include/x86_64-linux-gnu/bits/wordsize.h: + +/usr/include/x86_64-linux-gnu/gnu/stubs.h: + +/usr/include/x86_64-linux-gnu/gnu/stubs-64.h: + +/usr/lib/gcc/x86_64-linux-gnu/5/include/stddef.h: + +/usr/include/xlocale.h: + +/usr/include/x86_64-linux-gnu/bits/string.h: + +/usr/include/x86_64-linux-gnu/bits/string2.h: + +/usr/include/endian.h: + +/usr/include/x86_64-linux-gnu/bits/endian.h: + +/usr/include/x86_64-linux-gnu/bits/byteswap.h: + +/usr/include/x86_64-linux-gnu/bits/types.h: + +/usr/include/x86_64-linux-gnu/bits/typesizes.h: + +/usr/include/x86_64-linux-gnu/bits/byteswap-16.h: + +/usr/include/stdlib.h: + +/usr/include/x86_64-linux-gnu/bits/string3.h: + +/usr/include/setjmp.h: + +/usr/include/x86_64-linux-gnu/bits/setjmp.h: + +/usr/include/x86_64-linux-gnu/bits/sigset.h: + +/usr/include/x86_64-linux-gnu/bits/setjmp2.h: + +includes/xerhlt.h: + +../../modules/core/includes/machine.h: + +includes/dynlib_elementary_functions.h: diff --git a/modules/elementary_functions/src/c/.dirstamp b/modules/elementary_functions/src/c/.dirstamp new file mode 100755 index 000000000..e69de29bb --- /dev/null +++ b/modules/elementary_functions/src/c/.dirstamp diff --git a/modules/elementary_functions/src/c/.libs/libdummy_elementary_functions_la-unsfdcopy.o b/modules/elementary_functions/src/c/.libs/libdummy_elementary_functions_la-unsfdcopy.o Binary files differnew file mode 100755 index 000000000..be3ad94ae --- /dev/null +++ b/modules/elementary_functions/src/c/.libs/libdummy_elementary_functions_la-unsfdcopy.o diff --git a/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-IsEqualVar.o b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-IsEqualVar.o Binary files differnew file mode 100755 index 000000000..d5e86d8bc --- /dev/null +++ b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-IsEqualVar.o diff --git a/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-cmp.o b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-cmp.o Binary files differnew file mode 100755 index 000000000..6a050040e --- /dev/null +++ b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-cmp.o diff --git a/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-convertbase.o b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-convertbase.o Binary files differnew file mode 100755 index 000000000..6091dc53e --- /dev/null +++ b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-convertbase.o diff --git a/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-finite.o b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-finite.o Binary files differnew file mode 100755 index 000000000..c86af408f --- /dev/null +++ b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-finite.o diff --git a/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-gsort.o b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-gsort.o Binary files differnew file mode 100755 index 000000000..a7be6baab --- /dev/null +++ b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-gsort.o diff --git a/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-idmax.o b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-idmax.o Binary files differnew file mode 100755 index 000000000..2b3c15aa7 --- /dev/null +++ b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-idmax.o diff --git a/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-idmin.o b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-idmin.o Binary files differnew file mode 100755 index 000000000..4860eb608 --- /dev/null +++ b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-idmin.o diff --git a/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-int2db.o b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-int2db.o Binary files differnew file mode 100755 index 000000000..8d3f2c4aa --- /dev/null +++ b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-int2db.o diff --git a/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-qsort-char.o b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-qsort-char.o Binary files differnew file mode 100755 index 000000000..75b37769b --- /dev/null +++ b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-qsort-char.o diff --git a/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-qsort-double.o b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-qsort-double.o Binary files differnew file mode 100755 index 000000000..d88f88c1b --- /dev/null +++ b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-qsort-double.o diff --git a/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-qsort-int.o b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-qsort-int.o Binary files differnew file mode 100755 index 000000000..55c6b0fcc --- /dev/null +++ b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-qsort-int.o diff --git a/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-qsort-short.o b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-qsort-short.o Binary files differnew file mode 100755 index 000000000..b447b3ea8 --- /dev/null +++ b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-qsort-short.o diff --git a/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-qsort-string.o b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-qsort-string.o Binary files differnew file mode 100755 index 000000000..a98b07c2a --- /dev/null +++ b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-qsort-string.o diff --git a/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-qsort.o b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-qsort.o Binary files differnew file mode 100755 index 000000000..9ae5625cc --- /dev/null +++ b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-qsort.o diff --git a/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-rea2db.o b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-rea2db.o Binary files differnew file mode 100755 index 000000000..fab4e7433 --- /dev/null +++ b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-rea2db.o diff --git a/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-scidcopy.o b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-scidcopy.o Binary files differnew file mode 100755 index 000000000..ce6857b24 --- /dev/null +++ b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-scidcopy.o diff --git a/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-vceil.o b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-vceil.o Binary files differnew file mode 100755 index 000000000..026acc1de --- /dev/null +++ b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-vceil.o diff --git a/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-vfinite.o b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-vfinite.o Binary files differnew file mode 100755 index 000000000..28168dffe --- /dev/null +++ b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-vfinite.o diff --git a/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-vfloor.o b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-vfloor.o Binary files differnew file mode 100755 index 000000000..0d9d15ab9 --- /dev/null +++ b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-vfloor.o diff --git a/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-vfrexp.o b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-vfrexp.o Binary files differnew file mode 100755 index 000000000..ed31605e3 --- /dev/null +++ b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-vfrexp.o diff --git a/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-xerhlt.o b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-xerhlt.o Binary files differnew file mode 100755 index 000000000..4a87d20c2 --- /dev/null +++ b/modules/elementary_functions/src/c/.libs/libscielementary_functions_algo_la-xerhlt.o diff --git a/modules/elementary_functions/src/c/DllmainElementary_functions.c b/modules/elementary_functions/src/c/DllmainElementary_functions.c new file mode 100755 index 000000000..d3d8175b4 --- /dev/null +++ b/modules/elementary_functions/src/c/DllmainElementary_functions.c @@ -0,0 +1,34 @@ + +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) 2007-2008 - INRIA - Allan CORNET <allan.cornet@inria.fr> + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ + +#include <windows.h> +/*--------------------------------------------------------------------------*/ +#pragma comment(lib,"../../../../bin/libintl.lib") +/*--------------------------------------------------------------------------*/ +int WINAPI DllMain (HINSTANCE hInstance , DWORD reason, PVOID pvReserved) +{ + switch (reason) + { + case DLL_PROCESS_ATTACH: + break; + case DLL_PROCESS_DETACH: + break; + case DLL_THREAD_ATTACH: + break; + case DLL_THREAD_DETACH: + break; + } + return 1; +} +/*--------------------------------------------------------------------------*/ + diff --git a/modules/elementary_functions/src/c/IsEqualVar.c b/modules/elementary_functions/src/c/IsEqualVar.c new file mode 100755 index 000000000..a2348b5b9 --- /dev/null +++ b/modules/elementary_functions/src/c/IsEqualVar.c @@ -0,0 +1,1339 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) 2007 - INRIA - Serge STEER + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ + +/*------------------------------------------------------------------------ + * isequalbitwise and isequal built-ins definition + * Serge Steer, INRIA 2007 + * Comment: + * This file contains the routines used by the isequalbitwise and isequal builtin functions + --------------------------------------------------------------------------*/ + +#include "IsEqualVar.h" +#include "Scierror.h" +#include "BOOL.h" +#include "parse.h" + +/* Scilab parser recursion data and functions*/ +static int *Ids = NULL; +static int *Rstk = NULL; +static int *Pstk = NULL; +#define Pt (C2F(recu).pt) + +static void initStackParameters(void) +{ + Ids = C2F(recu).ids - nsiz - 1; + Rstk = C2F(recu).rstk - 1; + Pstk = C2F(recu).pstk - 1; +} + +/**intisequalvar +* Gateway for isequalbitwise and isequal builtins +* @param char * fname: the Scilab code of the function name +* @param int * job: if *job==0 the floating point numbers are compared bitwise , +* if *job==1 the comparison is made numerically, +* so NaN elements are not equal +* elements of with differents data types are raised to the upper types before comparison (to be done) +* @return 0 in any cases +* @author Serge Steer +* @see isequal +*/ + +int C2F(intisequalvar)(char * fname, int *job, long int fl) +{ + int topk, top1, srhs, k, kmin, l; + int res = 42; /* Bruno : @TODO initialisation !!! */ + int one = 1; + int l1, lk, il1, ilk; + int n1, nk; //memory size used by the variable, only used for overloaded comparison + + initStackParameters(); + + /*DEBUG_OVERLOADING("entering intisequal Top=%d, Rhs=%d, Rstk[pt]=%d\n",Top,Rhs,Rstk[Pt]);*/ + + + SetDoubleCompMode(*job); /* floating point numbers are compared bitwise */ + if (Rstk[Pt] == 914 || Rstk[Pt] == 915) /* coming back after evaluation of overloading function */ + { + /*DEBUG_OVERLOADING("intisequal called back by the parser Top=%d, Rhs=%d, Pt=%d\n",Top,Rhs,Pt);*/ + + /* Restore context */ + kmin = Ids[1 + Pt * nsiz]; + srhs = Ids[2 + Pt * nsiz]; + topk = Ids[3 + Pt * nsiz]; + top1 = Top - 1 - srhs + 1; /* Top-1 because Top has been increased to store the result of overloading function */ + } + else + { + CheckRhs(2, 2000000); + CheckLhs(1, 1); + srhs = Rhs; + top1 = Top - srhs + 1; + topk = top1 + 1; + kmin = 2; + MaxRec = 0; + Rrec = NULL; + } + + l1 = *Lstk(top1); + il1 = iadr(l1); + n1 = *Lstk(top1 + 1) - l1; + if (*istk(il1) < 0) + { + l1 = *istk(il1 + 1); + n1 = *istk(il1 + 3); + } + for (k = kmin; k <= srhs; k++) + { + + lk = *Lstk(topk); + ilk = iadr(lk); + nk = *Lstk(topk + 1) - lk; + if (*istk(ilk) < 0) + { + lk = *istk(ilk + 1); + nk = *istk(ilk + 3); + } + + res = IsEqualVar(stk(l1), n1, stk(lk), nk); + if (res == -1) /* overloading function evaluation required */ + { + /* save context */ + Ids[1 + Pt * nsiz] = k; + Ids[2 + Pt * nsiz] = srhs; + Ids[3 + Pt * nsiz] = topk; + return 0; + } + else if (res == -2) /* Memory allocation failed */ + { + SciError(112); + FreeRec(); + return 0; + } + /*DEBUG_OVERLOADING("k=%d, res=%d\n", k,res);*/ + + if (res == 0) + { + /* goto END; */ + Top = top1; + C2F(crebmat)(fname, &top1, &one, &one, &l, (unsigned long)strlen(fname)); + *istk(l) = res; + FreeRec(); + + return 0; + } + topk++; + } + + + /* END:*/ + Top = top1; + C2F(crebmat)(fname, &top1, &one, &one, &l, (unsigned long)strlen(fname)); + *istk(l) = res; + FreeRec(); + + return 0; +} + +/**IsEqualOverloaded +* Used to call the overloading function when testing unknown data type for equality +* @param double *d1: pointer on the beginning of the first variable structure +* @param int n1: memory size used by the first variable, only used for overloading +* @param double *d2: pointer on the beginning of the first variable structure +* @param int n2: memory size used by the second variable, only used for overloading +* @return 0 is the variables differ and 1 if they are identical, -1 for recursion purpose +* @author Serge Steer +* @see IsEqualVar +*/ +int IsEqualOverloaded(double *d1, int n1, double *d2, int n2) +{ + int *id1 = (int *) d1; + int *id2 = (int *) d2; + int il, lw; + int l1, l2; + + initStackParameters(); + + if (Rstk[Pt] == 914 || Rstk[Pt] == 915) /* coming back after evaluation of overloading function */ + { + /* Get the computed value */ + il = iadr(*Lstk(Top)); + Top--; + Pt--; + return *istk(il + 3); + } + + /* Prepare stack for calling overloading function */ + /* put references to d1 and d2 variable at the top of the stack */ + l1 = *Lstk(1) + (int)(d1 - stk(*Lstk(1))); /*compute index in stk from absolute adress value */ + l2 = *Lstk(1) + (int)(d2 - stk(*Lstk(1))); /*compute index in stk from absolute adress value */ + + Top = Top + 1; + + il = iadr(*Lstk(Top)); + *istk(il) = -id1[0]; + *istk(il + 1) = l1; /* index othe first element of the variable in stk */ + *istk(il + 2) = 0; /* variable number unknown */ + *istk(il + 3) = n1; /* variable memory size */ + *Lstk(Top + 1) = *Lstk(Top) + 2; + + Top = Top + 1; + il = iadr(*Lstk(Top)); + *istk(il) = -id2[0]; + *istk(il + 1) = l2; /* index othe first element of the variable in stk */ + *istk(il + 2) = 0; /*variable number unknown */ + *istk(il + 3) = n2; /*variable memory size */ + *Lstk(Top + 1) = *Lstk(Top) + 2; + + Ptover(1); + Rhs = 2; + lw = Top - 1; + + if ( GetDoubleCompMode() == 0) + { + C2F(overload)(&lw, "isequalbitwise", 14L); + Rstk[Pt] = 914; + } + else + { + C2F(overload)(&lw, "isequal", 7L); + Rstk[Pt] = 915; + } + + /*DEBUG_OVERLOADING("IsEqualVar Overloaded calls the parser Top=%d, Rhs=%d, Pt=%d\n",Top,Rhs,Pt);*/ + + return -1; +} + +/**IsEqualVar +* Driver used to test a couple of Scilab variable for equality +* @param double *d1: pointer on the beginning of the first variable structure +* @param int n1: memory size used by the first variable, only used for overloading +* @param double *d2: pointer on the beginning of the first variable structure +* @param int n2: memory size used by the second variable, only used for overloading +* @return 0 is the variables differ and 1 if they are identical, -1 for recursion purpose, -2 for allocatopn problem +* @author Serge Steer +* @see intisequal +*/ +int IsEqualVar(double *d1, int n1, double *d2, int n2) +{ + int *id1 = (int *) d1; + int *id2 = (int *) d2; + int res; + + /*DEBUG_BASE("IsEqualVar %d %d\n",id1[0],id2[0]);*/ + + /* Check the type */ + if ((id1[0] != id2[0])) + { + return 0; + } + + switch (id1[0]) + { + case 0: /* null */ + return 1; + case sci_matrix: /* matrix of double precision floating point numbers */ + if ( !IsEqualDoubleMat(d1, d2) ) + { + return 0; + } + break; + case sci_poly:/* matrix of polynomials */ + if ( !IsEqualPolyMat(d1, d2) ) + { + return 0; + } + break; + case sci_boolean:/* matrix of booleans */ + if ( !IsEqualBoolMat(d1, d2) ) + { + return 0; + } + break; + case sci_sparse:/* sparse matrix of double */ + if ( !IsEqualDoubleSparseMat(d1, d2) ) + { + return 0; + } + break; + case sci_boolean_sparse:/* sparse matrix of booleans */ + if ( !IsEqualBoolSparseMat(d1, d2) ) + { + return 0; + } + break; + case sci_matlab_sparse:/* matlab sparse matrix */ + if ( !IsEqualMatlabSparseMat(d1, d2) ) + { + return 0; + } + break; + case sci_ints : /* matrix of short integers */ + if ( !IsEqualIntegerMat(d1, d2) ) + { + return 0; + } + break; + case sci_handles : /* matrix of graphic handles */ + if ( !IsEqualDoubleMat(d1, d2) ) + { + return 0; + } + break; + case sci_strings:/* matrix of strings */ + if ( !IsEqualStringMat(d1, d2) ) + { + return 0; + } + break; + case sci_u_function:/* Uncompiled function */ + case sci_c_function:/* compiled function */ + if ( !IsEqualFunction(d1, d2) ) + { + return 0; + } + break; + case sci_lib:/* library */ + if ( !IsEqualLib(d1, d2) ) + { + return 0; + } + break; + case sci_list: /* list */ + case sci_tlist: /* tlist */ + case sci_mlist: /* mlist */ + res = IsEqualList(d1, d2); + if ( !res ) + { + return 0; + } + if (res < 0) + { + return res; + } + break; + case sci_lufact_pointer: /* lufact pointer */ + if ( !IsEqualLUPtr(d1, d2) ) + { + return 0; + } + break; + default : + res = IsEqualOverloaded(d1, n1, d2, n2); + if ( !res ) + { + return 0; + } + if (res == -1) + { + return -1; + } + } + + return 1; +} + + +/**IsEqualList +* Used to test a couple of Scilab variable of type list, tlist or mlist for equality +* @param double *d1: pointer on the beginning of the first variable structure +* @param double *d2: pointer on the beginning of the first variable structure +* @return 0 is the variables differ and 1 if they are identical, -1 for recursion purpose, -2 for allocatopn problem +* @author Serge Steer +* @see IsEqualVar +*/ +int IsEqualList(double *d1, double *d2) +{ + /* This code does not use simple recursion, because of possible need of + * call to Scilab for evaluation of overloading function + * The redusion is emulated using the Rrec data structure to memorize the path + * to the current element. + */ + int l, k, res, nelt; + int *id1, *id2; + int *ip1, *ip2; + double *p1, *p2; + int krec; + + initStackParameters(); + + if (Rstk[Pt] == 914 || Rstk[Pt] == 915) /* coming back after evaluation of overloading function */ + { + /* Restore context */ + krec = Pstk[Pt]; + MaxRec = Ids[4 + Pt * nsiz] ; + memcpy(&Rrec, &(Ids[5 + Pt * nsiz]), sizeof(RecursionRecordPtr)); /* recover Rrec pointer */ + k = Rrec[krec].k; + d1 = Rrec[krec].d1; /* pointer on the sub-level list 1*/ + d2 = Rrec[krec].d2; /* pointer on the sub-level list 2*/ + id1 = (int *) d1; + id2 = (int *) d2; + nelt = id1[1]; + goto SETLEVEL; + } + else /* regular entry */ + { + krec = 0; + + } + +STARTLEVEL: + /* the objects pointed to by d1 and d2 are lists */ + /* set current level context */ + if (AllocRecIfRequired(krec) == -2) + { + return -2; + } + + Rrec[krec].d1 = d1; + Rrec[krec].d2 = d2; + Rrec[krec].k = 0; + + /* check the type */ + id1 = (int *) d1; + id2 = (int *) d2; + if ((id1[0] != id2[0])) + { + return 0; + } + /* check the number of elements */ + if (id1[1] != id2[1]) + { + return 0; + } + nelt = id1[1]; + + /* check the array of "pointers" on list elements*/ + if (!IsEqualIntegerArray(nelt + 1, id1 + 2, id2 + 2)) + { + return 0; + } + + /*DEBUG_LIST("STARTLEVEL nelt=%d\n",nelt);*/ + + k = 0; +SETLEVEL: + /* check the list elements */ + ip1 = id1 + 2; + ip2 = id2 + 2; + + l = (nelt + 4) / 2; /* the beginning of first field in the double array */ + p1 = d1 + l; + p2 = d2 + l; + +ELEMENT: + if (k >= nelt) /* no more element to compare */ + { + if (krec > 0 ) /* end of a sub-level */ + { + /* restore upper level context*/ + krec--; + /*DEBUG_LIST("Sublist ELEMENT index=%d finished, previous restored from krec=%d\n",k+1,krec);*/ + + d1 = Rrec[krec].d1; + d2 = Rrec[krec].d2; + k = Rrec[krec].k + 1; + /* rebuild pointers */ + id1 = (int *) d1; + id2 = (int *) d2; + nelt = id1[1]; + /*DEBUG_LIST("back to lower level nelt=%d index=%d krec=%d\n",nelt,k+1,krec);*/ + + goto SETLEVEL; + } + else /* end of main level */ + { + return 1; + } + } + /* compare next element */ + if (ip1[k] == ip1[k + 1]) /* undefined element nothing to check */ + { + k++; + goto ELEMENT; + } + d1 = p1 + ip1[k] - 1; + d2 = p2 + ip2[k] - 1; + id1 = (int *)d1; + + if (id1[0] != 15 && id1[0] != 16 && id1[0] != 17) /* elements which are not lists */ + { + res = IsEqualVar(d1, ip1[k + 1] - ip1[k], d2, ip2[k + 1] - ip2[k]); + /*DEBUG_LIST("Regular ELEMENT index=%d res=%d\n",k+1,res);*/ + if (!res) + { + return 0; + } + if (res == -1) /*overloading function evaluation required */ + { + /* preserve context */ + Pstk[Pt] = krec; + Ids[4 + Pt * nsiz] = MaxRec; + /* Store Rrec pointer into Ids[5 + Pt * nsiz] and Ids[6 + Pt * nsiz] */ + memcpy(&(Ids[5 + Pt * nsiz]), &Rrec, sizeof(RecursionRecordPtr)); + return -1; + } + k++; + goto ELEMENT; + + } + else /* sub list found*/ + { + /*DEBUG_LIST("Sublist ELEMENT index=%d started, previous stored in krec=%d\n",k+1,krec);*/ + + Rrec[krec].k = k; + krec++; + + goto STARTLEVEL; + } +} + + +/**IsEqualLib +* Used to test a couple of Scilab variable of type library (14) for equality +* @param double *d1: pointer on the beginning of the first variable structure +* @param double *d2: pointer on the beginning of the first variable structure +* @return 0 is the variables differ and 1 if they are identical +* @author Serge Steer +* @see IsEqualVar +*/ +int IsEqualLib(double *d1, double *d2) +{ + int n, l; + int nclas = 29; + int *id1 = (int *) d1; + int *id2 = (int *) d2; + + /* Check the type */ + if ((id1[0] != id2[0])) + { + return 0; + } + + /* Check the path length */ + if (id1[1] != id2[1]) + { + return 0; + } + + /* Check the path" */ + n = id1[1]; + if (!IsEqualIntegerArray(n, id1 + 2, id2 + 2)) + { + return 0; + } + l = n + 2; + + /* Check the number of names */ + if (id1[l] != id2[l]) + { + return 0; + } + n = id1[l]; + l++; + + /* check the table */ + if (!IsEqualIntegerArray(nclas, id1 + l, id2 + l)) + { + return 0; + } + l += nclas; + /* Check the sequence of names */ + if (!IsEqualIntegerArray(n * nsiz, id1 + l, id2 + l)) + { + return 0; + } + + return 1; +} + +/**IsEqualDoubleMat +* Used to test a couple of Scilab variable of type 1 (matrix of floating point numbers) +* or 9 (graphic handles) for equality* +* @param double *d1: pointer on the beginning of the first variable structure +* @param double *d2: pointer on the beginning of the first variable structure +* @return 0 is the variables differ and 1 if they are identical +* @author Serge Steer +* @see IsEqualVar +*/ +int IsEqualDoubleMat(double *d1, double *d2) +{ + int n; + int *id1 = (int *) d1; + int *id2 = (int *) d2; + + /* Check the type */ + if ((id1[0] != id2[0])) + { + return 0; + } + + /* Check the number of rows */ + if (id1[1] != id2[1]) + { + return 0; + } + + /* Check the number of columns */ + if (id1[2] != id2[2]) + { + return 0; + } + + /* Check the real/complex flag */ + if (id1[3] != id2[3]) + { + return 0; + } + + + n = id1[1] * id1[2] * (id1[3] + 1); /* number of double precision floating point numbers */ + /* check the array of numbers */ + if (!IsEqualDoubleArray(n, d1 + 2, d2 + 2)) + { + return 0; + } + + return 1; +} +/**IsEqualIntegerMat +* Used to test a couple of Scilab variable of type 8 (int) for equality +* @param double *d1: pointer on the beginning of the first variable structure +* @param double *d2: pointer on the beginning of the first variable structure +* @return 0 is the variables differ and 1 if they are identical +* @author Serge Steer +* @see IsEqualVar +*/ +int IsEqualIntegerMat(double *d1, double *d2) +{ + int n; + int *id1 = (int *) d1; + int *id2 = (int *) d2; + + /* Check the type */ + if ((id1[0] != id2[0])) + { + return 0; + } + + /* Check the number of rows */ + if (id1[1] != id2[1]) + { + return 0; + } + + /* Check the number of columns */ + if (id1[2] != id2[2]) + { + return 0; + } + + /* Check the subtype */ + if (id1[3] != id2[3]) + { + return 0; + } + + + n = id1[1] * id1[2]; /* number of double precision floating point numbers */ + /* check the array of numbers */ + if (!IsEqualShortIntegerArray(id1[3], n, id1 + 4, id2 + 4)) + { + return 0; + } + + return 1; +} + +/**IsEqualBoolMat +* Used to test a couple of Scilab variable of type 4 (boolean) for equality +* @param double *d1: pointer on the beginning of the first variable structure +* @param double *d2: pointer on the beginning of the first variable structure +* @return 0 is the variables differ and 1 if they are identical +* @author Serge Steer +* @see IsEqualVar +*/ +int IsEqualBoolMat(double *d1, double *d2) +{ + int n; + int *id1 = (int *) d1; + int *id2 = (int *) d2; + + /* Check the type */ + if ((id1[0] != id2[0])) + { + return 0; + } + + /* Check the number of rows */ + if (id1[1] != id2[1]) + { + return 0; + } + + /* Check the number of columns */ + if (id1[2] != id2[2]) + { + return 0; + } + + /* Check the data */ + n = id1[1] * id1[2]; /* number of double precision floating point numbers */ + /* check the array of numbers */ + if (!IsEqualIntegerArray(n, id1 + 3, id2 + 3)) + { + return 0; + } + return 1; +} +/**IsEqualStringMat +* Used to test a couple of Scilab variable of type 10 (string) for equality +* @param double *d1: pointer on the beginning of the first variable structure +* @param double *d2: pointer on the beginning of the first variable structure +* @return 0 is the variables differ and 1 if they are identical +* @author Serge Steer +* @see IsEqualVar +*/ +int IsEqualStringMat(double *d1, double *d2) +{ + int n; + int *id1 = (int *) d1; + int *id2 = (int *) d2; + + /* Check the type */ + if ((id1[0] != id2[0])) + { + return 0; + } + + /* Check the number of rows */ + if (id1[1] != id2[1]) + { + return 0; + } + + /* Check the number of columns */ + if (id1[2] != id2[2]) + { + return 0; + } + + /* Check the array of "pointers" */ + n = id1[1] * id1[2]; + if ( !IsEqualIntegerArray(n + 1, id1 + 4, id2 + 4) ) + { + return 0; + } + + /* Check the array of character codes (int) */ + if (!IsEqualIntegerArray(id1[4 + n] - 1, id1 + 5 + n, id2 + 5 + n)) + { + return 0; + } + return 1; +} + + +/**IsEqualPolyMat +* Used to test a couple of Scilab variable of type 2 (matrix of polynomials) for equality +* @param double *d1: pointer on the beginning of the first variable structure +* @param double *d2: pointer on the beginning of the first variable structure +* @return 0 is the variables differ and 1 if they are identical +* @author Serge Steer +* @see IsEqualVar +*/ +int IsEqualPolyMat(double *d1, double *d2) +{ + int l, n; + int *id1 = (int *) d1; + int *id2 = (int *) d2; + + /* Check the type */ + if ((id1[0] != id2[0])) + { + return 0; + } + + /* Check the number of rows */ + if (id1[1] != id2[1]) + { + return 0; + } + + /* Check the number of columns */ + if (id1[2] != id2[2]) + { + return 0; + } + + /* Check the real/complex flag */ + if (id1[3] != id2[3]) + { + return 0; + } + /* Check the formal variable name */ + if ( !IsEqualIntegerArray(4, id1 + 4, id2 + 4) ) + { + return 0; + } + + + /* Check the array of "pointers" */ + n = id1[1] * id1[2]; + if ( !IsEqualIntegerArray(n, id1 + 8, id2 + 8) ) + { + return 0; + } + + /* Check the array of double precision numbers */ + l = (n + 10) / 2; /* the beginning of first field in th double array */ + + /* check the array of numbers */ + if ( !IsEqualDoubleArray(id1[8 + n] - 1, d1 + l, d2 + l) ) + { + return 0; + } + + return 1; +} + +/**IsEqualDoubleSparseMat +* Used to test a couple of Scilab variable of type 5 (sparse matrix) for equality +* @param double *d1: pointer on the beginning of the first variable structure +* @param double *d2: pointer on the beginning of the first variable structure +* @return 0 is the variables differ and 1 if they are identical +* @author Serge Steer +* @see IsEqualVar +*/ +int IsEqualDoubleSparseMat(double *d1, double *d2) /* a faire */ +{ + int l, nel; + int *id1 = (int *) d1; + int *id2 = (int *) d2; + + /* Check the type */ + if ((id1[0] != id2[0])) + { + return 0; + } + + /* Check the number of rows */ + if (id1[1] != id2[1]) + { + return 0; + } + + /* Check the number of columns */ + if (id1[2] != id2[2]) + { + return 0; + } + + /* Check the real/complex flag */ + if (id1[3] != id2[3]) + { + return 0; + } + + /* Check the number of non zero elements */ + if (id1[4] != id2[4]) + { + return 0; + } + nel = id1[4]; + l = 5; + /* Check the array of number of non zero element per row */ + if ( !IsEqualIntegerArray(id1[1], id1 + l, id2 + l) ) + { + return 0; + } + l += id1[1]; + + /* Check the column index of non zero elements */ + if ( !IsEqualIntegerArray(nel, id1 + l, id2 + l) ) + { + return 0; + } + l += nel; + + /* Check the non zero elements */ + l = (l + 1) / 2; + if ( !IsEqualDoubleArray(nel * (id1[3] + 1), d1 + l, d2 + l) ) + { + return 0; + } + + return 1; +} + +/**IsEqualMatlabSparseMat +* Used to test a couple of Scilab variable of type 7 (Matlab sparse matrix) for equality +* @param double *d1: pointer on the beginning of the first variable structure +* @param double *d2: pointer on the beginning of the first variable structure +* @return 0 is the variables differ and 1 if they are identical +* @author Serge Steer +* @see IsEqualVar +*/ +int IsEqualMatlabSparseMat(double *d1, double *d2) /* a faire */ +{ + int l, nel; + int *id1 = (int *) d1; + int *id2 = (int *) d2; + + /* Check the type */ + if ((id1[0] != id2[0])) + { + return 0; + } + + /* Check the number of rows */ + if (id1[1] != id2[1]) + { + return 0; + } + + /* Check the number of columns */ + if (id1[2] != id2[2]) + { + return 0; + } + + /* Check the real/complex flag */ + if (id1[3] != id2[3]) + { + return 0; + } + + /* Check the number of non zero elements */ + if (id1[4] != id2[4]) + { + return 0; + } + nel = id1[4]; + l = 5; + /* Check the array of number of non zero element per column */ + if ( !IsEqualIntegerArray(id1[2], id1 + l, id2 + l) ) + { + return 0; + } + l += id1[2]; + + /* Check the column index of non zero elements */ + if ( !IsEqualIntegerArray(nel, id1 + l, id2 + l) ) + { + return 0; + } + l += nel; + + /* Check the non zero elements */ + l = (l + 1) / 2; + if ( !IsEqualDoubleArray(nel * (id1[3] + 1), d1 + l, d2 + l) ) + { + return 0; + } + + return 1; +} + +/**IsEqualBoolSparseMat +* Used to test a couple of Scilab variable of type 6 (Boolean sparse matrix) for equality +* @param double *d1: pointer on the beginning of the first variable structure +* @param double *d2: pointer on the beginning of the first variable structure +* @return 0 is the variables differ and 1 if they are identical +* @author Serge Steer +* @see IsEqualVar +*/ +int IsEqualBoolSparseMat(double *d1, double *d2) /* a faire */ +{ + int l, nel; + int *id1 = (int *) d1; + int *id2 = (int *) d2; + + /* Check the type */ + if ((id1[0] != id2[0])) + { + return 0; + } + + /* Check the number of rows */ + if (id1[1] != id2[1]) + { + return 0; + } + + /* Check the number of columns */ + if (id1[2] != id2[2]) + { + return 0; + } + + + /* Check the number of non zero elements */ + if (id1[4] != id2[4]) + { + return 0; + } + nel = id1[4]; + l = 5; + /* Check the array of number of non zero element per row */ + if ( !IsEqualIntegerArray(id1[1], id1 + l, id2 + l) ) + { + return 0; + } + l += id1[1]; + + /* Check the column index of non zero elements */ + if ( !IsEqualIntegerArray(nel, id1 + l, id2 + l) ) + { + return 0; + } + + return 1; +} + +/**IsEqualFunction +* Used to test a couple of Scilab variable of type 11 or 13 (function) for equality +* @param double *d1: pointer on the beginning of the first variable structure +* @param double *d2: pointer on the beginning of the first variable structure +* @return 0 is the variables differ and 1 if they are identical +* @author Serge Steer +* @see IsEqualVar +*/ +int IsEqualFunction(double *d1, double *d2) +{ + int l, n; + int *id1 = (int *) d1; + int *id2 = (int *) d2; + + /* Check the type */ + if ((id1[0] != id2[0])) + { + return 0; + } + l = 1; + /* Check the number of output args */ + if (id1[l] != id2[l]) + { + return 0; + } + /* Check the output args names*/ + n = id1[l]; + l++; + if ( !IsEqualIntegerArray(n * nsiz, id1 + l, id2 + l) ) + { + return 0; + } + l += n * nsiz; + + /* Check the number of input args */ + if (id1[l] != id2[l]) + { + return 0; + } + /* Check the input args names*/ + n = id1[l]; + l++; + if ( !IsEqualIntegerArray(n * nsiz, id1 + l, id2 + l) ) + { + return 0; + } + l += n * nsiz; + + /* Check the number of int in instructions */ + if (id1[l] != id2[l]) + { + return 0; + } + n = id1[l]; + l++; + if ( !IsEqualIntegerArray(n, id1 + l, id2 + l) ) + { + return 0; + } + + + return 1; +} + +/**IsEqualLUPtr +* Used to test a couple of Scilab variable of type 128 (pointer on LU factorization) for equality +* @param double *d1: pointer on the beginning of the first variable structure +* @param double *d2: pointer on the beginning of the first variable structure +* @return 0 is the variables differ and 1 if they are identical +* @author Serge Steer +* @see IsEqualVar +*/ +int IsEqualLUPtr(double *d1, double *d2) +{ + int *id1 = (int *) d1; + int *id2 = (int *) d2; + + /* Check the type */ + if ((id1[0] != id2[0])) + { + return 0; + } + + /* Check the number of rows */ + if (id1[1] != id2[1]) + { + return 0; + } + + /* Check the number of columns */ + if (id1[2] != id2[2]) + { + return 0; + } + + /* Check the real/complex flag */ + if (id1[3] != id2[3]) + { + return 0; + } + + /* Check the pointer value */ + if (d1[2] != d2[2]) + { + return 0; + } + + return 1; +} + +/**IsEqualDoubleArrayIEEE +* compare if two double precision arrays of size n, are identical. +* NaN entries are supposed to be different from all values included NaN +* NaN != NaN +* @param int n: array size +* @param double *d1: pointer on the beginning of the first array +* @param double *d2: pointer on the beginning of the second array +* @return 0 is the arrays differ and 1 if they are identical +* @author Serge Steer +*/ +int IsEqualDoubleArrayIEEE(int n, double *d1, double *d2) +{ + int i; + /*DEBUG_BASE("IEEE comparison of %d doubles\n",n);*/ + + if (n == 0) + { + return 1; + } + for (i = 0; i < n; i++) + { + if (d1[i] != d2[i]) + { + return 0; + } + } + return 1; +} + +/** IsEqualDoubleArrayBinary +* compare if two arrays of long long integers of size n, are identical. +* @param int n: array size +* @param long long *d1: pointer on the beginning of the first array +* @param long long *d2: pointer on the beginning of the second array +* @return 0 is the arrays differ and 1 if they are identical +* @author Serge Steer +*/ +int IsEqualDoubleArrayBinary(int n, double *d1, double *d2) +{ + int i; + long long *l1 = (long long *)d1; + long long *l2 = (long long *)d2; + + /*DEBUG_BASE("binary comparison of %d doubles\n",n);*/ + + if (n == 0) + { + return 1; + } + for (i = 0; i < n; i++) + { + if (l1[i] != l2[i]) + { + return 0; + } + } + return 1; +} + + +/**IsEqualDoubleArray +* compare if two double precision arrays of size n, are identical. +* If the arrays conatins NaN the meaning depends on the value of the global flag IEEE_comp +* - if DoubleCompMode==1, double numbers are compared using "==", so Nan != NaN. +* - if DoubleCompMode==0, double numbers are compared bitwise. +* @param int n: array size +* @param double *d1: pointer on the beginning of the first array +* @param double *d2: pointer on the beginning of the second array +* @return 0 is the arrays differ and 1 if they are identical +* @author Serge Steer +*/ +int IsEqualDoubleArray(int n, double *d1, double *d2) +{ + if ( GetDoubleCompMode()) + { + return IsEqualDoubleArrayIEEE(n, d1, d2); + } + else + { + return IsEqualDoubleArrayBinary(n, d1, d2); + } +} + + + +/**IsEqualIntegerArray +* compare if two int arrays of size n, are identical +* @param int n: array size +* @param int *d1: pointer on the beginning of the first array +* @param int *d2: pointer on the beginning of the second array +* @return 0 is the arrays differ and 1 if they are identical +* @author Serge Steer +*/ +int IsEqualIntegerArray(int n, int *d1, int *d2) +{ + int i; + + /*DEBUG_BASE("comparison of %d ints\n",n);*/ + + if (n == 0) + { + return 1; + } + for (i = 0; i < n; i++) + { + if (d1[i] != d2[i]) + { + return 0; + } + } + return 1; +} + +typedef signed char integer1; +typedef short integer2; +/* Copyright INRIA */ + +#define ISEQUAL(Type) {\ + Type *A;\ + Type *B;\ + A=(Type *)d1;\ + B=(Type *)d2;\ + for (i = 0; i <n; ++i) {\ + if (A[i] != B[i]) return 0;\ + }\ +} + + +/**IsEqualShortIntegerArray +* compare if two short int (1,2 or 4 bytes) arrays of size n, are identical +* @param int type: int type 1, 2, 4 or 11, 12, 14 for unsigned int +* @param int n: array size +* @param int *d1: pointer on the beginning of the first array +* @param int *d2: pointer on the beginning of the second array +* @return 0 is the arrays differ and 1 if they are identical +* @author Serge Steer +*/ +int IsEqualShortIntegerArray(int typ, int n, int *d1, int *d2) +{ + int i; + + /*DEBUG_BASE("comparison of %d int %d bytes\n",n,typ);*/ + if (n == 0) + { + return 1; + } + switch (typ) + { + case 0: + ISEQUAL(double); + break; + case 1: + ISEQUAL(integer1); + break; + case 2: + ISEQUAL(integer2); + break; + case 4: + ISEQUAL(int) ; + break; + case 11: + ISEQUAL(unsigned char); + break; + case 12: + ISEQUAL(unsigned short); + break; + case 14: + ISEQUAL(unsigned int); + break; + } + + return 1; +} + +/**FreeRec +* Utility function to free the list recursion table +* @author Serge Steer +*/ +void FreeRec(void) +{ + if ( MaxRec > 0 ) + { + FREE(Rrec); + Rrec = NULL; + MaxRec = 0; + } +} + +/** AllocRecIfRequired +* Utility function to allocate or reallocate the list recursion table +* @param int krec: minimum size requested +* @author Serge Steer +*/ +int AllocRecIfRequired(int krec) +{ + /*Allocation is made by block of size 10 */ + if (MaxRec <= krec) + { + if ((Rrec = (RecursionRecordPtr)REALLOC(Rrec, (MaxRec + 10) * sizeof(RecursionRecord))) == NULL) + { + return -2; + } + MaxRec = MaxRec + 10; + } + return 0; +} + +/**SetDoubleCompMode +* Utility function used to set the way double numbers are compared +* @param int mode. 1 means that IEEE comparison is used, 0 means binary comparison +* @author Serge Steer +*/ + +void SetDoubleCompMode(int mode) +{ + DoubleCompMode = mode; +} +/**GetDoubleCompMode +* Utility function used to get the way double numbers are compared +* @return 1 means that IEEE comparison is used, 0 means binary comparison +* @author Serge Steer +*/ + +int GetDoubleCompMode(void) +{ + return DoubleCompMode; +} diff --git a/modules/elementary_functions/src/c/IsEqualVar.h b/modules/elementary_functions/src/c/IsEqualVar.h new file mode 100755 index 000000000..f23156636 --- /dev/null +++ b/modules/elementary_functions/src/c/IsEqualVar.h @@ -0,0 +1,81 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) 2007 - INRIA - Serge STEER + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ + +/* --------------------------------------------------------------------------*/ + +#ifndef __ISEQUALVAR__ +#define __ISEQUALVAR__ + +#include <string.h> +#include "stack-c.h" +#include "MALLOC.h" +#include "stack-def.h" + +static int IsEqualDoubleMat(double *d1, double *d2); +static int IsEqualPolyMat(double *d1, double *d2); +static int IsEqualBoolMat(double *d1, double *d2); +static int IsEqualDoubleSparseMat(double *d1, double *d2); +static int IsEqualBoolSparseMat(double *d1, double *d2); +static int IsEqualMatlabSparseMat(double *d1, double *d2); +static int IsEqualIntegerMat(double *d1, double *d2); +static int IsEqualStringMat(double *d1, double *d2); +static int IsEqualLib(double *d1, double *d2); +static int IsEqualList(double *d1, double *d2); +static int IsEqualLUPtr(double *d1, double *d2); +static int IsEqualOverloaded(double *d1, int n1, double *d2, int n2); +static int IsEqualDoubleArray(int n, double *d1, double *d2); +static int IsEqualDoubleArrayBinary(int n, double *d1, double *d2); +static int IsEqualDoubleArrayIEEE(int n, double *d1, double *d2); +static int IsEqualIntegerArray(int n, int *d1, int *d2); +static int IsEqualShortIntegerArray(int typ, int n, int *d1, int *d2); +static int IsEqualFunction(double *d1, double *d2); +static int IsEqualVar(double *d1, int n1, double *d2, int n2); + +/* comparison mode for double precision numbers */ +void SetDoubleCompMode(int mode); +int GetDoubleCompMode(void); +int DoubleCompMode = 1; /*IEEE mode */ + +/* Structure for walking inside Scilab lists (used by IsEqualList)*/ +int AllocRecIfRequired(int krec); +void FreeRec(void); +typedef struct RecursionRecord +{ + double* d1 ;/* pointers on the first list header */ + double* d2 ;/* pointers on the second list header */ + int k; /* index of current list element */ +} RecursionRecord, *RecursionRecordPtr; + +RecursionRecordPtr Rrec; +int MaxRec; /* allocated size for the array Rrec, 0 means not allocated */ + +/* macros for debugging */ +/*#define DEBUG_BASE(fmt, ...)sciprint(fmt, __VA_ARGS__) */; +/*#define DEBUG_LIST(fmt, ...) sciprint(fmt, __VA_ARGS__) */ ; +/*#define DEBUG_OVERLOADING(fmt, ...) sciprint(fmt, __VA_ARGS__) */ ; + + +/**intisequalvar + * Gateway for isequalbitwise and isequal builtins + * @param char * fname: the Scilab code of the function name + * @param int * job: if *job==0 the floating point numbers are compared bitwize , + * if *job==1 the comparison is made numerically, + * so NaN elements are not equal + * elements of with differents data types are raised to the upper types before comparison (to be done) + * @return 0 in any cases + * @author Serge Steer + * @see isequal + */ +int C2F(intisequalvar)(char * fname, int *job, long int fl); /* the gateway */ + + +#endif /* !__ISEQUALVAR__ */ diff --git a/modules/elementary_functions/src/c/cmp.c b/modules/elementary_functions/src/c/cmp.c new file mode 100755 index 000000000..0514f2c9c --- /dev/null +++ b/modules/elementary_functions/src/c/cmp.c @@ -0,0 +1,199 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) ENPC - Jean-Philippe CHANCELIER + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ +#include "cmp.h" +#include "isanan.h" + + +#ifdef _MSC_VER +/* vc++ pbs with nan and comparisons */ +#define NAN_CHECK +#endif + +#define less 59 +#define great 60 +#define equal 50 +/* less + equal */ +#define less_equal 109 +/* less + great */ +#define less_great 119 +/* great + equal */ +#define great_equal 110 + +static void idcmp_equal(double x[], double y[], int *n, int res[]) ; +static void idcmp_lessgreat(double x[], double y[], int *n, int res[]) ; +static void idcmp_less(double x[], double y[], int *n, int res[]) ; +static void idcmp_great(double x[], double y[], int *n, int res[]) ; +static void idcmp_lessequal(double x[], double y[], int *n, int res[]) ; +static void idcmp_greatequal(double x[], double y[], int *n, int res[]) ; + +int C2F(idcmp)(double x[], double y[], int *n, int res[], int *op) +{ + int i; + switch (*op) + { + case equal : + idcmp_equal(x, y, n, res) ; + break; + case less_great : + idcmp_lessgreat(x, y, n, res) ; + break; + case less : + idcmp_less(x, y, n, res) ; + break; + case great : + idcmp_great(x, y, n, res) ; + break; + case less_equal : + idcmp_lessequal(x, y, n, res) ; + break; + case great_equal : + idcmp_greatequal(x, y, n, res) ; + break; + default: + for (i = 0; i < *n; i++) + { + res[i] = 0; + } + } + return 0; +} + +/* nan pbs with vc++ */ + +static void idcmp_equal(double x[], double y[], int *n, int res[]) +{ + int i; + for (i = 0; i < *n; i++) + { +#ifdef NAN_CHECK + if ( C2F(isanan)(&x[i]) == 1 || C2F(isanan)(&y[i]) == 1 ) + { + res[i] = 0; + } + else + { + res[i] = x[i] == y[i]; + } +#else + res[i] = x[i] == y[i]; +#endif + } +} + +static void idcmp_lessgreat(double x[], double y[], int *n, int res[]) +{ + int i; + for (i = 0; i < *n; i++) + { +#ifdef NAN_CHECK + if ( C2F(isanan)(&x[i]) == 1 || C2F(isanan)(&y[i]) == 1 ) + { + res[i] = 1; + } + else + { + res[i] = x[i] != y[i]; + } +#else + res[i] = x[i] != y[i]; +#endif + } +} + +static void idcmp_less(double x[], double y[], int *n, int res[]) +{ + int i; + for (i = 0; i < *n; i++) + { +#ifdef NAN_CHECK + if ( C2F(isanan)(&x[i]) == 1 || C2F(isanan)(&y[i]) == 1 ) + { + res[i] = 0; + } + else + { + res[i] = x[i] < y[i]; + } +#else + res[i] = x[i] < y[i]; +#endif + } +} + + +static void idcmp_great(double x[], double y[], int *n, int res[]) +{ + int i; + for (i = 0; i < *n; i++) + { +#ifdef NAN_CHECK + if ( C2F(isanan)(&x[i]) == 1 || C2F(isanan)(&y[i]) == 1 ) + { + res[i] = 0; + } + else + { + res[i] = x[i] > y[i]; + } +#else + res[i] = x[i] > y[i]; +#endif + } +} + + +static void idcmp_lessequal(double x[], double y[], int *n, int res[]) +{ + int i; + for (i = 0; i < *n; i++) + { +#ifdef NAN_CHECK + if ( C2F(isanan)(&x[i]) == 1 || C2F(isanan)(&y[i]) == 1 ) + { + res[i] = 0; + } + else + { + res[i] = x[i] <= y[i]; + } +#else + res[i] = x[i] <= y[i]; +#endif + } +} + + +static void idcmp_greatequal(double x[], double y[], int *n, int res[]) +{ + int i; + for (i = 0; i < *n; i++) + { +#ifdef NAN_CHECK + if ( C2F(isanan)(&x[i]) == 1 || C2F(isanan)(&y[i]) == 1 ) + { + res[i] = 0; + } + else + { + res[i] = x[i] >= y[i]; + } +#else + res[i] = x[i] >= y[i]; +#endif + } +} + + + + + + diff --git a/modules/elementary_functions/src/c/cmp.h b/modules/elementary_functions/src/c/cmp.h new file mode 100755 index 000000000..caec00cb2 --- /dev/null +++ b/modules/elementary_functions/src/c/cmp.h @@ -0,0 +1,21 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) 2010 - DIGITEO - Allan CORNET + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ + +#ifndef __CMP_H__ +#define __CMP_H__ + +#include "machine.h" +#include "dynlib_elementary_functions.h" + +ELEMENTARY_FUNCTIONS_IMPEXP int C2F(idcmp)(double x[], double y[], int *n, int res[], int *op); + +#endif /* CMP_H__ */ diff --git a/modules/elementary_functions/src/c/convertbase.c b/modules/elementary_functions/src/c/convertbase.c new file mode 100755 index 000000000..161d9f699 --- /dev/null +++ b/modules/elementary_functions/src/c/convertbase.c @@ -0,0 +1,232 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) 2011 - DIGITEO - Allan CORNET + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ +/*--------------------------------------------------------------------------*/ +#include <string.h> +#include <math.h> +#include <stdio.h> +#include <stdlib.h> +#include "convertbase.h" +#include "MALLOC.h" +#include "freeArrayOfString.h" +#include "stack-def.h" +/*--------------------------------------------------------------------------*/ +#define char_a 'a' +#define char_A 'A' +#define char_z 'z' +#define char_Z 'Z' +#define char_zero '0' +#define char_nine '9' +/*--------------------------------------------------------------------------*/ +static char *convertDec2Base(double dValue, int numberbase, + unsigned int nbDigits, error_convertbase *err); +/*--------------------------------------------------------------------------*/ +double convertBase2Dec(const char *pStr, int numberbase, error_convertbase *err) +{ + double result = 0.; + *err = ERROR_CONVERTBASE_NOK; + + if (pStr) + { + size_t i = 0; + size_t len = strlen(pStr); + for (i = 0; i < len; i++) + { + if ((pStr[i] >= char_zero) && (pStr[i] <= char_nine)) + { + result = (numberbase * result) + (int)pStr[i] - char_zero; + } + else if ((pStr[i] >= char_A) && (pStr[i] <= char_Z)) + { + int vTmp = (int)pStr[i] - char_A + 10; + if (vTmp > numberbase) + { + *err = ERROR_CONVERTBASE_INVALID_REPRESENTATION; + return 0; + } + else + { + result = (numberbase * result) + vTmp; + } + } + else if ((pStr[i] >= char_a) && (pStr[i] <= char_z)) + { + int vTmp = (int)pStr[i] - char_a + 10; + if ( vTmp > numberbase) + { + *err = ERROR_CONVERTBASE_INVALID_REPRESENTATION; + return 0; + } + else + { + result = (numberbase * result) + vTmp; + } + } + else + { + return 0; + } + } + *err = ERROR_CONVERTBASE_OK; + } + return result; +} +/*--------------------------------------------------------------------------*/ +static char *convertDec2Base(double dValue, int numberbase, + unsigned int nbDigits, error_convertbase *err) +{ + char symbols[37] = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"; + long long int iDec = (long long int) dValue; + char *convertedValue = NULL; + + *err = ERROR_CONVERTBASE_NOK; + if (iDec == 0) + { + convertedValue = (char*)MALLOC(sizeof(char) * 2); + if (convertedValue) + { + strcpy(convertedValue, "0"); + *err = ERROR_CONVERTBASE_OK; + } + else + { + *err = ERROR_CONVERTBASE_ALLOCATION; + return NULL; + } + } + else + { + int count = 0; + char chResult[bsiz] = ""; + char *pChResult = chResult; + while (iDec > 0 && count++ < bsiz) + { + *pChResult = symbols[iDec % numberbase]; + pChResult++; + iDec = iDec / numberbase; + } + + convertedValue = (char*)MALLOC(sizeof(char) * (strlen(chResult) + 1)); + if (convertedValue) + { + size_t j = 0; + size_t i = strlen(chResult); + int t = !(i % 2) ? 1 : 0; + int k = 0; + strcpy(convertedValue, chResult); + for (j = i - 1; j > (i / 2 - t); j--) + { + char ch = chResult[j]; + chResult[j] = chResult[k]; + chResult[k++] = ch; + } + strcpy(convertedValue, chResult); + *err = ERROR_CONVERTBASE_OK; + } + else + { + *err = ERROR_CONVERTBASE_ALLOCATION; + return NULL; + } + } + + if (*err == ERROR_CONVERTBASE_OK) + { + size_t lenConvertedValue = strlen(convertedValue); + if ((nbDigits > lenConvertedValue) && (nbDigits > 0)) + { + size_t i = 0; + char *tmp = (char*)MALLOC(sizeof(char) * (nbDigits + 1)); + if (tmp) + { + for (i = 0; i < nbDigits - lenConvertedValue; i++) + { + tmp[i] = '0'; + } + tmp[i] = 0; + strcat(tmp, convertedValue); + FREE(convertedValue); + convertedValue = tmp; + } + } + } + + return convertedValue; +} +/*--------------------------------------------------------------------------*/ +char **convertMatrixOfDec2Base(const double* dValues, int mn, + int numberbase, unsigned int nbDigits, + error_convertbase *err) +{ + char **convertedValues = NULL; + int i = 0; + double maxVal = 0.; + + for (i = 0; i < mn; i++) + { + long long int iValue = (long long int) dValues[i]; + + /* search max value */ + if (dValues[i] > maxVal) + { + maxVal = dValues[i]; + } + + /* check if it is an integer value */ + if (dValues[i] != (double)iValue) + { + *err = ERROR_CONVERTBASE_NOT_INTEGER_VALUE; + return NULL; + } + + /* check if it is in the good interval */ + if ((dValues[i] < 0) || (dValues[i] > pow(2, 52))) + { + *err = ERROR_CONVERTBASE_NOT_IN_INTERVAL; + return NULL; + } + } + + if ((mn > 1) && (numberbase == 2)) /* Only binary base is uniformed about number of digits */ + { + size_t maxDigits = 0; + char *maxBaseString = convertDec2Base(maxVal, numberbase, nbDigits, err); + if (maxBaseString) + { + maxDigits = strlen(maxBaseString); + FREE(maxBaseString); + if (maxDigits > nbDigits) + { + nbDigits = (unsigned int)maxDigits; + } + } + } + + convertedValues = (char **)MALLOC(sizeof(char*) * (mn)); + if (convertedValues) + { + for (i = 0; i < mn; i++) + { + convertedValues[i] = convertDec2Base(dValues[i], numberbase, nbDigits, err); + if (*err) + { + freeArrayOfString(convertedValues, mn); + return NULL; + } + } + } + else + { + *err = ERROR_CONVERTBASE_ALLOCATION; + } + return convertedValues; +} +/*--------------------------------------------------------------------------*/ diff --git a/modules/elementary_functions/src/c/convertbase.h b/modules/elementary_functions/src/c/convertbase.h new file mode 100755 index 000000000..5e4959916 --- /dev/null +++ b/modules/elementary_functions/src/c/convertbase.h @@ -0,0 +1,46 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) 2011 - DIGITEO - Allan CORNET + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ +/*--------------------------------------------------------------------------*/ +#ifndef __CONVERTBASE_H__ +#define __CONVERTBASE_H__ + +typedef enum +{ + ERROR_CONVERTBASE_OK = 0, + ERROR_CONVERTBASE_NOK = 1, + ERROR_CONVERTBASE_NOT_INTEGER_VALUE = 2, + ERROR_CONVERTBASE_NOT_IN_INTERVAL = 3, + ERROR_CONVERTBASE_ALLOCATION = 4, + ERROR_CONVERTBASE_INVALID_REPRESENTATION = 5 +} error_convertbase; + +/** +* convert from base b to decimal +* @param string base +* @param int base +* @param[out] int if 0 no error +* @return converted value (decimal) +*/ +double convertBase2Dec(const char *pStr, int numberbase, error_convertbase *err); + +/** +* Convert decimal to base N number in string +* @param[in] array of integer values +* @param[in] number of elements in dValues array +* @param[in] number of digits for representation +* @param[out] error value +* @return a matrix of string of size mn +*/ +char **convertMatrixOfDec2Base(const double* dValues, int mn, int numberbase, unsigned int nbDigits, error_convertbase *err); + +#endif /* __CONVERTBASE_H__ */ +/*--------------------------------------------------------------------------*/ diff --git a/modules/elementary_functions/src/c/core_Import.def b/modules/elementary_functions/src/c/core_Import.def new file mode 100755 index 000000000..517dbb40a --- /dev/null +++ b/modules/elementary_functions/src/c/core_Import.def @@ -0,0 +1,32 @@ + LIBRARY core.dll + + +EXPORTS +; +;core +; +freeArrayOfString +isanan_ +callFunctionFromGateway +com_ +recu_ +overload_ +Ptover +vstk_ +stack_ +crebmat_ +checklhs_ +checkrhs_ +createvarfromptr_ +putlhsvar_ +intersci_ +createvar_ +GetData +check_length +getrhsvar_ +vartype_ +getWarningMode +MyHeapAlloc +MyHeapFree +MyHeapRealloc +getieee diff --git a/modules/elementary_functions/src/c/dscal.c b/modules/elementary_functions/src/c/dscal.c new file mode 100755 index 000000000..5bffa80ab --- /dev/null +++ b/modules/elementary_functions/src/c/dscal.c @@ -0,0 +1,31 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) 2014 - Scilab Enterprises - Bruno JOFRET + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ + +/* This file is the C version of BLAS function dscal.f */ +/* Used in Scilab for Mac OS X version (Fixes %nan*0 and 0*%nan) */ + +#include "machine.h" + +void C2F(dscal)(int *n, double *da, double *dx, int *incx) +{ + int i = 0; + + if (*n < 0 || * incx < 0) + { + return; + } + + for (i = 0 ; i < *n ; i += *incx) + { + dx[i] = dx[i] * (*da); + } +} diff --git a/modules/elementary_functions/src/c/elementary_functions.rc b/modules/elementary_functions/src/c/elementary_functions.rc new file mode 100755 index 000000000..f9f4f4fa5 --- /dev/null +++ b/modules/elementary_functions/src/c/elementary_functions.rc @@ -0,0 +1,95 @@ +// Microsoft Visual C++ generated resource script. +// + + +#define APSTUDIO_READONLY_SYMBOLS +///////////////////////////////////////////////////////////////////////////// +// +// Generated from the TEXTINCLUDE 2 resource. +// +#define APSTUDIO_HIDDEN_SYMBOLS +#include "windows.h" +///////////////////////////////////////////////////////////////////////////// +#undef APSTUDIO_READONLY_SYMBOLS + +///////////////////////////////////////////////////////////////////////////// +// French (France) resources + +#if !defined(AFX_RESOURCE_DLL) || defined(AFX_TARG_FRA) +#ifdef _WIN32 +LANGUAGE LANG_FRENCH, SUBLANG_FRENCH +#pragma code_page(1252) +#endif //_WIN32 + +#ifdef APSTUDIO_INVOKED +///////////////////////////////////////////////////////////////////////////// +// +// TEXTINCLUDE +// + +1 TEXTINCLUDE +BEGIN + "resource.h\0" +END + +3 TEXTINCLUDE +BEGIN + "\r\n" + "\0" +END + +#endif // APSTUDIO_INVOKED + + +///////////////////////////////////////////////////////////////////////////// +// +// Version +// + +VS_VERSION_INFO VERSIONINFO + FILEVERSION 5,5,2,0 + PRODUCTVERSION 5,5,2,0 + FILEFLAGSMASK 0x17L +#ifdef _DEBUG + FILEFLAGS 0x1L +#else + FILEFLAGS 0x0L +#endif + FILEOS 0x4L + FILETYPE 0x2L + FILESUBTYPE 0x0L +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "040c04b0" + BEGIN + VALUE "FileDescription", "elementary_functions module" + VALUE "FileVersion", "5, 5, 2, 0" + VALUE "InternalName", "elementary_functions module" + VALUE "LegalCopyright", "Copyright (C) 2017" + VALUE "OriginalFilename", "elementary_functions.dll" + VALUE "ProductName", "elementary_functions module" + VALUE "ProductVersion", "5, 5, 2, 0" + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x40c, 1200 + END +END + +#endif // French (France) resources +///////////////////////////////////////////////////////////////////////////// + + + +#ifndef APSTUDIO_INVOKED +///////////////////////////////////////////////////////////////////////////// +// +// Generated from the TEXTINCLUDE 3 resource. +// + + +///////////////////////////////////////////////////////////////////////////// +#endif // not APSTUDIO_INVOKED + diff --git a/modules/elementary_functions/src/c/elementary_functions.vcxproj b/modules/elementary_functions/src/c/elementary_functions.vcxproj new file mode 100755 index 000000000..411945e55 --- /dev/null +++ b/modules/elementary_functions/src/c/elementary_functions.vcxproj @@ -0,0 +1,341 @@ +<?xml version="1.0" encoding="utf-8"?> +<Project DefaultTargets="Build" ToolsVersion="4.0" xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <ItemGroup Label="ProjectConfigurations"> + <ProjectConfiguration Include="Debug|Win32"> + <Configuration>Debug</Configuration> + <Platform>Win32</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Debug|x64"> + <Configuration>Debug</Configuration> + <Platform>x64</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Release|Win32"> + <Configuration>Release</Configuration> + <Platform>Win32</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Release|x64"> + <Configuration>Release</Configuration> + <Platform>x64</Platform> + </ProjectConfiguration> + </ItemGroup> + <PropertyGroup Label="Globals"> + <ProjectGuid>{5B110267-7C18-437C-B87D-DBA2B50729E9}</ProjectGuid> + <RootNamespace>elementary_functions</RootNamespace> + <Keyword>Win32Proj</Keyword> + </PropertyGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.Default.props" /> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>MultiByte</CharacterSet> + <WholeProgramOptimization>false</WholeProgramOptimization> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>MultiByte</CharacterSet> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>MultiByte</CharacterSet> + <WholeProgramOptimization>false</WholeProgramOptimization> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>MultiByte</CharacterSet> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.props" /> + <ImportGroup Label="ExtensionSettings"> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <PropertyGroup Label="UserMacros" /> + <PropertyGroup> + <_ProjectFileVersion>10.0.30319.1</_ProjectFileVersion> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">false</LinkIncremental> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">false</LinkIncremental> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">false</LinkIncremental> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Release|x64'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Release|x64'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Release|x64'">false</LinkIncremental> + </PropertyGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'"> + <ClCompile> + <Optimization>Disabled</Optimization> + <AdditionalIncludeDirectories>.;../../includes;../../../core/includes;../../../output_stream/includes;../../../dynamic_link/includes;../../../dynamic_link/src/c;../../../localization/includes;../../../core/src/c;../../../../libs/intl;../../../elementary_functions/includes;../../../api_scilab/includes;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>_CRT_SECURE_NO_DEPRECATE;FORDLL;_DEBUG;_WINDOWS;_USRDLL;ELEMENTARY_FUNCTIONS_EXPORTS;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDebugDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + </ClCompile> + <PreLinkEvent> + <Message>Make dependencies</Message> + <Command>lib /DEF:"$(ProjectDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)elementary_functions_f.lib" 1>NUL 2>NUL +</Command> + </PreLinkEvent> + <Link> + <AdditionalDependencies>core.lib;elementary_functions_f.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX86</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + </Link> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'"> + <Midl> + <TargetEnvironment>X64</TargetEnvironment> + </Midl> + <ClCompile> + <Optimization>Disabled</Optimization> + <AdditionalIncludeDirectories>.;../../includes;../../../core/includes;../../../output_stream/includes;../../../dynamic_link/includes;../../../dynamic_link/src/c;../../../localization/includes;../../../core/src/c;../../../../libs/intl;../../../elementary_functions/includes;../../../api_scilab/includes;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>_CRT_SECURE_NO_DEPRECATE;FORDLL;_DEBUG;_WINDOWS;_USRDLL;ELEMENTARY_FUNCTIONS_EXPORTS;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDebugDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + </ClCompile> + <PreLinkEvent> + <Message>Make dependencies</Message> + <Command>lib /DEF:"$(ProjectDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)elementary_functions_f.lib" 1>NUL 2>NUL +</Command> + </PreLinkEvent> + <Link> + <AdditionalDependencies>core.lib;elementary_functions_f.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX64</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + </Link> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'"> + <ClCompile> + <FavorSizeOrSpeed>Speed</FavorSizeOrSpeed> + <WholeProgramOptimization>false</WholeProgramOptimization> + <AdditionalIncludeDirectories>.;../../includes;../../../core/includes;../../../output_stream/includes;../../../dynamic_link/includes;../../../dynamic_link/src/c;../../../localization/includes;../../../core/src/c;../../../../libs/intl;../../../elementary_functions/includes;../../../api_scilab/includes;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>_CRT_SECURE_NO_DEPRECATE;FORDLL;NDEBUG;_WINDOWS;_USRDLL;ELEMENTARY_FUNCTIONS_EXPORTS;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <StringPooling>true</StringPooling> + <RuntimeLibrary>MultiThreadedDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + <MultiProcessorCompilation>true</MultiProcessorCompilation> + </ClCompile> + <PreLinkEvent> + <Message>Make dependencies</Message> + <Command>lib /DEF:"$(ProjectDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)elementary_functions_f.lib" 1>NUL 2>NUL +</Command> + </PreLinkEvent> + <Link> + <AdditionalDependencies>core.lib;elementary_functions_f.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <GenerateDebugInformation>false</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <OptimizeReferences>true</OptimizeReferences> + <EnableCOMDATFolding>true</EnableCOMDATFolding> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX86</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + </Link> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'"> + <Midl> + <TargetEnvironment>X64</TargetEnvironment> + </Midl> + <ClCompile> + <FavorSizeOrSpeed>Speed</FavorSizeOrSpeed> + <WholeProgramOptimization>false</WholeProgramOptimization> + <AdditionalIncludeDirectories>.;../../includes;../../../core/includes;../../../output_stream/includes;../../../dynamic_link/includes;../../../dynamic_link/src/c;../../../localization/includes;../../../core/src/c;../../../../libs/intl;../../../elementary_functions/includes;../../../api_scilab/includes;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>_CRT_SECURE_NO_DEPRECATE;FORDLL;NDEBUG;_WINDOWS;_USRDLL;ELEMENTARY_FUNCTIONS_EXPORTS;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <StringPooling>true</StringPooling> + <RuntimeLibrary>MultiThreadedDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + <MultiProcessorCompilation>true</MultiProcessorCompilation> + </ClCompile> + <PreLinkEvent> + <Message>Make dependencies</Message> + <Command>lib /DEF:"$(ProjectDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)elementary_functions_f.lib" 1>NUL 2>NUL +</Command> + </PreLinkEvent> + <Link> + <AdditionalDependencies>core.lib;elementary_functions_f.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <GenerateDebugInformation>false</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <OptimizeReferences>true</OptimizeReferences> + <EnableCOMDATFolding>true</EnableCOMDATFolding> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX64</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + </Link> + </ItemDefinitionGroup> + <ItemGroup> + <ClCompile Include="..\..\sci_gateway\c\sci_base2dec.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_dec2base.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_find.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_log10.c" /> + <ClCompile Include="cmp.c" /> + <ClCompile Include="convertbase.c" /> + <ClCompile Include="DllmainElementary_functions.c" /> + <ClCompile Include="finite.c" /> + <ClCompile Include="gsort.c" /> + <ClCompile Include="..\..\sci_gateway\c\gw_elementary_functions.c" /> + <ClCompile Include="idmax.c" /> + <ClCompile Include="idmin.c" /> + <ClCompile Include="int2db.c" /> + <ClCompile Include="IsEqualVar.c"> + <CompileAs Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">Default</CompileAs> + <CompileAs Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">Default</CompileAs> + <CompileAs Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">Default</CompileAs> + <CompileAs Condition="'$(Configuration)|$(Platform)'=='Release|x64'">Default</CompileAs> + </ClCompile> + <ClCompile Include="qsort-char.c" /> + <ClCompile Include="qsort-double.c" /> + <ClCompile Include="qsort-int.c" /> + <ClCompile Include="qsort-short.c" /> + <ClCompile Include="qsort-string.c" /> + <ClCompile Include="qsort.c" /> + <ClCompile Include="rea2db.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_abs.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_acos.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_asin.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_atan.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_ceil.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_chinesehat.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_clean.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_conj.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_cos.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_cumprod.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_cumsum.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_diag.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_dsearch.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_exp.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_expm.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_eye.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_floor.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_frexp.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_gsort.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_imag.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_imult.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_int.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_isequal.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_isequalbitwise.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_isreal.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_kron.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_log.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_log1p.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_matrix.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_maxi.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_nearfloat.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_number_properties.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_ones.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_prod.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_rand.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_rat.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_real.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_round.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_sign.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_sin.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_size.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_spones.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_sqrt.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_sum.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_tan.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_testmatrix.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_tril.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_triu.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_zeros.c" /> + <ClCompile Include="scidcopy.c" /> + <ClCompile Include="unsfdcopy.c"> + <Optimization Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">Disabled</Optimization> + <FavorSizeOrSpeed Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">Size</FavorSizeOrSpeed> + <Optimization Condition="'$(Configuration)|$(Platform)'=='Release|x64'">Disabled</Optimization> + <FavorSizeOrSpeed Condition="'$(Configuration)|$(Platform)'=='Release|x64'">Size</FavorSizeOrSpeed> + </ClCompile> + <ClCompile Include="vceil.c" /> + <ClCompile Include="vfinite.c" /> + <ClCompile Include="vfloor.c" /> + <ClCompile Include="vfrexp.c" /> + <ClCompile Include="xerhlt.c" /> + </ItemGroup> + <ItemGroup> + <ClInclude Include="..\..\includes\dynlib_elementary_functions.h" /> + <ClInclude Include="..\..\includes\elementary_functions.h" /> + <ClInclude Include="..\..\includes\finite.h" /> + <ClInclude Include="..\..\includes\gw_elementary_functions.h" /> + <ClInclude Include="..\..\includes\idmax.h" /> + <ClInclude Include="..\..\includes\idmin.h" /> + <ClInclude Include="..\..\includes\int2db.h" /> + <ClInclude Include="..\..\includes\rea2b.h" /> + <ClInclude Include="..\..\includes\rea2db.h" /> + <ClInclude Include="..\..\includes\scidcopy.h" /> + <ClInclude Include="..\..\includes\unsfdcopy.h" /> + <ClInclude Include="..\..\includes\vfinite.h" /> + <ClInclude Include="..\..\includes\xerhlt.h" /> + <ClInclude Include="cmp.h" /> + <ClInclude Include="convertbase.h" /> + <ClInclude Include="gsort.h" /> + <ClInclude Include="IsEqualVar.h" /> + <ClInclude Include="qsort-char.h" /> + <ClInclude Include="qsort-double.h" /> + <ClInclude Include="qsort-int.h" /> + <ClInclude Include="qsort-short.h" /> + <ClInclude Include="qsort-string.h" /> + <ClInclude Include="qsort.h" /> + <ClInclude Include="vceil.h" /> + <ClInclude Include="vfloor.h" /> + <ClInclude Include="vfrexp.h" /> + </ItemGroup> + <ItemGroup> + <None Include="..\..\locales\elementary_functions.pot" /> + <None Include="elementary_functions_f_Import.def" /> + <None Include="core_import.def" /> + <None Include="..\..\elementary_functions.iss" /> + <None Include="..\..\sci_gateway\elementary_functions_gateway.xml" /> + <None Include="..\..\Makefile.am" /> + </ItemGroup> + <ItemGroup> + <ResourceCompile Include="elementary_functions.rc" /> + </ItemGroup> + <ItemGroup> + <ProjectReference Include="..\..\..\..\tools\Dumpexts\Dumpexts.vcxproj"> + <Project>{3170e4c2-1173-4264-a222-7ee8ccb3ddf7}</Project> + <ReferenceOutputAssembly>false</ReferenceOutputAssembly> + </ProjectReference> + <ProjectReference Include="..\..\..\api_scilab\api_scilab.vcxproj"> + <Project>{43c5bab1-1dca-4743-a183-77e0d42fe7d0}</Project> + <ReferenceOutputAssembly>false</ReferenceOutputAssembly> + </ProjectReference> + <ProjectReference Include="..\..\..\output_stream\src\c\output_stream.vcxproj"> + <Project>{a5911cd7-f8e8-440c-a23e-4843a0636f3a}</Project> + <ReferenceOutputAssembly>false</ReferenceOutputAssembly> + </ProjectReference> + </ItemGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.targets" /> + <ImportGroup Label="ExtensionTargets"> + </ImportGroup> +</Project>
\ No newline at end of file diff --git a/modules/elementary_functions/src/c/elementary_functions.vcxproj.filters b/modules/elementary_functions/src/c/elementary_functions.vcxproj.filters new file mode 100755 index 000000000..fd95155d4 --- /dev/null +++ b/modules/elementary_functions/src/c/elementary_functions.vcxproj.filters @@ -0,0 +1,357 @@ +<?xml version="1.0" encoding="utf-8"?> +<Project ToolsVersion="4.0" xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <ItemGroup> + <Filter Include="Source Files"> + <UniqueIdentifier>{2532be4c-7f4f-4a9e-820f-06722d341c6b}</UniqueIdentifier> + <Extensions>cpp;c;cxx;rc;def;r;odl;idl;hpj;bat</Extensions> + </Filter> + <Filter Include="Header Files"> + <UniqueIdentifier>{d7cc4029-d91d-49f3-9b01-5c53fb62896f}</UniqueIdentifier> + <Extensions>h;hpp;hxx;hm;inl</Extensions> + </Filter> + <Filter Include="localization"> + <UniqueIdentifier>{52824dfe-3d89-4089-8d41-fdd0a8810c30}</UniqueIdentifier> + </Filter> + <Filter Include="Libraries Dependencies"> + <UniqueIdentifier>{24d1972f-fc65-4972-b9b5-54a21b8851bd}</UniqueIdentifier> + </Filter> + <Filter Include="Libraries Dependencies\Imports"> + <UniqueIdentifier>{b448109a-0d70-4f7e-9e44-0d6b8a41cb4e}</UniqueIdentifier> + </Filter> + <Filter Include="Resource File"> + <UniqueIdentifier>{efacc063-b3ce-4b6a-8cb7-9c31b2f5efd6}</UniqueIdentifier> + </Filter> + </ItemGroup> + <ItemGroup> + <ClCompile Include="cmp.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="DllmainElementary_functions.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="finite.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="gsort.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\gw_elementary_functions.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="idmax.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="idmin.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="int2db.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="IsEqualVar.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="qsort-char.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="qsort-double.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="qsort-int.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="qsort-short.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="qsort-string.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="qsort.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="rea2db.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_abs.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_acos.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_asin.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_atan.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_ceil.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_chinesehat.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_clean.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_conj.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_cos.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_cumprod.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_cumsum.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_diag.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_dsearch.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_exp.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_expm.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_eye.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_floor.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_frexp.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_gsort.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_imag.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_imult.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_int.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_isequal.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_isequalbitwise.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_isreal.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_kron.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_log.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_log1p.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_matrix.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_maxi.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_nearfloat.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_number_properties.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_ones.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_prod.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_rand.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_rat.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_real.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_round.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_sign.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_sin.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_size.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_spones.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_sqrt.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_sum.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_tan.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_testmatrix.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_tril.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_triu.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_zeros.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="scidcopy.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="unsfdcopy.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="vceil.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="vfinite.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="vfloor.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="vfrexp.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="xerhlt.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="convertbase.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_base2dec.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_dec2base.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_find.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_log10.c"> + <Filter>Source Files</Filter> + </ClCompile> + </ItemGroup> + <ItemGroup> + <ClInclude Include="..\..\includes\dynlib_elementary_functions.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="..\..\includes\elementary_functions.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="..\..\includes\finite.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="..\..\includes\gw_elementary_functions.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="..\..\includes\idmax.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="..\..\includes\idmin.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="..\..\includes\int2db.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="..\..\includes\rea2b.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="..\..\includes\rea2db.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="..\..\includes\scidcopy.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="..\..\includes\unsfdcopy.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="..\..\includes\vfinite.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="..\..\includes\xerhlt.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="convertbase.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="cmp.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="gsort.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="IsEqualVar.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="qsort.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="qsort-char.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="qsort-double.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="qsort-int.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="qsort-short.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="qsort-string.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="vceil.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="vfloor.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="vfrexp.h"> + <Filter>Header Files</Filter> + </ClInclude> + </ItemGroup> + <ItemGroup> + <None Include="elementary_functions_f_Import.def"> + <Filter>Libraries Dependencies\Imports</Filter> + </None> + <None Include="core_import.def"> + <Filter>Libraries Dependencies\Imports</Filter> + </None> + <None Include="..\..\elementary_functions.iss" /> + <None Include="..\..\sci_gateway\elementary_functions_gateway.xml" /> + <None Include="..\..\Makefile.am" /> + <None Include="..\..\locales\elementary_functions.pot"> + <Filter>localization</Filter> + </None> + </ItemGroup> + <ItemGroup> + <ResourceCompile Include="elementary_functions.rc"> + <Filter>Resource File</Filter> + </ResourceCompile> + </ItemGroup> +</Project>
\ No newline at end of file diff --git a/modules/elementary_functions/src/c/elementary_functions_f_Import.def b/modules/elementary_functions/src/c/elementary_functions_f_Import.def new file mode 100755 index 000000000..3b91936b1 --- /dev/null +++ b/modules/elementary_functions/src/c/elementary_functions_f_Import.def @@ -0,0 +1,55 @@ +LIBRARY elementary_functions_f.dll + + +EXPORTS +; --------------------------------------- +; elementary_functions_f +; --------------------------------------- +intabs_ +intacos_ +intasin_ +intatan_ +intceil_ +intchinesehat_ +intclean_ +intconj_ +intcos_ +intcumprod_ +intcumsum_ +intdiag_ +intdsearch_ +intexp_ +intexpm_ +inteye_ +intfloor_ +intfrexp_ +intimag_ +intimult_ +intint_ +intisequal_ +intisreal_ +intkron_ +intlog_ +intlog1p_ +intmatrix_ +intmaxi_ +intnearfl_ +intnbprop_ +intones_ +intprod_ +intrand_ +intrat_ +intreal_ +intround_ +intsign_ +intsin_ +intsize_ +intspones_ +intsqrt_ +intsum_ +inttan_ +inttestmatrix_ +inttril_ +inttriu_ +intzeros_ +intfind_ diff --git a/modules/elementary_functions/src/c/f2c_workaround.c b/modules/elementary_functions/src/c/f2c_workaround.c new file mode 100755 index 000000000..9991c281e --- /dev/null +++ b/modules/elementary_functions/src/c/f2c_workaround.c @@ -0,0 +1,34 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) 2010 - DIGITEO - Allan CORNET + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ +/*--------------------------------------------------------------------------*/ +/* Workaround for bug 8175 with f2c Visual studio solution ONLY */ +/*--------------------------------------------------------------------------*/ +#include <string.h> +#include "machine.h" +/*--------------------------------------------------------------------------*/ +extern double C2F(slamch)(); +/*--------------------------------------------------------------------------*/ +double C2F(radix)(float *n) +{ + return C2F(slamch)("b", strlen("b")); +} +/*--------------------------------------------------------------------------*/ +double C2F(tiny)(float *n) +{ + return C2F(slamch)("u", strlen("u")); +} +/*--------------------------------------------------------------------------*/ +double C2F(huge)(float *n) +{ + return C2F(slamch)("o", strlen("o")); +} +/*--------------------------------------------------------------------------*/ diff --git a/modules/elementary_functions/src/c/finite.c b/modules/elementary_functions/src/c/finite.c new file mode 100755 index 000000000..e4c532edb --- /dev/null +++ b/modules/elementary_functions/src/c/finite.c @@ -0,0 +1,61 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) INRIA + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ + +#include "machine.h" +#include "core_math.h" +#include "finite.h" + +#if !(defined HAVE_FINITE) && (defined hppa) + +#include <math.h> + +int finite(double x) +{ + if (isfinite(x) == 0) + { + return 0; + } + return 1; +} + +#else +#if !(defined HAVE_FINITE) + +typedef unsigned int __uint32_t; +typedef union +{ + struct + { + __uint32_t lsw; + __uint32_t msw; + } parts; + double value; +} ieee_double_shape_type; + +int finite(double x) +{ + int hx; + ieee_double_shape_type gh_u; + + gh_u.value = x; + hx = gh_u.parts.msw; + return (int)((__uint32_t)((hx & 0x7fffffff) - 0x7ff00000) >> 31); +} + + +#endif +#endif + +int finiteComplex(doublecomplex x) +{ + return (finite(x.r) && finite(x.i)); +}
\ No newline at end of file diff --git a/modules/elementary_functions/src/c/gsort.c b/modules/elementary_functions/src/c/gsort.c new file mode 100755 index 000000000..1566674f4 --- /dev/null +++ b/modules/elementary_functions/src/c/gsort.c @@ -0,0 +1,284 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) 1998 - ENPC - Jean-Philippe CHANCELIER + * Copyright (C) 2006 - INRIA - Allan CORNET + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ + +/*--------------------------------------------------------------------------*/ +/* Written by Jean-Philippe Chancelier + * Modified (restructuration and bug fix) by Allan Cornet */ +/*--------------------------------------------------------------------------*/ +#include <stdio.h> +#include <string.h> +#include <math.h> +#include "core_math.h" +#include "gsort.h" + +#include "../../../string/includes/men_Sutils.h" +#include "MALLOC.h" +/*--------------------------------------------------------------------------*/ +#include "qsort.h" +#include "qsort-string.h" +#include "qsort-short.h" +#include "qsort-int.h" +#include "qsort-double.h" +#include "qsort-char.h" + +/*--------------------------------------------------------------------------*/ +/****************************************************** + * General sort routine for Scilab + * xI is the transmitted table to sort ( if table is int ) + * xD is the transmitted table to sort ( if table is double ) + * ind is the int table to store the permutation + * (which is to be initialized and changed ) + * iflag == if 1 ind is to be computed if 0 ind is ignored + * m,n : matrix size + * type : the operation ( see the interface ) + * iord : 'i' or 'd' : increasind or decreasing sort + ******************************************************/ +int C2F(gsortd)(double *xD, int *ind, int *iflag, int *m, int *n, char *type, char *iord) +{ + + switch ( type[0]) + { + case 'r' : + ColSortdouble(xD, ind, *iflag, *m, *n, iord[0]); + break; + case 'c' : + RowSortdouble(xD, ind, *iflag, *m, *n, iord[0]); + break; + case 'l' : + if ( type[1] == 'r' ) + { + CNAME(LexiRow, double)(xD, ind, *iflag, *m, *n, iord[0]); + } + else + { + CNAME(LexiCol, double)(xD, ind, *iflag, *m, *n, iord[0]); + } + break; + case 'g' : + default : + GlobalSortdouble(xD, ind, *iflag, *m, *n, iord[0]); + break; + } + return(0); +} + +int C2F(gsortint)(int *xI, int *ind, int *iflag, int *m, int *n, char *type, char *iord) +{ + + switch ( type[0]) + { + case 'r' : + ColSortint(xI, ind, *iflag, *m, *n, iord[0]); + break; + case 'c' : + RowSortint(xI, ind, *iflag, *m, *n, iord[0]); + break; + case 'l' : + if ( type[1] == 'r' ) + { + CNAME(LexiRow, int)(xI, ind, *iflag, *m, *n, iord[0]); + } + else + { + CNAME(LexiCol, int)(xI, ind, *iflag, *m, *n, iord[0]); + } + break; + case 'g' : + default : + GlobalSortint(xI, ind, *iflag, *m, *n, iord[0]); + break; + } + return(0); +} + +int C2F(gsortuint)(unsigned int *xI, int *ind, int *iflag, int *m, int *n, char *type, char *iord) +{ + + switch ( type[0]) + { + case 'r' : + ColSortuint(xI, ind, *iflag, *m, *n, iord[0]); + break; + case 'c' : + RowSortuint(xI, ind, *iflag, *m, *n, iord[0]); + break; + case 'l' : + if ( type[1] == 'r' ) + { + CNAME(LexiRow, uint)(xI, ind, *iflag, *m, *n, iord[0]); + } + else + { + CNAME(LexiCol, uint)(xI, ind, *iflag, *m, *n, iord[0]); + } + break; + case 'g' : + default : + GlobalSortuint(xI, ind, *iflag, *m, *n, iord[0]); + break; + } + return(0); +} + +int C2F(gsortshort)(short *xI, int *ind, int *iflag, int *m, int *n, char *type, char *iord) +{ + + switch ( type[0]) + { + case 'r' : + ColSortshort(xI, ind, *iflag, *m, *n, iord[0]); + break; + case 'c' : + RowSortshort(xI, ind, *iflag, *m, *n, iord[0]); + break; + case 'l' : + if ( type[1] == 'r' ) + { + CNAME(LexiRow, short)(xI, ind, *iflag, *m, *n, iord[0]); + } + else + { + CNAME(LexiCol, short)(xI, ind, *iflag, *m, *n, iord[0]); + } + break; + case 'g' : + default : + GlobalSortshort(xI, ind, *iflag, *m, *n, iord[0]); + break; + } + return(0); +} + +int C2F(gsortushort)(unsigned short *xI, int *ind, int *iflag, int *m, int *n, char *type, char *iord) +{ + + switch ( type[0]) + { + case 'r' : + ColSortushort(xI, ind, *iflag, *m, *n, iord[0]); + break; + case 'c' : + RowSortushort(xI, ind, *iflag, *m, *n, iord[0]); + break; + case 'l' : + if ( type[1] == 'r' ) + { + CNAME(LexiRow, ushort)(xI, ind, *iflag, *m, *n, iord[0]); + } + else + { + CNAME(LexiCol, ushort)(xI, ind, *iflag, *m, *n, iord[0]); + } + break; + case 'g' : + default : + GlobalSortushort(xI, ind, *iflag, *m, *n, iord[0]); + break; + } + return(0); +} + +int C2F(gsortchar)(char *xI, int *ind, int *iflag, int *m, int *n, char *type, char *iord) +{ + + switch ( type[0]) + { + case 'r' : + ColSortchar(xI, ind, *iflag, *m, *n, iord[0]); + break; + case 'c' : + RowSortchar(xI, ind, *iflag, *m, *n, iord[0]); + break; + case 'l' : + if ( type[1] == 'r' ) + { + CNAME(LexiRow, char)(xI, ind, *iflag, *m, *n, iord[0]); + } + else + { + CNAME(LexiCol, char)(xI, ind, *iflag, *m, *n, iord[0]); + } + break; + case 'g' : + default : + GlobalSortchar(xI, ind, *iflag, *m, *n, iord[0]); + break; + } + return(0); +} + +int C2F(gsortuchar)(unsigned char *xI, int *ind, int *iflag, int *m, int *n, char *type, char *iord) +{ + + switch ( type[0]) + { + case 'r' : + ColSortuchar(xI, ind, *iflag, *m, *n, iord[0]); + break; + case 'c' : + RowSortuchar(xI, ind, *iflag, *m, *n, iord[0]); + break; + case 'l' : + if ( type[1] == 'r' ) + { + CNAME(LexiRow, uchar)(xI, ind, *iflag, *m, *n, iord[0]); + } + else + { + CNAME(LexiCol, uchar)(xI, ind, *iflag, *m, *n, iord[0]); + } + break; + case 'g' : + default : + GlobalSortuchar(xI, ind, *iflag, *m, *n, iord[0]); + break; + } + return(0); +} + +/*--------------------------------------------------------------------------*/ +/****************************************************** + * General sort routine for Scilab strings + * iflag == if 1 ind is to be computed if 0 ind is ignored + * m,n : matrix size + * type : the operation ( see the interface ) + * iord : 'i' or 'd' : increasind or decreasing sort + ******************************************************/ +void C2F(gsorts)(char **data, int *ind, int *iflag, int *m, int *n, char *type, char *iord) +{ + + switch ( type[0]) + { + case 'r' : + ColSortstring(data, ind, *iflag, *m, *n, iord[0]); + break; + case 'c' : + RowSortstring(data, ind, *iflag, *m, *n, iord[0]); + break; + case 'l' : + if ( type[1] == 'r' ) + { + LexiRowstring(data, ind, *iflag, *m, *n, iord[0]); + } + else + { + LexiColstring(data, ind, *iflag, *m, *n, iord[0]); + } + break; + case 'g' : + default : + GlobalSortstring(data, ind, *iflag, *m, *n, iord[0]); + break; + } +} +/*--------------------------------------------------------------------------*/ diff --git a/modules/elementary_functions/src/c/gsort.h b/modules/elementary_functions/src/c/gsort.h new file mode 100755 index 000000000..eddebf96a --- /dev/null +++ b/modules/elementary_functions/src/c/gsort.h @@ -0,0 +1,42 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) 1998 - ENPC - Jean-Philippe CHANCELIER + * Copyright (C) 2006 - INRIA - Allan CORNET + * Copyright (C) ???? - INRIA - Jean-Baptiste SILVY + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ + +/*--------------------------------------------------------------------------*/ +/* Written by Jean-Philippe Chancelier */ +/* Modified (restructuration and bug fix) by Allan Cornet */ +/* Jean-Baptiste Silvy */ +/*--------------------------------------------------------------------------*/ + +#ifndef _GSORT_H_ +#define _GSORT_H_ + +#include "machine.h" +#define INCREASE_COMMAND 'i' +#define DECREASE_COMMAND 'd' +#define ROW_SORT 'r' +#define COLUMN_SORT 'c' +#define LIST_SORT 'l' +#define GLOBAL_SORT 'g' + + +void C2F(gsorts)(char **data, int *ind, int *iflag, int *m, int *n, char *type, char *iord); +int C2F(gsortd)(double *xD, int *ind, int *iflag, int *m, int *n, char *type, char *iord); +int C2F(gsortint)(int *xI, int *ind, int *iflag, int *m, int *n, char *type, char *iord); +int C2F(gsortuint)(unsigned int *xI, int *ind, int *iflag, int *m, int *n, char *type, char *iord); +int C2F(gsortshort)(short *xI, int *ind, int *iflag, int *m, int *n, char *type, char *iord); +int C2F(gsortushort)(unsigned short *xI, int *ind, int *iflag, int *m, int *n, char *type, char *iord); +int C2F(gsortchar)(char *xI, int *ind, int *iflag, int *m, int *n, char *type, char *iord); +int C2F(gsortuchar)(unsigned char *xI, int *ind, int *iflag, int *m, int *n, char *type, char *iord); + +#endif /* _GSORT_H_ */ diff --git a/modules/elementary_functions/src/c/idmax.c b/modules/elementary_functions/src/c/idmax.c new file mode 100755 index 000000000..4733d53b2 --- /dev/null +++ b/modules/elementary_functions/src/c/idmax.c @@ -0,0 +1,66 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) ???? - INRIA + * Copyright (C) 2003 - Bruno PINCON + * Copyright (C) 2007 - Allan CORNET + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ + +/*----------------------------------------------------------------------*/ +/* @author INRIA (initial fortran version) */ +/* @author Bruno Pincon (2003) bug fix for the nan problem */ +/* @author Allan Cornet (2007) rewrite to C */ +/*----------------------------------------------------------------------*/ +#include "idmax.h" +#include "isanan.h" +/*--------------------------------------------------------------------------*/ +int C2F(idmax)(int *n, double *x, int *incx) +{ + int x_dim1 = 0, x_offset = 0, ret_val = 0, i1; + + /* Local variables */ + int i = 0, j = 0; + double xmax; + + x_dim1 = *incx; + x_offset = 1 + x_dim1; + x -= x_offset; + + ret_val = 1; + /* initialize the max with the first component being not a nan */ + j = 1; + while (C2F(isanan)(&x[j * x_dim1 + 1]) == 1) + { + ++j; + if (j > *n) + { + return ret_val; + } + } + xmax = x[j * x_dim1 + 1]; + ret_val = j; + + /* the usual loop */ + i1 = *n; + for (i = j + 1; i <= i1; ++i) + { + if (x[i * x_dim1 + 1] > xmax) + { + /* the previous test must return false if x[i*x_dim1+1] is a nan + * so should not branch here in this case (for compiler + * managing ieee754 ... Intel Compiler doesn't) + */ + xmax = x[i * x_dim1 + 1]; + ret_val = i; + } + } + return ret_val; +} +/*--------------------------------------------------------------------------*/ + diff --git a/modules/elementary_functions/src/c/idmin.c b/modules/elementary_functions/src/c/idmin.c new file mode 100755 index 000000000..a38f8fa84 --- /dev/null +++ b/modules/elementary_functions/src/c/idmin.c @@ -0,0 +1,64 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) INRIA + * Copyright (C) 2003 - Bruno PINCON + * Copyright (C) 2007 - INRIA - Allan CORNET + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ + +/*----------------------------------------------------------------------*/ +/* @author INRIA (initial fortran version) */ +/* @author Bruno Pincon (2003) bug fix for the nan problem */ +/* @author Allan Cornet (2007) rewrite to C */ +/*----------------------------------------------------------------------*/ +#include "idmin.h" +#include "isanan.h" +/*--------------------------------------------------------------------------*/ +int C2F(idmin)(int *n, double *x, int *incx) +{ + + int x_dim1 = 0, x_offset = 0, ret_val = 0, i1 = 0; + int i = 0, j = 0; + double xmin = 0; + + x_dim1 = *incx; + x_offset = 1 + x_dim1; + x -= x_offset; + + ret_val = 1; + /* initialize the min with the first component being not a nan */ + j = 1; + while (C2F(isanan)(&x[j * x_dim1 + 1]) == 1) + { + ++j; + if (j > *n) + { + return ret_val; + } + } + xmin = x[j * x_dim1 + 1]; + ret_val = j; + + /* the usual loop */ + i1 = *n; + for (i = j + 1; i <= i1; ++i) + { + if (x[i * x_dim1 + 1] < xmin) + { + /* the previous test must return false if x[i*x_dim1+1] is a nan + * so should not branch here in this case (for compiler + * managing ieee754 ... Intel Compiler doesn't) + */ + xmin = x[i * x_dim1 + 1]; + ret_val = i; + } + } + return ret_val; +} +/*--------------------------------------------------------------------------*/ diff --git a/modules/elementary_functions/src/c/int2db.c b/modules/elementary_functions/src/c/int2db.c new file mode 100755 index 000000000..73aea9fd9 --- /dev/null +++ b/modules/elementary_functions/src/c/int2db.c @@ -0,0 +1,63 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) 2007 - INRIA + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ + +/*--------------------------------------------------------------------------*/ +#include "int2db.h" +/*--------------------------------------------------------------------------*/ +int C2F(int2db)(int *n, int *dx, int *incx, double *dy, int *incy) +{ + int i1 = 0, i = 0; + int ix = 0, iy = 0; + + --dy; + --dx; + + if (*n <= 0) + { + return 0; + } + + if (*incx == 1 && *incy == 1) + { + /* code for both increments equal to 1 */ + i1 = *n; + for (i = 1; i <= i1; ++i) + { + dy[i] = (double) dx[i]; + } + return 0; + } + + /* code for unequal increments or equal increments not equal to 1 */ + ix = 1; + iy = 1; + + if (*incx < 0) + { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) + { + iy = (-(*n) + 1) * *incy + 1; + } + iy = (-(*n) + 1) * *incy + 1; + i1 = *n; + for (i = 1; i <= i1; ++i) + { + dy[iy] = (double) dx[ix]; + ix += *incx; + iy += *incy; + } + return 0; +} +/*--------------------------------------------------------------------------*/ + diff --git a/modules/elementary_functions/src/c/libdummy_elementary_functions_la-unsfdcopy.lo b/modules/elementary_functions/src/c/libdummy_elementary_functions_la-unsfdcopy.lo new file mode 100755 index 000000000..17ebcfbab --- /dev/null +++ b/modules/elementary_functions/src/c/libdummy_elementary_functions_la-unsfdcopy.lo @@ -0,0 +1,12 @@ +# src/c/libdummy_elementary_functions_la-unsfdcopy.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/libdummy_elementary_functions_la-unsfdcopy.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/c/libscielementary_functions_algo_la-IsEqualVar.lo b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-IsEqualVar.lo new file mode 100755 index 000000000..7156287e0 --- /dev/null +++ b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-IsEqualVar.lo @@ -0,0 +1,12 @@ +# src/c/libscielementary_functions_algo_la-IsEqualVar.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/libscielementary_functions_algo_la-IsEqualVar.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/c/libscielementary_functions_algo_la-cmp.lo b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-cmp.lo new file mode 100755 index 000000000..bc704d715 --- /dev/null +++ b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-cmp.lo @@ -0,0 +1,12 @@ +# src/c/libscielementary_functions_algo_la-cmp.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/libscielementary_functions_algo_la-cmp.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/c/libscielementary_functions_algo_la-convertbase.lo b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-convertbase.lo new file mode 100755 index 000000000..3acc3d6a5 --- /dev/null +++ b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-convertbase.lo @@ -0,0 +1,12 @@ +# src/c/libscielementary_functions_algo_la-convertbase.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/libscielementary_functions_algo_la-convertbase.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/c/libscielementary_functions_algo_la-finite.lo b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-finite.lo new file mode 100755 index 000000000..af4f926cf --- /dev/null +++ b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-finite.lo @@ -0,0 +1,12 @@ +# src/c/libscielementary_functions_algo_la-finite.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/libscielementary_functions_algo_la-finite.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/c/libscielementary_functions_algo_la-gsort.lo b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-gsort.lo new file mode 100755 index 000000000..5e8896748 --- /dev/null +++ b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-gsort.lo @@ -0,0 +1,12 @@ +# src/c/libscielementary_functions_algo_la-gsort.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/libscielementary_functions_algo_la-gsort.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/c/libscielementary_functions_algo_la-idmax.lo b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-idmax.lo new file mode 100755 index 000000000..2ab31c35f --- /dev/null +++ b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-idmax.lo @@ -0,0 +1,12 @@ +# src/c/libscielementary_functions_algo_la-idmax.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/libscielementary_functions_algo_la-idmax.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/c/libscielementary_functions_algo_la-idmin.lo b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-idmin.lo new file mode 100755 index 000000000..afeef1325 --- /dev/null +++ b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-idmin.lo @@ -0,0 +1,12 @@ +# src/c/libscielementary_functions_algo_la-idmin.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/libscielementary_functions_algo_la-idmin.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/c/libscielementary_functions_algo_la-int2db.lo b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-int2db.lo new file mode 100755 index 000000000..545d951b6 --- /dev/null +++ b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-int2db.lo @@ -0,0 +1,12 @@ +# src/c/libscielementary_functions_algo_la-int2db.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/libscielementary_functions_algo_la-int2db.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/c/libscielementary_functions_algo_la-qsort-char.lo b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-qsort-char.lo new file mode 100755 index 000000000..268529cdf --- /dev/null +++ b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-qsort-char.lo @@ -0,0 +1,12 @@ +# src/c/libscielementary_functions_algo_la-qsort-char.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/libscielementary_functions_algo_la-qsort-char.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/c/libscielementary_functions_algo_la-qsort-double.lo b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-qsort-double.lo new file mode 100755 index 000000000..c1d0f7bb6 --- /dev/null +++ b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-qsort-double.lo @@ -0,0 +1,12 @@ +# src/c/libscielementary_functions_algo_la-qsort-double.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/libscielementary_functions_algo_la-qsort-double.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/c/libscielementary_functions_algo_la-qsort-int.lo b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-qsort-int.lo new file mode 100755 index 000000000..370085763 --- /dev/null +++ b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-qsort-int.lo @@ -0,0 +1,12 @@ +# src/c/libscielementary_functions_algo_la-qsort-int.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/libscielementary_functions_algo_la-qsort-int.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/c/libscielementary_functions_algo_la-qsort-short.lo b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-qsort-short.lo new file mode 100755 index 000000000..f3cfce48d --- /dev/null +++ b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-qsort-short.lo @@ -0,0 +1,12 @@ +# src/c/libscielementary_functions_algo_la-qsort-short.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/libscielementary_functions_algo_la-qsort-short.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/c/libscielementary_functions_algo_la-qsort-string.lo b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-qsort-string.lo new file mode 100755 index 000000000..645992877 --- /dev/null +++ b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-qsort-string.lo @@ -0,0 +1,12 @@ +# src/c/libscielementary_functions_algo_la-qsort-string.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/libscielementary_functions_algo_la-qsort-string.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/c/libscielementary_functions_algo_la-qsort.lo b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-qsort.lo new file mode 100755 index 000000000..a1e91f2ff --- /dev/null +++ b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-qsort.lo @@ -0,0 +1,12 @@ +# src/c/libscielementary_functions_algo_la-qsort.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/libscielementary_functions_algo_la-qsort.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/c/libscielementary_functions_algo_la-rea2db.lo b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-rea2db.lo new file mode 100755 index 000000000..a62d10636 --- /dev/null +++ b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-rea2db.lo @@ -0,0 +1,12 @@ +# src/c/libscielementary_functions_algo_la-rea2db.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/libscielementary_functions_algo_la-rea2db.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/c/libscielementary_functions_algo_la-scidcopy.lo b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-scidcopy.lo new file mode 100755 index 000000000..00e6c445c --- /dev/null +++ b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-scidcopy.lo @@ -0,0 +1,12 @@ +# src/c/libscielementary_functions_algo_la-scidcopy.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/libscielementary_functions_algo_la-scidcopy.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/c/libscielementary_functions_algo_la-vceil.lo b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-vceil.lo new file mode 100755 index 000000000..9a9758098 --- /dev/null +++ b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-vceil.lo @@ -0,0 +1,12 @@ +# src/c/libscielementary_functions_algo_la-vceil.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/libscielementary_functions_algo_la-vceil.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/c/libscielementary_functions_algo_la-vfinite.lo b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-vfinite.lo new file mode 100755 index 000000000..f6b3ee726 --- /dev/null +++ b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-vfinite.lo @@ -0,0 +1,12 @@ +# src/c/libscielementary_functions_algo_la-vfinite.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/libscielementary_functions_algo_la-vfinite.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/c/libscielementary_functions_algo_la-vfloor.lo b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-vfloor.lo new file mode 100755 index 000000000..b4fda6bd1 --- /dev/null +++ b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-vfloor.lo @@ -0,0 +1,12 @@ +# src/c/libscielementary_functions_algo_la-vfloor.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/libscielementary_functions_algo_la-vfloor.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/c/libscielementary_functions_algo_la-vfrexp.lo b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-vfrexp.lo new file mode 100755 index 000000000..9c96361d5 --- /dev/null +++ b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-vfrexp.lo @@ -0,0 +1,12 @@ +# src/c/libscielementary_functions_algo_la-vfrexp.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/libscielementary_functions_algo_la-vfrexp.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/c/libscielementary_functions_algo_la-xerhlt.lo b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-xerhlt.lo new file mode 100755 index 000000000..0c827b6b3 --- /dev/null +++ b/modules/elementary_functions/src/c/libscielementary_functions_algo_la-xerhlt.lo @@ -0,0 +1,12 @@ +# src/c/libscielementary_functions_algo_la-xerhlt.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/libscielementary_functions_algo_la-xerhlt.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/c/qsort-char.c b/modules/elementary_functions/src/c/qsort-char.c new file mode 100755 index 000000000..bad257b12 --- /dev/null +++ b/modules/elementary_functions/src/c/qsort-char.c @@ -0,0 +1,558 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) ???? - ENPC - Jean-Philippe CHANCELIER + * Copyright (C) 2006 - INRIA - Serge STEER + * Copyright (C) 2006 - INRIA - Allan CORNET + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ +/* + * Modified 2006 by S.Steer and A.Cornet INRIA (changing generic code to sepcialized code + * by hand macro expansion). + * Modified 2009 by S.Steer INRIA (to make in stable when index is wanted) + */ + +#include "qsort.h" +#include "qsort-char.h" + +static int swapcodechar(char * parmi, char * parmj, int n, int incr) +{ + int i = n; + register char *pi = (char *) (parmi); + register char *pj = (char *) (parmj); + register int inc1 = incr / sizeof(char); + do + { + register char t = *pi; + *pi = *pj; + *pj = t; + pi += inc1; + pj += inc1; + } + while (--i > 0); + return(0); +} +/*--------------------------------------------------------------------------*/ +static int compareCchar(char *i, char *j, char *indi, char *indj, int iflag) +{ + if ( *((char *)i) > *((char *)j)) + { + return (1); + } + if ( *((char *)i) < * ((char *)j)) + { + return (-1); + } + if (iflag) + { + if ( *((int *)indi) > *((int *)indj)) + { + return (1); + } + if ( *((int *)indi) < * ((int *)indj)) + { + return (-1); + } + } + return (0); +} +/*--------------------------------------------------------------------------*/ +static int compareDchar(char *i, char *j, char *indi, char *indj, int iflag) +{ + if ( *((char *)i) < * ((char *)j)) + { + return (1); + } + if ( *((char *)i) > *((char *)j)) + { + return (-1); + } + if (iflag) + { + if ( *((int *)indi) > *((int *)indj)) + { + return (1); + } + if ( *((int *)indi) < * ((int *)indj)) + { + return (-1); + } + } + return (0); +} +/*--------------------------------------------------------------------------*/ +static int compareCuchar(char *i, char *j, char *indi, char *indj, int iflag) +{ + if ( *((unsigned char *)i) > *((unsigned char *)j)) + { + return (1); + } + if ( *((unsigned char *)i) < * ((unsigned char *)j)) + { + return (-1); + } + if (iflag) + { + if ( *((int *)indi) > *((int *)indj)) + { + return (1); + } + if ( *((int *)indi) < * ((int *)indj)) + { + return (-1); + } + } + return (0); +} +/*--------------------------------------------------------------------------*/ +static int compareDuchar(char *i, char *j, char *indi, char *indj, int iflag) +{ + if ( *((unsigned char *)i) < * ((unsigned char *)j)) + { + return (1); + } + if ( *((unsigned char *)i) > *((unsigned char *)j)) + { + return (-1); + } + if (iflag) + { + if ( *((int *)indi) > *((int *)indj)) + { + return (1); + } + if ( *((int *)indi) < * ((int *)indj)) + { + return (-1); + } + } + return (0); +} +/*--------------------------------------------------------------------------*/ +/****************************************************** + * Column sort of a matrix + ******************************************************/ +void ColSortchar(char *a, int *ind, int flag, int n, int p, char dir) +{ + int i, j; + if ( flag == 1) + { + for ( j = 0 ; j < p ; j++ ) + { + for ( i = 0 ; i < n ; i++) + { + ind[i + n * j] = i + 1; + } + } + } + for ( j = 0 ; j < p ; j++ ) + { + sciqsort((char *) (a + n * j), (char *) (ind + n * j), flag, n, + sizeof(char), sizeof(int), + (dir == 'i' ) ? compareCchar : compareDchar, + swapcodechar, swapcodeind); + } +} +/*--------------------------------------------------------------------------*/ +/****************************************************** + * Row sort of a matrix + ******************************************************/ +void RowSortchar(char *a, int *ind, int flag, int n, int p, char dir) +{ + int i, j; + if ( flag == 1) + { + for ( i = 0 ; i < n ; i++) + { + for ( j = 0 ; j < p ; j++ ) + { + ind[i + n * j] = j + 1; + } + } + } + for ( i = 0 ; i < n ; i++) + { + sciqsort((char *) (a + i), (char *) (ind + i), flag, p, + n * sizeof(char), n * sizeof(int), + (dir == 'i' ) ? compareCchar : compareDchar, + swapcodechar, swapcodeind); + } +} +/*--------------------------------------------------------------------------*/ +/****************************************************** + * Global sort of a Matrix + ******************************************************/ +void GlobalSortchar(char *a, int *ind, int flag, int n, int p, char dir) +{ + int i; + if ( flag == 1) + { + for ( i = 0 ; i < n * p ; i++) + { + ind[i] = i + 1; + } + } + sciqsort((char *) (a), (char *) (ind), flag, n * p, + sizeof(char), sizeof(int), + (dir == 'i' ) ? compareCchar : compareDchar, + swapcodechar, swapcodeind); +} +/*--------------------------------------------------------------------------*/ +/*--------------------------------------------------------------------------*/ +/****************************************************** + * Column sort of a matrix + ******************************************************/ +void ColSortuchar(unsigned char *a, int *ind, int flag, int n, int p, char dir) +{ + int i, j; + if ( flag == 1) + { + for ( j = 0 ; j < p ; j++ ) + { + for ( i = 0 ; i < n ; i++) + { + ind[i + n * j] = i + 1; + } + } + } + for ( j = 0 ; j < p ; j++ ) + { + sciqsort((char *) (a + n * j), (char *) (ind + n * j), flag, n, + sizeof(char), sizeof(int), + (dir == 'i' ) ? compareCuchar : compareDuchar, + swapcodechar, swapcodeind); + } +} +/*--------------------------------------------------------------------------*/ +/****************************************************** + * Row sort of a matrix + ******************************************************/ +void RowSortuchar(unsigned char *a, int *ind, int flag, int n, int p, char dir) +{ + int i, j; + if ( flag == 1) + { + for ( i = 0 ; i < n ; i++) + { + for ( j = 0 ; j < p ; j++ ) + { + ind[i + n * j] = j + 1; + } + } + } + for ( i = 0 ; i < n ; i++) + { + sciqsort((char *) (a + i), (char *) (ind + i), flag, p, + n * sizeof(char), n * sizeof(int), + (dir == 'i' ) ? compareCuchar : compareDuchar, + swapcodechar, swapcodeind); + } +} +/*--------------------------------------------------------------------------*/ +/****************************************************** + * Global sort of a Matrix + ******************************************************/ +void GlobalSortuchar(unsigned char *a, int *ind, int flag, int n, int p, char dir) +{ + int i; + if ( flag == 1) + { + for ( i = 0 ; i < n * p ; i++) + { + ind[i] = i + 1; + } + } + sciqsort((char *) (a), (char *) (ind), flag, n * p, + sizeof(char), sizeof(int), + (dir == 'i' ) ? compareCuchar : compareDuchar, + swapcodechar, swapcodeind); +} +/*--------------------------------------------------------------------------*/ +/******************************************************* + * lexicographic order with Rows ind is of size n + * ind gives the permutation of the rows which is applied + * to sort them + ******************************************************/ +static int lexicolschar = 1; +static int lexirowschar = 1; +/*--------------------------------------------------------------------------*/ +static void setLexiSizechar(int n, int p) +{ + lexicolschar = p; + lexirowschar = n; +} + +static int LexiRowcompareCchar(char *i, char *j) +{ + int jc; + for ( jc = 0 ; jc < lexicolschar ; jc++) + { + if (*i > *j) + { + return (1); + } + if (*i < *j) + { + return (-1); + } + i += lexirowschar; + j += lexirowschar; + } + return (0); +} +static int LexiRowcompareDchar(char *i, char*j) +{ + int jc; + for ( jc = 0 ; jc < lexicolschar ; jc++) + { + if (*i < *j) + { + return (1); + } + if (*i > *j) + { + return (-1); + } + i += lexirowschar; + j += lexirowschar; + } + return (0); +} +static int LexiRowcompareCuchar(unsigned char *i, unsigned char *j) +{ + int jc; + for ( jc = 0 ; jc < lexicolschar ; jc++) + { + if (*i > *j) + { + return (1); + } + if (*i < *j) + { + return (-1); + } + i += lexirowschar; + j += lexirowschar; + } + return (0); +} +static int LexiRowcompareDuchar(unsigned char *i, unsigned char*j) +{ + int jc; + for ( jc = 0 ; jc < lexicolschar ; jc++) + { + if (*i < *j) + { + return (1); + } + if (*i > *j) + { + return (-1); + } + i += lexirowschar; + j += lexirowschar; + } + return (0); +} +/*--------------------------------------------------------------------------*/ +static int LexiRowswapcodechar(char *parmi, char * parmj, int n) +{ + int i = n, j; + register char *pi = (char *) (parmi); + register char *pj = (char *) (parmj); + /* if ( n!= 1) printf(" swapcode avec n != 1\n"); */ + do + { + for ( j = 0 ; j < lexicolschar ; j++) + { + register char t = *(pi + lexirowschar * j); + *(pi + lexirowschar * j) = *(pj + lexirowschar * j); + *(pj + lexirowschar * j) = t; + } + pi++; + pj++; + } + while (--i > 0); + return(0); +} +/*--------------------------------------------------------------------------*/ +void LexiRowchar(char *a, int *ind, int flag, int n, int p, char dir) +{ + int i; + setLexiSizechar(n, p); + if ( flag == 1) + { + for ( i = 0 ; i < n ; i++) + { + ind[i] = i + 1; + } + } + sciqsort((char *) (a), (char *) (ind), flag, n, + sizeof(char), sizeof(int), + (dir == 'i' ) ? LexiRowcompareCchar : LexiRowcompareDchar, + LexiRowswapcodechar, swapcodeind); +} + +/*--------------------------------------------------------------------------*/ +void LexiRowuchar(unsigned char *a, int *ind, int flag, int n, int p, char dir) +{ + int i; + setLexiSizechar(n, p); + if ( flag == 1) + { + for ( i = 0 ; i < n ; i++) + { + ind[i] = i + 1; + } + } + sciqsort((char *) (a), (char *) (ind), flag, n, + sizeof(char), sizeof(int), + (dir == 'i' ) ? LexiRowcompareCuchar : LexiRowcompareDuchar, + LexiRowswapcodechar, swapcodeind); +} +/*--------------------------------------------------------------------------*/ +/****************************************************** + * lexicographic order with Cols ind is of size p + * ind gives the permutation of the column which is applied + * to sort them + ******************************************************/ +static int LexiColcompareCchar(char *i, char *j) +{ + int ic; + for ( ic = 0 ; ic < lexirowschar ; ic++) + { + if (*i > *j) + { + return (1); + } + if (*i < *j) + { + return (-1); + } + i++; + j++; + } + return (0); +} +/*--------------------------------------------------------------------------*/ +static int LexiColcompareDchar(char *i, char *j) +{ + int ic; + for ( ic = 0 ; ic < lexirowschar ; ic++) + { + if (*i < *j) + { + return (1); + } + if (*i > *j) + { + return (-1); + } + i++; + j++; + } + return (0); +} +/*--------------------------------------------------------------------------*/ +static int LexiColcompareCuchar(unsigned char *i, unsigned char *j) +{ + int ic; + for ( ic = 0 ; ic < lexirowschar ; ic++) + { + if (*i > *j) + { + return (1); + } + if (*i < *j) + { + return (-1); + } + i++; + j++; + } + return (0); +} +/*--------------------------------------------------------------------------*/ +static int LexiColcompareDuchar(unsigned char *i, unsigned char *j) +{ + int ic; + for ( ic = 0 ; ic < lexirowschar ; ic++) + { + if (*i < *j) + { + return (1); + } + if (*i > *j) + { + return (-1); + } + i++; + j++; + } + return (0); +} + +/*--------------------------------------------------------------------------*/ +static int LexiColswapcodechar(char *parmi, char* parmj, int n) +{ + int i = n, ir; + register char *pi = (char *) (parmi); + register char *pj = (char *) (parmj); + /* if ( n!= 1) printf(" swapcode avec n != 1\n"); */ + do + { + for ( ir = 0 ; ir < lexirowschar ; ir++) + { + register char t = *(pi + ir); + *(pi + ir) = *(pj + ir); + *(pj + ir) = t; + } + pi += lexirowschar ; + pj += lexirowschar ; + } + while (--i > 0); + return(0); +} +/*--------------------------------------------------------------------------*/ +void LexiColchar(char *a, int *ind, int flag, int n, int p, char dir) +{ + int i; + setLexiSizechar(n, p); + if ( flag == 1) + { + for ( i = 0 ; i < p ; i++) + { + ind[i] = i + 1; + } + } + sciqsort((char *) (a), (char *) (ind), flag, p, + n * sizeof(char), sizeof(int), + (dir == 'i' ) ? LexiColcompareCchar : LexiColcompareDchar, + LexiColswapcodechar, + swapcodeind); +} +/*--------------------------------------------------------------------------*/ +void LexiColuchar(unsigned char *a, int *ind, int flag, int n, int p, char dir) +{ + int i; + setLexiSizechar(n, p); + if ( flag == 1) + { + for ( i = 0 ; i < p ; i++) + { + ind[i] = i + 1; + } + } + sciqsort((char *) (a), (char *) (ind), flag, p, + n * sizeof(char), sizeof(int), + (dir == 'i' ) ? LexiColcompareCuchar : LexiColcompareDuchar, + LexiColswapcodechar, + swapcodeind); +} +/*--------------------------------------------------------------------------*/ + diff --git a/modules/elementary_functions/src/c/qsort-char.h b/modules/elementary_functions/src/c/qsort-char.h new file mode 100755 index 000000000..f8d220e43 --- /dev/null +++ b/modules/elementary_functions/src/c/qsort-char.h @@ -0,0 +1,32 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) 2006 - INRIA - Sylvestre LEDRU + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ +/*------------------------------------------------------------------------*/ +#ifndef __QSORT_CHAR_H__ +#define __QSORT_CHAR_H__ + +void ColSortchar(char *a, int *ind, int flag, int n, int p, char dir); +void RowSortchar(char *a, int *ind, int flag, int n, int p, char dir); + +void GlobalSortchar(char *a, int *ind, int flag, int n, int p, char dir); + +void ColSortuchar(unsigned char *a, int *ind, int flag, int n, int p, char dir); +void RowSortuchar(unsigned char *a, int *ind, int flag, int n, int p, char dir); + +void GlobalSortuchar(unsigned char *a, int *ind, int flag, int n, int p, char dir); + + +void LexiColuchar(unsigned char *a, int *ind, int flag, int n, int p, char dir); +void LexiRowchar(char *a, int *ind, int flag, int n, int p, char dir); +void LexiRowuchar(unsigned char *a, int *ind, int flag, int n, int p, char dir); +void LexiColchar(char *a, int *ind, int flag, int n, int p, char dir); + +#endif /* __QSORT_CHAR_H__ */ diff --git a/modules/elementary_functions/src/c/qsort-double.c b/modules/elementary_functions/src/c/qsort-double.c new file mode 100755 index 000000000..8f8a5847e --- /dev/null +++ b/modules/elementary_functions/src/c/qsort-double.c @@ -0,0 +1,331 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) ???? - ENPC - Jean-Philippe CHANCELIER + * Copyright (C) 2006 - INRIA - Serge STEER + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ + +/* + * Modified 2006 by S.Steer and A.Cornet INRIA (changing generic code to sepcialized code + * by hand macro expansion). + * Modified 2009 by S.Steer INRIA (to make in stable when index is wanted) + */ + + +#include "qsort.h" +#include "qsort-double.h" +#include "isanan.h" + +static int swapcodedouble(char * parmi, char * parmj, int n, int inc) +{ + int i = n; + register double *pi = (double *) (parmi); + register double *pj = (double *) (parmj); + register int inc1 = inc / sizeof(double); + do + { + register double t = *pi; + *pi = *pj; + *pj = t; + pi += inc1; + pj += inc1; + } + while (--i > 0); + return(0); +} +/*--------------------------------------------------------------------------*/ +static int compareCdouble(char *i, char *j, char *indi, char *indj, int iflag) +{ + if ( *((double *)i) > *((double *)j) || C2F(isanan)((double *)i) == 1) + { + return (1); + } + if ( *((double *)i) < * ((double *)j) || C2F(isanan)((double *)j) == 1) + { + return (-1); + } + if (iflag) + { + if ( *((int *)indi) > *((int *)indj)) + { + return (1); + } + if ( *((int *)indi) < * ((int *)indj)) + { + return (-1); + } + } + return (0); +} +/*--------------------------------------------------------------------------*/ +static int compareDdouble(char *i, char *j, char *indi, char *indj, int iflag) +{ + if ( *((double *)i) < * ((double *)j) || C2F(isanan)((double *)j) == 1) + { + return (1); + } + if ( *((double *)i) > *((double *)j) || C2F(isanan)((double *)i) == 1) + { + return (-1); + } + if (iflag) + { + if ( *((int *)indi) > *((int *)indj)) + { + return (1); + } + if ( *((int *)indi) < * ((int *)indj)) + { + return (-1); + } + } + return (0); +} +/*--------------------------------------------------------------------------*/ +/****************************************************** + * Column sort of a matrix + ******************************************************/ +void ColSortdouble(double *a, int *ind, int flag, int n, int p, char dir) +{ + int i, j; + if ( flag == 1) + { + for ( j = 0 ; j < p ; j++ ) + { + for ( i = 0 ; i < n ; i++) + { + ind[i + n * j] = i + 1; + } + } + } + + for ( j = 0 ; j < p ; j++ ) + { + sciqsort((char *) (a + n * j), (char *) (ind + n * j), flag, n, + sizeof(double), sizeof(int), + (dir == 'i' ) ? compareCdouble : compareDdouble, + swapcodedouble, swapcodeind); + } +} +/*--------------------------------------------------------------------------*/ +/****************************************************** + * Row sort of a matrix + ******************************************************/ +void RowSortdouble(double *a, int *ind, int flag, int n, int p, char dir) +{ + int i, j; + if ( flag == 1) + { + for ( i = 0 ; i < n ; i++) + { + for ( j = 0 ; j < p ; j++ ) + { + ind[i + n * j] = j + 1; + } + } + } + for ( i = 0 ; i < n ; i++) + { + sciqsort((char *) (a + i), (char *) (ind + i), flag, p, + n * sizeof(double), n * sizeof(int), + (dir == 'i' ) ? compareCdouble : compareDdouble, + swapcodedouble, swapcodeind); + } +} +/*--------------------------------------------------------------------------*/ +/****************************************************** + * Global sort of a Matrix + ******************************************************/ +void GlobalSortdouble(double *a, int *ind, int flag, int n, int p, char dir) +{ + int i; + if ( flag == 1) for ( i = 0 ; i < n * p ; i++) + { + ind[i] = i + 1; + } + sciqsort((char *) (a), (char *) (ind), flag, n * p, + sizeof(double), sizeof(int), + (dir == 'i' ) ? compareCdouble : compareDdouble, + swapcodedouble, swapcodeind); +} +/*--------------------------------------------------------------------------*/ +/******************************************************* + * lexicographic order with Rows ind is of size n + * ind gives the permutation of the rows which is applied + * to sort them + ******************************************************/ +static int lexicolsdouble = 1; +static int lexirowsdouble = 1; +/*--------------------------------------------------------------------------*/ +static void setLexiSizedouble(int n, int p) +{ + lexicolsdouble = p; + lexirowsdouble = n; +} +/*--------------------------------------------------------------------------*/ +static int LexiRowcompareCdouble(double *i, double *j) +{ + int jc; + + for ( jc = 0 ; jc < lexicolsdouble ; jc++) + { + if (*i > *j || (double *)C2F(isanan)((double *)i) == (double *) 1) + { + return (1); + } + if (*i < *j || (double *)C2F(isanan)((double *)j) == (double *) 1) + { + return (-1); + } + i += lexirowsdouble; + j += lexirowsdouble; + } + return (0); +} +/*--------------------------------------------------------------------------*/ +static int LexiRowcompareDdouble(double *i, double*j) +{ + int jc; + + for ( jc = 0 ; jc < lexicolsdouble ; jc++) + { + if (*i < *j || (double *)C2F(isanan)((double *)j) == (double *) 1) + { + return (1); + } + if (*i > *j || (double *)C2F(isanan)((double *)i) == (double *) 1) + { + return (-1); + } + i += lexirowsdouble; + j += lexirowsdouble; + } + return (0); +} +/*--------------------------------------------------------------------------*/ +static int LexiRowswapcodedouble(char *parmi, char * parmj, int n) +{ + int i = n, j; + register double *pi = (double *) (parmi); + register double *pj = (double *) (parmj); + + do + { + for ( j = 0 ; j < lexicolsdouble ; j++) + { + register double t = *(pi + lexirowsdouble * j); + *(pi + lexirowsdouble * j) = *(pj + lexirowsdouble * j); + *(pj + lexirowsdouble * j) = t; + } + pi++; + pj++; + } + while (--i > 0); + return(0); +} +/*--------------------------------------------------------------------------*/ +void LexiRowdouble(double *a, int *ind, int flag, int n, int p, char dir) +{ + int i; + setLexiSizedouble(n, p); + if ( flag == 1) + { + for ( i = 0 ; i < n ; i++) + { + ind[i] = i + 1; + } + } + sciqsort((char *) (a), (char *) (ind), flag, n, + sizeof(double), sizeof(int), + (dir == 'i' ) ? LexiRowcompareCdouble : LexiRowcompareDdouble, + LexiRowswapcodedouble, swapcodeind); +} +/*--------------------------------------------------------------------------*/ +/****************************************************** + * lexicographic order with Cols ind is of size p + * ind gives the permutation of the column which is applied + * to sort them + ******************************************************/ +static int LexiColcompareCdouble(double *i, double *j) +{ + int ic; + for ( ic = 0 ; ic < lexirowsdouble ; ic++) + { + if (*i > *j || (double *)C2F(isanan)((double *)i) == (double *) 1) + { + return (1); + } + if (*i < *j || (double *)C2F(isanan)((double *)j) == (double *) 1) + { + return (-1); + } + i++; + j++; + } + return (0); +} +/*--------------------------------------------------------------------------*/ +static int LexiColcompareDdouble(double *i, double *j) +{ + int ic; + for ( ic = 0 ; ic < lexirowsdouble ; ic++) + { + if (*i < *j || (double *)C2F(isanan)((double *)j) == (double *) 1) + { + return (1); + } + if (*i > *j || (double *)C2F(isanan)((double *)i) == (double *) 1) + { + return (-1); + } + i++; + j++; + } + return (0); +} +/*--------------------------------------------------------------------------*/ +static int LexiColswapcodedouble(char *parmi, char* parmj, int n) +{ + int i = n, ir; + register double *pi = (double *) (parmi); + register double *pj = (double *) (parmj); + do + { + for ( ir = 0 ; ir < lexirowsdouble ; ir++) + { + register double t = *(pi + ir); + *(pi + ir) = *(pj + ir); + *(pj + ir) = t; + } + pi += lexirowsdouble ; + pj += lexirowsdouble ; + } + while (--i > 0); + return(0); +} +/*--------------------------------------------------------------------------*/ +void LexiColdouble(double *a, int *ind, int flag, int n, int p, char dir) +{ + int i; + setLexiSizedouble(n, p); + if ( flag == 1) + { + for ( i = 0 ; i < p ; i++) + { + ind[i] = i + 1; + } + } + sciqsort((char *) (a), (char *) (ind), flag, p, + n * sizeof(double), sizeof(int), + (dir == 'i' ) ? LexiColcompareCdouble : LexiColcompareDdouble, + LexiColswapcodedouble, + swapcodeind); +} +/*--------------------------------------------------------------------------*/ + diff --git a/modules/elementary_functions/src/c/qsort-double.h b/modules/elementary_functions/src/c/qsort-double.h new file mode 100755 index 000000000..34d6fd461 --- /dev/null +++ b/modules/elementary_functions/src/c/qsort-double.h @@ -0,0 +1,22 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) 2006 - INRIA - Sylvestre LEDRU + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ +/*------------------------------------------------------------------------*/ +#ifndef __QSORT_DOUBLE_H__ +#define __QSORT_DOUBLE_H__ + +void ColSortdouble(double *a, int *ind, int flag, int n, int p, char dir); +void RowSortdouble(double *a, int *ind, int flag, int n, int p, char dir); +void GlobalSortdouble(double *a, int *ind, int flag, int n, int p, char dir); +void LexiRowdouble(double *a, int *ind, int flag, int n, int p, char dir); +void LexiColdouble(double *a, int *ind, int flag, int n, int p, char dir); + +#endif /* __QSORT_DOUBLE_H__ */ diff --git a/modules/elementary_functions/src/c/qsort-int.c b/modules/elementary_functions/src/c/qsort-int.c new file mode 100755 index 000000000..1eef00d14 --- /dev/null +++ b/modules/elementary_functions/src/c/qsort-int.c @@ -0,0 +1,540 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) ???? - ENPC - Jean-Philippe CHANCELIER + * Copyright (C) 2006 - INRIA - Serge STEER + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ +/* + * Modified 2006 by S.Steer and A.Cornet INRIA (changing generic code to sepcialized code + * by hand macro expansion). + * Modified 2009 by S.Steer INRIA (to make in stable when index is wanted) + */ +#include "qsort.h" +#include "qsort-int.h" + +/*--------------------------------------------------------------------------*/ +static int compareCint(char *i, char *j, char *indi, char *indj, int iflag) +{ + if ( *((int *)i) > *((int *)j)) + { + return (1); + } + if ( *((int *)i) < * ((int *)j)) + { + return (-1); + } + if (iflag) + { + if ( *((int *)indi) > *((int *)indj)) + { + return (1); + } + if ( *((int *)indi) < * ((int *)indj)) + { + return (-1); + } + } + return (0); +} +/*--------------------------------------------------------------------------*/ +static int compareDint(char *i, char *j, char *indi, char *indj, int iflag) +{ + if ( *((int *)i) < * ((int *)j)) + { + return (1); + } + if ( *((int *)i) > *((int *)j)) + { + return (-1); + } + if (iflag) + { + if ( *((int *)indi) > *((int *)indj)) + { + return (1); + } + if ( *((int *)indi) < * ((int *)indj)) + { + return (-1); + } + } + return (0); +} +/*--------------------------------------------------------------------------*/ +static int compareCuint(char *i, char *j, char *indi, char *indj, int iflag) +{ + if ( *((unsigned int *)i) > *((unsigned int *)j)) + { + return (1); + } + if ((unsigned int) * ((unsigned int *)i) < (unsigned int) * ((unsigned int *)j)) + { + return (-1); + } + if (iflag) + { + if ( *((int *)indi) > *((int *)indj)) + { + return (1); + } + if ( *((int *)indi) < * ((int *)indj)) + { + return (-1); + } + } + return (0); +} +/*--------------------------------------------------------------------------*/ +static int compareDuint(char *i, char *j, char *indi, char *indj, int iflag) +{ + if ((unsigned int) * ((unsigned int *)i) < (unsigned int) * ((unsigned int *)j)) + { + return (1); + } + if ( (unsigned int) * ((unsigned int *)i) > (unsigned int) * ((unsigned int *)j)) + { + return (-1); + } + if (iflag) + { + if ( *((int *)indi) > *((int *)indj)) + { + return (1); + } + if ( *((int *)indi) < * ((int *)indj)) + { + return (-1); + } + } + return (0); +} +/*--------------------------------------------------------------------------*/ + +/****************************************************** + * Column sort of a matrix + ******************************************************/ +void ColSortint(int *a, int *ind, int flag, int n, int p, char dir) +{ + int i, j; + if ( flag == 1) + { + for ( j = 0 ; j < p ; j++ ) + { + for ( i = 0 ; i < n ; i++) + { + ind[i + n * j] = i + 1; + } + } + } + for ( j = 0 ; j < p ; j++ ) + { + sciqsort((char *) (a + n * j), (char *) (ind + n * j), flag, n, + sizeof(int), sizeof(int), + (dir == 'i' ) ? compareCint : compareDint, + swapcodeint, swapcodeind); + } +} +/*--------------------------------------------------------------------------*/ +void ColSortuint(unsigned int *a, int *ind, int flag, int n, int p, char dir) +{ + int i, j; + if ( flag == 1) + { + for ( j = 0 ; j < p ; j++ ) + { + for ( i = 0 ; i < n ; i++) + { + ind[i + n * j] = i + 1; + } + } + } + for ( j = 0 ; j < p ; j++ ) + { + sciqsort((char *) (a + n * j), (char *) (ind + n * j), flag, n, + sizeof(int), sizeof(int), + (dir == 'i' ) ? compareCuint : compareDuint, + swapcodeint, swapcodeind); + } +} +/*--------------------------------------------------------------------------*/ + +/****************************************************** + * Row sort of a matrix + ******************************************************/ +void RowSortint(int *a, int *ind, int flag, int n, int p, char dir) +{ + int i, j; + if ( flag == 1) + { + for ( i = 0 ; i < n ; i++) + { + for ( j = 0 ; j < p ; j++ ) + { + ind[i + n * j] = j + 1; + } + } + } + for ( i = 0 ; i < n ; i++) + { + sciqsort((char *) (a + i), (char *) (ind + i), flag, p, + n * sizeof(int), n * sizeof(int), + (dir == 'i' ) ? compareCint : compareDint, + swapcodeint, swapcodeind); + } +} +/*--------------------------------------------------------------------------*/ +void RowSortuint(unsigned int *a, int *ind, int flag, int n, int p, char dir) +{ + int i, j; + if ( flag == 1) + { + for ( i = 0 ; i < n ; i++) + { + for ( j = 0 ; j < p ; j++ ) + { + ind[i + n * j] = j + 1; + } + } + } + for ( i = 0 ; i < n ; i++) + { + sciqsort((char *) (a + i), (char *) (ind + i), flag, p, + n * sizeof(int), n * sizeof(int), + (dir == 'i' ) ? compareCuint : compareDuint, + swapcodeint, swapcodeind); + } +} +/*--------------------------------------------------------------------------*/ + +/****************************************************** + * Global sort of a Matrix + ******************************************************/ +void GlobalSortint(int *a, int *ind, int flag, int n, int p, char dir) +{ + int i; + if ( flag == 1) + { + for ( i = 0 ; i < n * p ; i++) + { + ind[i] = i + 1; + } + } + sciqsort((char *) (a), (char *) (ind), flag, n * p, + sizeof(int), sizeof(int), + (dir == 'i' ) ? compareCint : compareDint, + swapcodeint, swapcodeind); +} + +/*--------------------------------------------------------------------------*/ +void GlobalSortuint(unsigned int *a, int *ind, int flag, int n, int p, char dir) +{ + int i; + if ( flag == 1) + { + for ( i = 0 ; i < n * p ; i++) + { + ind[i] = i + 1; + } + } + sciqsort((char *) (a), (char *) (ind), flag, n * p, + sizeof(int), sizeof(int), + (dir == 'i' ) ? compareCuint : compareDuint, + swapcodeint, swapcodeind); +} + +/*--------------------------------------------------------------------------*/ + +/******************************************************* + * lexicographic order with Rows ind is of size n + * ind gives the permutation of the rows which is applied + * to sort them + ******************************************************/ +static int lexicolsint = 1; +static int lexirowsint = 1; +/*--------------------------------------------------------------------------*/ +static void setLexiSizeint(int n, int p) +{ + lexicolsint = p; + lexirowsint = n; +} + +static int LexiRowcompareCint(int *i, int *j) +{ + int jc; + for ( jc = 0 ; jc < lexicolsint ; jc++) + { + if (*i > *j) + { + return (1); + } + if (*i < *j) + { + return (-1); + } + i += lexirowsint; + j += lexirowsint; + } + return (0); +} + +static int LexiRowcompareCuint(unsigned int *i, unsigned int *j) +{ + int jc; + for ( jc = 0 ; jc < lexicolsint ; jc++) + { + if (*i > *j) + { + return (1); + } + if (*i < *j) + { + return (-1); + } + i += lexirowsint; + j += lexirowsint; + } + return (0); +} + +static int LexiRowcompareDint(int *i, int*j) +{ + int jc; + for ( jc = 0 ; jc < lexicolsint ; jc++) + { + if (*i < *j) + { + return (1); + } + if (*i > *j) + { + return (-1); + } + i += lexirowsint; + j += lexirowsint; + } + return (0); +} + +static int LexiRowcompareDuint(unsigned int *i, unsigned int*j) +{ + int jc; + for ( jc = 0 ; jc < lexicolsint ; jc++) + { + if (*i < *j) + { + return (1); + } + if (*i > *j) + { + return (-1); + } + i += lexirowsint; + j += lexirowsint; + } + return (0); +} + +/*--------------------------------------------------------------------------*/ +static int LexiRowswapcodeint(char *parmi, char * parmj, int n) +{ + int i = n, j; + register int *pi = (int *) (parmi); + register int *pj = (int *) (parmj); + /* if ( n!= 1) printf(" swapcode avec n != 1\n"); */ + do + { + for ( j = 0 ; j < lexicolsint ; j++) + { + register int t = *(pi + lexirowsint * j); + *(pi + lexirowsint * j) = *(pj + lexirowsint * j); + *(pj + lexirowsint * j) = t; + } + pi++; + pj++; + } + while (--i > 0); + return(0); +} +/*--------------------------------------------------------------------------*/ +void LexiRowint(int *a, int *ind, int flag, int n, int p, char dir) +{ + int i; + setLexiSizeint(n, p); + if ( flag == 1) + { + for ( i = 0 ; i < n ; i++) + { + ind[i] = i + 1; + } + } + sciqsort((char *) (a), (char *) (ind), flag, n, + sizeof(int), sizeof(int), + (dir == 'i' ) ? LexiRowcompareCint : LexiRowcompareDint, + LexiRowswapcodeint, swapcodeind); +} + +void LexiRowuint(unsigned int *a, int *ind, int flag, int n, int p, char dir) +{ + int i; + setLexiSizeint(n, p); + if ( flag == 1) + { + for ( i = 0 ; i < n ; i++) + { + ind[i] = i + 1; + } + } + sciqsort((char *) (a), (char *) (ind), flag, n, + sizeof(int), sizeof(int), + (dir == 'i' ) ? LexiRowcompareCuint : LexiRowcompareDuint, + LexiRowswapcodeint, swapcodeind); +} + +/*--------------------------------------------------------------------------*/ +/****************************************************** + * lexicographic order with Cols ind is of size p + * ind gives the permutation of the column which is applied + * to sort them + ******************************************************/ +static int LexiColcompareCint(int *i, int *j) +{ + int ic; + for ( ic = 0 ; ic < lexirowsint ; ic++) + { + if (*i > *j) + { + return (1); + } + if (*i < *j) + { + return (-1); + } + i++; + j++; + } + return (0); +} + +static int LexiColcompareCuint(unsigned int *i, unsigned int *j) +{ + int ic; + for ( ic = 0 ; ic < lexirowsint ; ic++) + { + if (*i > *j) + { + return (1); + } + if (*i < *j) + { + return (-1); + } + i++; + j++; + } + return (0); +} + +/*--------------------------------------------------------------------------*/ +static int LexiColcompareDint(int *i, int *j) +{ + int ic; + for ( ic = 0 ; ic < lexirowsint ; ic++) + { + if (*i < *j) + { + return (1); + } + if (*i > *j) + { + return (-1); + } + i++; + j++; + } + return (0); +} + +static int LexiColcompareDuint(unsigned int *i, unsigned int *j) +{ + int ic; + for ( ic = 0 ; ic < lexirowsint ; ic++) + { + if (*i < *j) + { + return (1); + } + if (*i > *j) + { + return (-1); + } + i++; + j++; + } + return (0); +} +/*--------------------------------------------------------------------------*/ +static int LexiColswapcodeint(char *parmi, char* parmj, int n) +{ + int i = n, ir; + register int *pi = (int *) (parmi); + register int *pj = (int *) (parmj); + /* if ( n!= 1) printf(" swapcode avec n != 1\n"); */ + do + { + for ( ir = 0 ; ir < lexirowsint ; ir++) + { + register int t = *(pi + ir); + *(pi + ir) = *(pj + ir); + *(pj + ir) = t; + } + pi += lexirowsint ; + pj += lexirowsint ; + } + while (--i > 0); + return(0); +} +/*--------------------------------------------------------------------------*/ +void LexiColint(int *a, int *ind, int flag, int n, int p, char dir) +{ + int i; + setLexiSizeint(n, p); + if ( flag == 1) + { + for ( i = 0 ; i < p ; i++) + { + ind[i] = i + 1; + } + } + sciqsort((char *) (a), (char *) (ind), flag, p, + n * sizeof(int), sizeof(int), + (dir == 'i' ) ? LexiColcompareCint : LexiColcompareDint, + LexiColswapcodeint, + swapcodeind); +} + +void LexiColuint(unsigned int *a, int *ind, int flag, int n, int p, char dir) +{ + int i; + setLexiSizeint(n, p); + if ( flag == 1) + { + for ( i = 0 ; i < p ; i++) + { + ind[i] = i + 1; + } + } + sciqsort((char *) (a), (char *) (ind), flag, p, + n * sizeof(int), sizeof(int), + (dir == 'i' ) ? LexiColcompareCuint : LexiColcompareDuint, + LexiColswapcodeint, + swapcodeind); +} + +/*--------------------------------------------------------------------------*/ + diff --git a/modules/elementary_functions/src/c/qsort-int.h b/modules/elementary_functions/src/c/qsort-int.h new file mode 100755 index 000000000..2a8d1a782 --- /dev/null +++ b/modules/elementary_functions/src/c/qsort-int.h @@ -0,0 +1,28 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) 2006 - INRIA - Sylvestre LEDRU + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ + +/*------------------------------------------------------------------------*/ +#ifndef __QSORT_INT__ +#define __QSORT_INT__ + +void ColSortint(int *a, int *ind, int flag, int n, int p, char dir); +void ColSortuint(unsigned int *a, int *ind, int flag, int n, int p, char dir); +void RowSortint(int *a, int *ind, int flag, int n, int p, char dir); +void RowSortuint(unsigned int *a, int *ind, int flag, int n, int p, char dir); +void GlobalSortint(int *a, int *ind, int flag, int n, int p, char dir); +void GlobalSortuint(unsigned int *a, int *ind, int flag, int n, int p, char dir); +void LexiRowint(int *a, int *ind, int flag, int n, int p, char dir); +void LexiRowuint(unsigned int *a, int *ind, int flag, int n, int p, char dir); +void LexiColint(int *a, int *ind, int flag, int n, int p, char dir); +void LexiColuint(unsigned int *a, int *ind, int flag, int n, int p, char dir); + +#endif /* __QSORT_INT__ */ diff --git a/modules/elementary_functions/src/c/qsort-short.c b/modules/elementary_functions/src/c/qsort-short.c new file mode 100755 index 000000000..9cbe44b67 --- /dev/null +++ b/modules/elementary_functions/src/c/qsort-short.c @@ -0,0 +1,558 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) ???? - ENPC - Jean-Philippe CHANCELIER + * Copyright (C) 2006 - INRIA - Serge STEER + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ + +/* + * Modified 2006 by S.Steer and A.Cornet INRIA (changing generic code to sepcialized code + * by hand macro expansion). + * Modified 2009 by S.Steer INRIA (to make in stable when index is wanted) + */ + +#include "qsort.h" +#include "qsort-short.h" + +static int swapcodeshort(char * parmi, char * parmj, int n, int incr) +{ + int i = n; + register short *pi = (short *) (parmi); + register short *pj = (short *) (parmj); + register int inc1 = incr / sizeof(short); + do + { + register short t = *pi; + *pi = *pj; + *pj = t; + pi += inc1; + pj += inc1; + } + while (--i > 0); + return(0); +} +/*--------------------------------------------------------------------------*/ +static int compareCshort(char *i, char *j, char *indi, char *indj, int iflag) +{ + if ( *((short *)i) > *((short *)j)) + { + return (1); + } + if ( *((short *)i) < * ((short *)j)) + { + return (-1); + } + if (iflag) + { + if ( *((int *)indi) > *((int *)indj)) + { + return (1); + } + if ( *((int *)indi) < * ((int *)indj)) + { + return (-1); + } + } + return (0); +} +/*--------------------------------------------------------------------------*/ +static int compareDshort(char *i, char *j, char *indi, char *indj, int iflag) +{ + if ( *((short *)i) < * ((short *)j)) + { + return (1); + } + if ( *((short *)i) > *((short *)j)) + { + return (-1); + } + if (iflag) + { + if ( *((int *)indi) > *((int *)indj)) + { + return (1); + } + if ( *((int *)indi) < * ((int *)indj)) + { + return (-1); + } + } + return (0); +} +/*--------------------------------------------------------------------------*/ +static int compareCushort(char *i, char *j, char *indi, char *indj, int iflag) +{ + if ( *((unsigned short *)i) > *((unsigned short *)j)) + { + return (1); + } + if ( *((unsigned short *)i) < * ((unsigned short *)j)) + { + return (-1); + } + if (iflag) + { + if ( *((int *)indi) > *((int *)indj)) + { + return (1); + } + if ( *((int *)indi) < * ((int *)indj)) + { + return (-1); + } + } + return (0); +} +/*--------------------------------------------------------------------------*/ +static int compareDushort(char *i, char *j, char *indi, char *indj, int iflag) +{ + if ( *((unsigned short *)i) < * ((unsigned short *)j)) + { + return (1); + } + if ( *((unsigned short *)i) > *((unsigned short *)j)) + { + return (-1); + } + if (iflag) + { + if ( *((int *)indi) > *((int *)indj)) + { + return (1); + } + if ( *((int *)indi) < * ((int *)indj)) + { + return (-1); + } + } + return (0); +} +/*--------------------------------------------------------------------------*/ +/****************************************************** + * Column sort of a matrix + ******************************************************/ +void ColSortshort(short *a, int *ind, int flag, int n, int p, char dir) +{ + int i, j; + if ( flag == 1) + { + for ( j = 0 ; j < p ; j++ ) + { + for ( i = 0 ; i < n ; i++) + { + ind[i + n * j] = i + 1; + } + } + } + for ( j = 0 ; j < p ; j++ ) + { + sciqsort((char *) (a + n * j), (char *) (ind + n * j), flag, n, + sizeof(short), sizeof(int), + (dir == 'i' ) ? compareCshort : compareDshort, + swapcodeshort, swapcodeind); + } +} +/*--------------------------------------------------------------------------*/ +/****************************************************** + * Row sort of a matrix + ******************************************************/ +void RowSortshort(short *a, int *ind, int flag, int n, int p, char dir) +{ + int i, j; + if ( flag == 1) + { + for ( i = 0 ; i < n ; i++) + { + for ( j = 0 ; j < p ; j++ ) + { + ind[i + n * j] = j + 1; + } + } + } + for ( i = 0 ; i < n ; i++) + { + sciqsort((char *) (a + i), (char *) (ind + i), flag, p, + n * sizeof(short), n * sizeof(int), + (dir == 'i' ) ? compareCshort : compareDshort, + swapcodeshort, swapcodeind); + } +} +/*--------------------------------------------------------------------------*/ +/****************************************************** + * Global sort of a Matrix + ******************************************************/ +void GlobalSortshort(short *a, int *ind, int flag, int n, int p, char dir) +{ + int i; + if ( flag == 1) + { + for ( i = 0 ; i < n * p ; i++) + { + ind[i] = i + 1; + } + } + sciqsort((char *) (a), (char *) (ind), flag, n * p, + sizeof(short), sizeof(int), + (dir == 'i' ) ? compareCshort : compareDshort, + swapcodeshort, swapcodeind); +} +/*--------------------------------------------------------------------------*/ +/*--------------------------------------------------------------------------*/ +/****************************************************** + * Column sort of a matrix + ******************************************************/ +void ColSortushort(unsigned short *a, int *ind, int flag, int n, int p, char dir) +{ + int i, j; + if ( flag == 1) + { + for ( j = 0 ; j < p ; j++ ) + { + for ( i = 0 ; i < n ; i++) + { + ind[i + n * j] = i + 1; + } + } + } + for ( j = 0 ; j < p ; j++ ) + { + sciqsort((char *) (a + n * j), (char *) (ind + n * j), flag, n, + sizeof(short), sizeof(int), + (dir == 'i' ) ? compareCushort : compareDushort, + swapcodeshort, swapcodeind); + } +} +/*--------------------------------------------------------------------------*/ +/****************************************************** + * Row sort of a matrix + ******************************************************/ +void RowSortushort(unsigned short *a, int *ind, int flag, int n, int p, char dir) +{ + int i, j; + if ( flag == 1) + { + for ( i = 0 ; i < n ; i++) + { + for ( j = 0 ; j < p ; j++ ) + { + ind[i + n * j] = j + 1; + } + } + } + for ( i = 0 ; i < n ; i++) + { + sciqsort((char *) (a + i), (char *) (ind + i), flag, p, + n * sizeof(short), n * sizeof(int), + (dir == 'i' ) ? compareCushort : compareDushort, + swapcodeshort, swapcodeind); + } +} +/*--------------------------------------------------------------------------*/ +/****************************************************** + * Global sort of a Matrix + ******************************************************/ +void GlobalSortushort(unsigned short *a, int *ind, int flag, int n, int p, char dir) +{ + int i; + if ( flag == 1) + { + for ( i = 0 ; i < n * p ; i++) + { + ind[i] = i + 1; + } + } + sciqsort((char *) (a), (char *) (ind), flag, n * p, + sizeof(short), sizeof(int), + (dir == 'i' ) ? compareCushort : compareDushort, + swapcodeshort, swapcodeind); +} +/*--------------------------------------------------------------------------*/ +/******************************************************* + * lexicographic order with Rows ind is of size n + * ind gives the permutation of the rows which is applied + * to sort them + ******************************************************/ +static int lexicolsshort = 1; +static int lexirowsshort = 1; +/*--------------------------------------------------------------------------*/ +static void setLexiSizeshort(int n, int p) +{ + lexicolsshort = p; + lexirowsshort = n; +} + +static int LexiRowcompareCshort(short *i, short *j) +{ + int jc; + for ( jc = 0 ; jc < lexicolsshort ; jc++) + { + if (*i > *j) + { + return (1); + } + if (*i < *j) + { + return (-1); + } + i += lexirowsshort; + j += lexirowsshort; + } + return (0); +} +static int LexiRowcompareDshort(short *i, short*j) +{ + int jc; + for ( jc = 0 ; jc < lexicolsshort ; jc++) + { + if (*i < *j) + { + return (1); + } + if (*i > *j) + { + return (-1); + } + i += lexirowsshort; + j += lexirowsshort; + } + return (0); +} +static int LexiRowcompareCushort(unsigned short *i, unsigned short *j) +{ + int jc; + for ( jc = 0 ; jc < lexicolsshort ; jc++) + { + if (*i > *j) + { + return (1); + } + if (*i < *j) + { + return (-1); + } + i += lexirowsshort; + j += lexirowsshort; + } + return (0); +} +static int LexiRowcompareDushort(unsigned short *i, unsigned short*j) +{ + int jc; + for ( jc = 0 ; jc < lexicolsshort ; jc++) + { + if (*i < *j) + { + return (1); + } + if (*i > *j) + { + return (-1); + } + i += lexirowsshort; + j += lexirowsshort; + } + return (0); +} +/*--------------------------------------------------------------------------*/ +static int LexiRowswapcodeshort(char *parmi, char * parmj, int n) +{ + int i = n, j; + register short *pi = (short *) (parmi); + register short *pj = (short *) (parmj); + /* if ( n!= 1) printf(" swapcode avec n != 1\n"); */ + do + { + for ( j = 0 ; j < lexicolsshort ; j++) + { + register short t = *(pi + lexirowsshort * j); + *(pi + lexirowsshort * j) = *(pj + lexirowsshort * j); + *(pj + lexirowsshort * j) = t; + } + pi++; + pj++; + } + while (--i > 0); + return(0); +} +/*--------------------------------------------------------------------------*/ +void LexiRowshort(short *a, int *ind, int flag, int n, int p, char dir) +{ + int i; + setLexiSizeshort(n, p); + if ( flag == 1) + { + for ( i = 0 ; i < n ; i++) + { + ind[i] = i + 1; + } + } + sciqsort((char *) (a), (char *) (ind), flag, n, + sizeof(short), sizeof(int), + (dir == 'i' ) ? LexiRowcompareCshort : LexiRowcompareDshort, + LexiRowswapcodeshort, swapcodeind); +} + +/*--------------------------------------------------------------------------*/ +void LexiRowushort(unsigned short *a, int *ind, int flag, int n, int p, char dir) +{ + int i; + setLexiSizeshort(n, p); + if ( flag == 1) + { + for ( i = 0 ; i < n ; i++) + { + ind[i] = i + 1; + } + } + sciqsort((char *) (a), (char *) (ind), flag, n, + sizeof(short), sizeof(int), + (dir == 'i' ) ? LexiRowcompareCushort : LexiRowcompareDushort, + LexiRowswapcodeshort, swapcodeind); +} +/*--------------------------------------------------------------------------*/ +/****************************************************** + * lexicographic order with Cols ind is of size p + * ind gives the permutation of the column which is applied + * to sort them + ******************************************************/ +static int LexiColcompareCshort(short *i, short *j) +{ + int ic; + for ( ic = 0 ; ic < lexirowsshort ; ic++) + { + if (*i > *j) + { + return (1); + } + if (*i < *j) + { + return (-1); + } + i++; + j++; + } + return (0); +} +/*--------------------------------------------------------------------------*/ +static int LexiColcompareDshort(short *i, short *j) +{ + int ic; + for ( ic = 0 ; ic < lexirowsshort ; ic++) + { + if (*i < *j) + { + return (1); + } + if (*i > *j) + { + return (-1); + } + i++; + j++; + } + return (0); +} +/*--------------------------------------------------------------------------*/ +static int LexiColcompareCushort(unsigned short *i, unsigned short *j) +{ + int ic; + for ( ic = 0 ; ic < lexirowsshort ; ic++) + { + if (*i > *j) + { + return (1); + } + if (*i < *j) + { + return (-1); + } + i++; + j++; + } + return (0); +} +/*--------------------------------------------------------------------------*/ +static int LexiColcompareDushort(unsigned short *i, unsigned short *j) +{ + int ic; + for ( ic = 0 ; ic < lexirowsshort ; ic++) + { + if (*i < *j) + { + return (1); + } + if (*i > *j) + { + return (-1); + } + i++; + j++; + } + return (0); +} + +/*--------------------------------------------------------------------------*/ +static int LexiColswapcodeshort(char *parmi, char* parmj, int n) +{ + int i = n, ir; + register short *pi = (short *) (parmi); + register short *pj = (short *) (parmj); + /* if ( n!= 1) printf(" swapcode avec n != 1\n"); */ + do + { + for ( ir = 0 ; ir < lexirowsshort ; ir++) + { + register short t = *(pi + ir); + *(pi + ir) = *(pj + ir); + *(pj + ir) = t; + } + pi += lexirowsshort ; + pj += lexirowsshort ; + } + while (--i > 0); + return(0); +} +/*--------------------------------------------------------------------------*/ +void LexiColshort(short *a, int *ind, int flag, int n, int p, char dir) +{ + int i; + setLexiSizeshort(n, p); + if ( flag == 1) + { + for ( i = 0 ; i < p ; i++) + { + ind[i] = i + 1; + } + } + sciqsort((char *) (a), (char *) (ind), flag, p, + n * sizeof(short), sizeof(int), + (dir == 'i' ) ? LexiColcompareCshort : LexiColcompareDshort, + LexiColswapcodeshort, + swapcodeind); +} +/*--------------------------------------------------------------------------*/ +void LexiColushort(unsigned short *a, int *ind, int flag, int n, int p, char dir) +{ + int i; + setLexiSizeshort(n, p); + if ( flag == 1) + { + for ( i = 0 ; i < p ; i++) + { + ind[i] = i + 1; + } + } + sciqsort((char *) (a), (char *) (ind), flag, p, + n * sizeof(short), sizeof(int), + (dir == 'i' ) ? LexiColcompareCushort : LexiColcompareDushort, + LexiColswapcodeshort, + swapcodeind); +} +/*--------------------------------------------------------------------------*/ + diff --git a/modules/elementary_functions/src/c/qsort-short.h b/modules/elementary_functions/src/c/qsort-short.h new file mode 100755 index 000000000..ac58f3af8 --- /dev/null +++ b/modules/elementary_functions/src/c/qsort-short.h @@ -0,0 +1,32 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) 2006 - INRIA - Sylvestre LEDRU + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ +/*------------------------------------------------------------------------*/ +#ifndef __QSORT_SHORT_H__ +#define __QSORT_SHORT_H__ + +void ColSortshort(short *a, int *ind, int flag, int n, int p, char dir); +void RowSortshort(short *a, int *ind, int flag, int n, int p, char dir); +void GlobalSortshort(short *a, int *ind, int flag, int n, int p, char dir); + +void ColSortshort(short *a, int *ind, int flag, int n, int p, char dir); +void ColSortushort(unsigned short *a, int *ind, int flag, int n, int p, char dir); + +void RowSortushort(unsigned short *a, int *ind, int flag, int n, int p, char dir); +void GlobalSortushort(unsigned short *a, int *ind, int flag, int n, int p, char dir); + +void LexiRowshort(short *a, int *ind, int flag, int n, int p, char dir); +void LexiRowushort(unsigned short *a, int *ind, int flag, int n, int p, char dir); + +void LexiColshort(short *a, int *ind, int flag, int n, int p, char dir); +void LexiColushort(unsigned short *a, int *ind, int flag, int n, int p, char dir); + +#endif /* __QSORT_SHORT_H__ */ diff --git a/modules/elementary_functions/src/c/qsort-string.c b/modules/elementary_functions/src/c/qsort-string.c new file mode 100755 index 000000000..49fa507aa --- /dev/null +++ b/modules/elementary_functions/src/c/qsort-string.c @@ -0,0 +1,304 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) ???? - ENPC - Jean-Philippe CHANCELIER + * Copyright (C) 2006 - INRIA - Serge STEER + * Copyright (C) 2006 - INRIA - Allan CORNET + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ + +/* + * Modified 2006 S.Steer A.Cornet (changing generic code to sepcialized code + * by hand macro expansion). + * Modified 2009 by S.Steer (to make in stable when index is wanted) + */ +#include <string.h> +#include "qsort.h" +#include "qsort-string.h" + + +static int swapcodestring( char ** parmi, char ** parmj, int n, int incr) +{ + int i = n; + register char **pi = (char **) (parmi); + register char **pj = (char **) (parmj); + register int inc1 = incr / sizeof(char *); + do + { + register char *t = *pi; + *pi = *pj; + *pj = t; + pi += inc1; + pj += inc1; + } + while (--i > 0); + return(0); +} +/*--------------------------------------------------------------------------*/ +static int compareCstring(char *i, char *j, char *indi, char *indj, int iflag) +{ + int r = strcmp(*((char * *) i), *((char **) j)); + if (r == 0 && iflag) + { + if ( *((int *)indi) > *((int *)indj)) + { + r = 1; + } + if ( *((int *)indi) < * ((int *)indj)) + { + r = -1; + } + } + return(r); +} +/*--------------------------------------------------------------------------*/ +static int compareDstring(char *i, char *j, char *indi, char *indj, int iflag) +{ + int r = -strcmp(*((char * *) i), *((char **) j)); + if (r == 0 && iflag) + { + if ( *((int *)indi) > *((int *)indj)) + { + r = 1; + } + if ( *((int *)indi) < * ((int *)indj)) + { + r = -1; + } + } + return(r); +} +/*--------------------------------------------------------------------------*/ +/****************************************************** + * Column sort of a matrix + ******************************************************/ +void ColSortstring(char * *a, int *ind, int flag, int n, int p, char dir) +{ + int i, j; + if ( flag == 1) + { + for ( j = 0 ; j < p ; j++ ) + { + for ( i = 0 ; i < n ; i++) + { + ind[i + n * j] = i + 1; + } + } + } + for ( j = 0 ; j < p ; j++ ) + { + sciqsort((char *) (a + n * j), (char *) (ind + n * j), flag, n, + sizeof(char *), sizeof(int), + (dir == 'i' ) ? compareCstring : compareDstring, + swapcodestring, swapcodeind); + } +} +/*--------------------------------------------------------------------------*/ +/****************************************************** + * Row sort of a matrix + ******************************************************/ +void RowSortstring(char * *a, int *ind, int flag, int n, int p, char dir) +{ + int i, j; + if ( flag == 1) + { + for ( i = 0 ; i < n ; i++) + { + for ( j = 0 ; j < p ; j++ ) + { + ind[i + n * j] = j + 1; + } + } + } + for ( i = 0 ; i < n ; i++) + { + sciqsort((char *) (a + i), (char *) (ind + i), flag, p, + n * sizeof(char *), n * sizeof(int), + (dir == 'i' ) ? compareCstring : compareDstring, + swapcodestring, swapcodeind); + } +} +/*--------------------------------------------------------------------------*/ +/****************************************************** + * Global sort of a Matrix + ******************************************************/ +void GlobalSortstring(char * *a, int *ind, int flag, int n, int p, char dir) +{ + int i; + if ( flag == 1) + { + for ( i = 0 ; i < n * p ; i++) + { + ind[i] = i + 1; + } + } + sciqsort((char *) (a), (char *) (ind), flag, n * p, + sizeof(char *), sizeof(int), + (dir == 'i' ) ? compareCstring : compareDstring, + swapcodestring, swapcodeind); +} +/*--------------------------------------------------------------------------*/ +/******************************************************* + * lexicographic order with Rows ind is of size n + * ind gives the permutation of the rows which is applied + * to sort them + ******************************************************/ +static int lexicolsstring = 1; +static int lexirowsstring = 1; +/*--------------------------------------------------------------------------*/ +static void setLexiSizestring(int n, int p) +{ + lexicolsstring = p; + lexirowsstring = n; +} +/*--------------------------------------------------------------------------*/ +static int LexiRowcompareCstring(char * *i, char * *j) +{ + int jc; + for ( jc = 0 ; jc < lexicolsstring ; jc++) + { + int k = strcmp(*i, *j); + if ( k != 0) + { + return(k); + } + i += lexirowsstring; + j += lexirowsstring; + } + return (0); +} +/*--------------------------------------------------------------------------*/ +static int LexiRowcompareDstring(char * *i, char * *j) +{ + int jc; + for ( jc = 0 ; jc < lexicolsstring ; jc++) + { + int k = strcmp(*i, *j); + if ( k != 0) + { + return(-k); + } + i += lexirowsstring; + j += lexirowsstring; + } + return (0); +} +/*--------------------------------------------------------------------------*/ +static int LexiRowswapcodestring(char *parmi, char * parmj, int n) +{ + int i = n, j; + register char * *pi = (char * *) (parmi); + register char * *pj = (char * *) (parmj); + /* if ( n!= 1) printf(" swapcode avec n != 1\n"); */ + do + { + for ( j = 0 ; j < lexicolsstring ; j++) + { + register char * t = *(pi + lexirowsstring * j); + *(pi + lexirowsstring * j) = *(pj + lexirowsstring * j); + *(pj + lexirowsstring * j) = t; + } + pi++; + pj++; + } + while (--i > 0); + return(0); +} +/*--------------------------------------------------------------------------*/ +void LexiRowstring(char * *a, int *ind, int flag, int n, int p, char dir) +{ + int i; + setLexiSizestring(n, p); + if ( flag == 1) + { + for ( i = 0 ; i < n ; i++) + { + ind[i] = i + 1; + } + } + sciqsort((char *) (a), (char *) (ind), flag, n, + sizeof(char *), sizeof(int), + (dir == 'i' ) ? LexiRowcompareCstring : LexiRowcompareDstring, + LexiRowswapcodestring, swapcodeind); +} +/*--------------------------------------------------------------------------*/ +/****************************************************** + * lexicographic order with Cols ind is of size p + * ind gives the permutation of the column which is applied + * to sort them + ******************************************************/ +static int LexiColcompareCstring(char * *i, char * *j) +{ + int ic; + for ( ic = 0 ; ic < lexirowsstring ; ic++) + { + int k = strcmp(*i, *j); + if ( k != 0) + { + return(k); + } + i++; + j++; + } + return (0); +} +/*--------------------------------------------------------------------------*/ +static int LexiColcompareDstring(char * *i, char * *j) +{ + int ic; + for ( ic = 0 ; ic < lexirowsstring ; ic++) + { + int k = strcmp(*i, *j); + if ( k != 0) + { + return(-k); + } + i++; + j++; + } + return (0); +} +/*--------------------------------------------------------------------------*/ +static int LexiColswapcodestring(char *parmi, char* parmj, int n) +{ + int i = n, ir; + register char * *pi = (char * *) (parmi); + register char * *pj = (char * *) (parmj); + /* if ( n!= 1) printf(" swapcode avec n != 1\n"); */ + do + { + for ( ir = 0 ; ir < lexirowsstring ; ir++) + { + register char * t = *(pi + ir); + *(pi + ir) = *(pj + ir); + *(pj + ir) = t; + } + pi += lexirowsstring ; + pj += lexirowsstring ; + } + while (--i > 0); + return(0); +} +/*--------------------------------------------------------------------------*/ +void LexiColstring(char * *a, int *ind, int flag, int n, int p, char dir) +{ + int i; + setLexiSizestring(n, p); + if ( flag == 1) + { + for ( i = 0 ; i < p ; i++) + { + ind[i] = i + 1; + } + } + sciqsort((char *) (a), (char *) (ind), flag, p, + n * sizeof(char *), sizeof(int), + (dir == 'i' ) ? LexiColcompareCstring : LexiColcompareDstring, + LexiColswapcodestring, swapcodeind); +} +/*--------------------------------------------------------------------------*/ diff --git a/modules/elementary_functions/src/c/qsort-string.h b/modules/elementary_functions/src/c/qsort-string.h new file mode 100755 index 000000000..0fe08afb2 --- /dev/null +++ b/modules/elementary_functions/src/c/qsort-string.h @@ -0,0 +1,22 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) 2006 - INRIA - Sylvestre LEDRU + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ +/*------------------------------------------------------------------------*/ +#ifndef __QSORT_STRING_H__ +#define __QSORT_STRING_H__ + +void ColSortstring(char * *a, int *ind, int flag, int n, int p, char dir); +void RowSortstring(char * *a, int *ind, int flag, int n, int p, char dir); +void GlobalSortstring(char * *a, int *ind, int flag, int n, int p, char dir); +void LexiRowstring(char * *a, int *ind, int flag, int n, int p, char dir); +void LexiColstring(char * *a, int *ind, int flag, int n, int p, char dir); + +#endif /* __QSORT_STRING_H__ */ diff --git a/modules/elementary_functions/src/c/qsort.c b/modules/elementary_functions/src/c/qsort.c new file mode 100755 index 000000000..cd912cbc0 --- /dev/null +++ b/modules/elementary_functions/src/c/qsort.c @@ -0,0 +1,236 @@ +/* +* See Copyright below +* Copyright (c) 1992, 1993 +* The Regents of the University of California. All rights reserved. +*/ + +#include <stdlib.h> +#include <string.h> +/*--------------------------------------------------------------------------*/ +#include "qsort.h" +#include "qsort-int.h" +#include "qsort-short.h" +#include "qsort-char.h" +#include "qsort-double.h" +#include "qsort-string.h" +#include "core_math.h" +/*--------------------------------------------------------------------------*/ + +/*--------------------------------------------------------------------------*/ + +/*--------------------------------------------------------------------------*/ +/* $NetBSD: qsort.c,v 1.5 1995/12/28 08:52:36 thorpej Exp $ */ +/*- +* Copyright (c) 1992, 1993 +* The Regents of the University of California. All rights reserved. +* +* Redistribution and use in source and binary forms, with or without +* modification, are permitted provided that the following conditions +* are met: +* 1. Redistributions of source code must retain the above copyright +* notice, this list of conditions and the following disclaimer. +* 2. Redistributions in binary form must reproduce the above copyright +* notice, this list of conditions and the following disclaimer in the +* documentation and/or other materials provided with the distribution. +* 3. All advertising materials mentioning features or use of this software +* must display the following acknowledgement: +* This product includes software developed by the University of +* California, Berkeley and its contributors. +* 4. Neither the name of the University nor the names of its contributors +* may be used to endorse or promote products derived from this software +* without specific prior written permission. +* +* THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +* ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +* ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE +* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +* OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +* SUCH DAMAGE. +* +* Modified for Scilab Jean-Philippe Chancelier to keep a permutation index +* Modified for Scilab by Serge Steer to make it stable when permutation index is computed. +*/ +/*--------------------------------------------------------------------------*/ +/* +* Qsort routine from Bentley & McIlroy's "Engineering a Sort Function". +* Software---Practice and Experience, 23(11):1249-1265 +*/ +/*--------------------------------------------------------------------------*/ +void sciqsort(char *a, char *tab, int flag, int n, int es, int es1, int (*cmp)(), int (*swapcode)(), int (*lswapcodeind)()) +{ + char *pa, *pb, *pc, *pd, *pl, *pm, *pn; + char *taba, *tabb, *tabc, *tabd, *tabl, *tabm, *tabn; + int d, dind, r, r1; + +loop: + if (n < 7) /* Insertion sort on smallest arrays */ + { + for (pm = a + es, tabm = tab + es1 ; pm < (char *) a + n * es; pm += es, tabm += es1 ) + { + for (pl = pm, tabl = tabm ; pl > (char *) a && cmp(pl - es, pl, tabl - es1, tabl, flag) > 0; pl -= es, tabl -= es1) + { + swapind(tabl, tabl - es1); + swap(pl, pl - es); + } + } + + return; + } + + /*Determine the pivot */ + pm = a + (n / 2) * es;/* Small arrays, middle element */ + tabm = tab + (n / 2) * es1 ; + + pn = a + (n - 1) * es; + tabn = tab + (n - 1) * es1; + + if (n > 7) + { + pl = a; + tabl = tab; + if (n > 40) /* Big arrays, pseudomedian of 9 */ + { + dind = (n / 8) * es1; + d = (n / 8) * es; + med3(pl, tabl, pl, pl + d, pl + 2 * d, tabl, tabl + dind, tabl + 2 * dind, cmp); + med3(pm, tabm, pm - d, pm, pm + d, tabm - dind, tabm, tabm + dind, cmp); + med3(pn, tabn, pn - 2 * d, pn - d, pn, tabn - 2 * dind, tabn - dind, tabn, cmp); + } + med3(pm, tabm, pl, pm, pn, tabl, tabm, tabn, cmp); + } + + /* Put it at the first position */ + /* Partionning */ + if (cmp(pn, a, tabn, tab, flag)) + { + swapind(tab, tabn); + swap(a, pn); + } + + /* pointers on data array */ + pa = pb = a + es;/* pa and pb start from the beginning of the array */ + pc = pd = a + (n - 1) * es;/* pc and pd start from the end of the array */ + + /* similar pointers for index array */ + taba = tabb = tab + es1; + tabc = tabd = tab + (n - 1) * es1; + + /* here we have + |a |pa | pc| + |a |pb | pd| + |*a | ? | ? | + */ + for (;;) + { + /* increase the pointer pb while it points on values lesser than the pivot (pointer a) */ + while (pb <= pc && (r = cmp(pb, a, tabb, tab, flag)) <= 0) + { + if (r == 0) /*The pivot and value pointed to by pb are equal */ + { + /* store the equal value at the location pa and increase pa */ + swapind(taba, tabb); + taba += es1; + swap(pa, pb); + pa += es; + } + pb += es;/* next number */ + tabb += es1; + } + + /* here pb points on a value greater than the pivot */ + /* decrease the pointer pc while it points on a value greater than the pivot (pointer a) */ + while (pb <= pc && (r = cmp(pc, a, tabc, tab, flag)) >= 0) + { + if (r == 0) /*The pivot and value pointed to by pc are equal */ + { + /* store the equal value at the location pd and decrease pd */ + swapind(tabc, tabd); + tabd -= es1; + swap(pc, pd); + pd -= es; + } + pc -= es; + tabc -= es1; + } + /* here pc points on a value lesser than the pivot */ + if (pb > pc) + { + /* here we have + |a |pa |pc|pb pd| $| + | =*a | <*a | >*a | =*a $| + */ + /* partition is done */ + break; + } + /*here + pc points on a value lesser than the pivot + and + pb points on a value greater than the pivot + swap the values + */ + swapind(tabb, tabc); + tabb += es1; + tabc -= es1; + swap(pb, pc); + /* increase pb and decrease pc */ + pb += es; + pc -= es; + /* here we have + |a |pa |pb pc| pd| $| + | =*a | <*a | ? | >*a | =*a $| + */ + } + + /* put the equal values in the middle */ + pn = a + n * es; + r = (int)Min(pa - (char *)a, pb - pa); + vecswap(a, pb - r, r); + + tabn = tab + n * es1 ; + r1 = (int)Min(taba - (char *) tab, tabb - taba); + vecswapind(tab, tabb - r1, r1); + + r = (int)Min(pd - pc, pn - pd - es); + vecswap(pb, pn - r, r); + + r1 = (int)Min(tabd - tabc, tabn - tabd - es1 ); + vecswapind(tabb, tabn - r1, r1); + + if ((r = (int)(pb - pa)) > es ) + /* recall sciqsort for the lower part */ + { + sciqsort(a, tab, flag, r / es, es, es1, cmp, swapcode, lswapcodeind); + } + if ((r = (int)(pd - pc)) > es) + { + /* Iterate rather than recurse to save stack space */ + a = pn - r; + tab = tabn - (tabd - tabc); + n = r / es; + goto loop; + } +} +/*--------------------------------------------------------------------------*/ +int swapcodeint(char * parmi, char * parmj, int n, int incr) +{ + int i = n; + register int *pi = (int *) (parmi); + register int *pj = (int *) (parmj); + register int inc1 = incr / sizeof(int); + do + { + register int t = *pi; + *pi = *pj; + *pj = t; + pi += inc1; + pj += inc1; + } + while (--i > 0); + return(0); +} +/*--------------------------------------------------------------------------*/ diff --git a/modules/elementary_functions/src/c/qsort.h b/modules/elementary_functions/src/c/qsort.h new file mode 100755 index 000000000..d8bbaa560 --- /dev/null +++ b/modules/elementary_functions/src/c/qsort.h @@ -0,0 +1,29 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) INRIA + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ +/*------------------------------------------------------------------------*/ +#ifndef __QSORT_H__ +#define __QSORT_H__ + +void sciqsort(char *a, char *tab, int flag, int n, int es, int es1, int (*cmp) (), int (*swapcode) (), int (*swapcodeind) ()); +int swapcodeint(char * parmi, char * parmj, int n, int incr); + +#define swapcodeind swapcodeint +#define swap(a, b) swapcode(a, b, 1,es) +#define swapind(a, b) if ( flag==1) swapcodeind(a,b,1,es1) +#define vecswap(a, b, n) if ((n) > 0) swapcode(a, b, n/es,es) +#define vecswapind(a, b, n) if ((n) > 0 && flag == 1) swapcodeind(a,b,n/es1,es1) +#define med3(res,tabres,a, b, c, xa,xb,xc,cmp) cmp(a, b,xa,xb) < 0 ? \ + (cmp(b, c, xb, xc) < 0 ? (res=b,tabres=xb) : \ + (cmp(a, c, xa, xc) < 0 ? (res=c,tabres=xc) : (res=a,tabres=xa) )) \ + :(cmp(b, c, xb, xc) > 0 ? (res=b,tabres=xb) : (cmp(a, c, xa, xc) < 0 ? (res=a,tabres=xa) : (res=c,tabres=xc) )) + +#endif /* __QSORT_H__ */ diff --git a/modules/elementary_functions/src/c/rea2db.c b/modules/elementary_functions/src/c/rea2db.c new file mode 100755 index 000000000..dd3cb0497 --- /dev/null +++ b/modules/elementary_functions/src/c/rea2db.c @@ -0,0 +1,70 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) 2007 - INRIA + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ +/*--------------------------------------------------------------------------*/ +#include "rea2db.h" +/*--------------------------------------------------------------------------*/ +/* cette subroutine traduit un vecteur dx, de taille n, sur un + vecteur double precision dy. + dans le cas de deux increments egaux a 1, cette fonction + emploie des boucles "epanouies". + dans le cas ou les increments sont negatifs cette + fonction prend les composantes en ordre inverse. +*/ +/*--------------------------------------------------------------------------*/ +int C2F(rea2db)(int *n, float *dx, int *incx, double *dy, int *incy) +{ + int i1 = 0, i = 0, ix = 0, iy = 0; + + /* Parameter adjustments */ + --dy; + --dx; + + if (*n <= 0) + { + return 0; + } + + if (*incx == 1 && *incy == 1) + { + /* code for both increments equal to 1 */ + i1 = *n; + for (i = 1; i <= i1; ++i) + { + dy[i] = (double)dx[i]; + } + return 0; + } + + /* code for unequal increments or equal increments not equal to 1 */ + ix = 1; + iy = 1; + + if (*incx < 0) + { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) + { + iy = (-(*n) + 1) * *incy + 1; + } + + i1 = *n; + for (i = 1; i <= i1; ++i) + { + dy[iy] = (double)dx[ix]; + ix += *incx; + iy += *incy; + } + return 0; +} +/*--------------------------------------------------------------------------*/ + diff --git a/modules/elementary_functions/src/c/scidcopy.c b/modules/elementary_functions/src/c/scidcopy.c new file mode 100755 index 000000000..989150ff7 --- /dev/null +++ b/modules/elementary_functions/src/c/scidcopy.c @@ -0,0 +1,54 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) 2007 - INRIA - Allan CORNET + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ + +/* rewrite scidcopy.f */ +/*--------------------------------------------------------------------------*/ +/* alternative to dcopy for copying array with mixed datatypes */ +/* int*8 declaration used instead of double precision used to fix a */ +/* efficiency problem with pentium M processors */ +/*--------------------------------------------------------------------------*/ +#include <string.h> +#include "machine.h" +#include "scidcopy.h" +/*--------------------------------------------------------------------------*/ +int C2F(scidcopy)(int *n, const long long *dx, int *incx, long long *dy, int *incy) +{ + if (*n <= 0) + { + return 0; + } + + if ( (*incx == 1) && (*incy == 1) ) + { + /* code for both increments equal to 1 */ + /* clean-up loop */ + memcpy(dy , dx , (*n * sizeof(double)) ); + } + else + { + int i = 0; + + /* code for unequal increments or equal increments */ + /* not equal to 1 */ + int ix = *incx >= 0 ? 0 : (1 - *n) * *incx; + int iy = *incy >= 0 ? 0 : (1 - *n) * *incy ; + + for (i = 0; i < *n; i++) + { + dy[iy] = dx[ix]; + ix += *incx; + iy += *incy; + } + } + return 0; +} +/*--------------------------------------------------------------------------*/ diff --git a/modules/elementary_functions/src/c/unsfdcopy.c b/modules/elementary_functions/src/c/unsfdcopy.c new file mode 100755 index 000000000..ea805751a --- /dev/null +++ b/modules/elementary_functions/src/c/unsfdcopy.c @@ -0,0 +1,49 @@ +/* + * Copyright (C) 1978-1993 - Jack Dongarra, linpack + * Modified 12/3/93, array(1) declarations changed to array(*) + * Copyright (C) 2007 - INRIA - Allan CORNET (translation to C) + */ + +/*--------------------------------------------------------------------------*/ +/* rewrite unsfdcopy.f */ +/*--------------------------------------------------------------------------*/ +/* WARNING :*/ +/* ALWAYS BUILD unsfdcopy without optimization (Blended) */ +/* unsfdcopy same thing as scidcopy but built without optimization */ +/*--------------------------------------------------------------------------*/ +#include <string.h> /* memcpy */ +#include "machine.h" +#include "unsfdcopy.h" +/*--------------------------------------------------------------------------*/ +int C2F(unsfdcopy)(int *n, long long *dx, int *incx, long long *dy, int *incy) +{ + if (*n <= 0) + { + return 0; + } + + if ( (*incx == 1) && (*incy == 1) ) + { + /* code for both increments equal to 1 */ + /* clean-up loop */ + memmove(dy , dx , (*n * sizeof(double)) ); + } + else + { + int i = 0; + + /* code for unequal increments or equal increments */ + /* not equal to 1 */ + int ix = *incx >= 0 ? 0 : (1 - *n) * *incx; + int iy = *incy >= 0 ? 0 : (1 - *n) * *incy ; + + for (i = 0; i < *n; i++) + { + dy[iy] = dx[ix]; + ix += *incx; + iy += *incy; + } + } + return 0; +} +/*--------------------------------------------------------------------------*/ diff --git a/modules/elementary_functions/src/c/vceil.c b/modules/elementary_functions/src/c/vceil.c new file mode 100755 index 000000000..f84b44f30 --- /dev/null +++ b/modules/elementary_functions/src/c/vceil.c @@ -0,0 +1,40 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) INRIA + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ + +#include <math.h> +#include "machine.h" +#include "vceil.h" + + +void C2F(vceil)(int *n, double *x, int *ix, double *y, int *iy) +{ + int ix1, iy1, i; + ix1 = 0; + iy1 = 0; + + if (*ix < 0) + { + ix1 = -(*n - 1) * (*ix); + } + if (*iy < 0) + { + iy1 = -(*n - 1) * (*iy); + } + + for (i = 0; i < *n; i++) + { + y[iy1] = ceil(x[ix1]); + iy1 += *iy; + ix1 += *ix; + } +} + diff --git a/modules/elementary_functions/src/c/vceil.h b/modules/elementary_functions/src/c/vceil.h new file mode 100755 index 000000000..249bd89fb --- /dev/null +++ b/modules/elementary_functions/src/c/vceil.h @@ -0,0 +1,22 @@ +/* +* Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +* Copyright (C) 2010 - DIGITEO - Allan CORNET +* +* This file must be used under the terms of the CeCILL. +* This source file is licensed as described in the file COPYING, which +* you should have received as part of this distribution. The terms +* are also available at +* http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +* +*/ + +#ifndef __VCEIL_H__ +#define __VCEIL_H__ + +#include "machine.h" +#include "dynlib_elementary_functions.h" + +ELEMENTARY_FUNCTIONS_IMPEXP void C2F(vceil)(int *n, double *x, int *ix, double *y, int *iy); + +#endif /* __VCEIL_H__ */ + diff --git a/modules/elementary_functions/src/c/vfinite.c b/modules/elementary_functions/src/c/vfinite.c new file mode 100755 index 000000000..c1515b785 --- /dev/null +++ b/modules/elementary_functions/src/c/vfinite.c @@ -0,0 +1,41 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) INRIA + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ + + +/* checks if all entries of a vector are finite */ +#include "machine.h" +#include "core_math.h" +#include "vfinite.h" +#include "finite.h" + + +int C2F(vfinite)(int *n, double *v) +{ + int i; + for (i = 0; i < *n; i++) + if (finite(v[i]) == 0) + { + return 0; + } + return 1; +} + +int C2F(vfiniteComplex)(int *n, doublecomplex *v) +{ + int i; + for (i = 0; i < *n; i++) + if (finiteComplex(v[i]) == 0) + { + return 0; + } + return 1; +} diff --git a/modules/elementary_functions/src/c/vfloor.c b/modules/elementary_functions/src/c/vfloor.c new file mode 100755 index 000000000..71d070e7d --- /dev/null +++ b/modules/elementary_functions/src/c/vfloor.c @@ -0,0 +1,38 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) INRIA + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ + +#include <math.h> +#include "machine.h" +#include "vfloor.h" + +void C2F(vfloor)(int *n, double *x, int *ix, double *y, int *iy) +{ + int ix1, iy1, i; + ix1 = 0; + iy1 = 0; + + if (*ix < 0) + { + ix1 = -(*n - 1) * (*ix); + } + if (*iy < 0) + { + iy1 = -(*n - 1) * (*iy); + } + + for (i = 0; i < *n; i++) + { + y[iy1] = floor(x[ix1]); + iy1 += *iy; + ix1 += *ix; + } +} diff --git a/modules/elementary_functions/src/c/vfloor.h b/modules/elementary_functions/src/c/vfloor.h new file mode 100755 index 000000000..e36440c07 --- /dev/null +++ b/modules/elementary_functions/src/c/vfloor.h @@ -0,0 +1,22 @@ +/* +* Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +* Copyright (C) 2010 - DIGITEO - Allan CORNET +* +* This file must be used under the terms of the CeCILL. +* This source file is licensed as described in the file COPYING, which +* you should have received as part of this distribution. The terms +* are also available at +* http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +* +*/ + +#ifndef __VFLOOR_H__ +#define __VFLOOR_H__ + +#include "machine.h" +#include "dynlib_elementary_functions.h" + +ELEMENTARY_FUNCTIONS_IMPEXP void C2F(vfloor)(int *n, double *x, int *ix, double *y, int *iy); + +#endif /* __VFLOOR_H__ */ + diff --git a/modules/elementary_functions/src/c/vfrexp.c b/modules/elementary_functions/src/c/vfrexp.c new file mode 100755 index 000000000..b8a087fc0 --- /dev/null +++ b/modules/elementary_functions/src/c/vfrexp.c @@ -0,0 +1,46 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) INRIA + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ + +#include <math.h> +#include "machine.h" +#include "vfrexp.h" + + +void C2F(vfrexp)(int *n, double *x, int *ix, double *y, int *iy, double *z, int *iz) +{ + int ix1, iy1, iz1, i, j; + ix1 = 0; + iy1 = 0; + iz1 = 0; + + if (*ix < 0) + { + ix1 = -(*n - 1) * (*ix); + } + if (*iy < 0) + { + iy1 = -(*n - 1) * (*iy); + } + if (*iz < 0) + { + iz1 = -(*n - 1) * (*iz); + } + + for (i = 0; i < *n; i++) + { + y[iy1] = frexp(x[ix1], &j); + z[iz1] = j; + iy1 += *iy; + ix1 += *ix; + iz1 += *iz; + } +} diff --git a/modules/elementary_functions/src/c/vfrexp.h b/modules/elementary_functions/src/c/vfrexp.h new file mode 100755 index 000000000..f31851799 --- /dev/null +++ b/modules/elementary_functions/src/c/vfrexp.h @@ -0,0 +1,22 @@ +/* +* Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +* Copyright (C) 2010 - DIGITEO - Allan CORNET +* +* This file must be used under the terms of the CeCILL. +* This source file is licensed as described in the file COPYING, which +* you should have received as part of this distribution. The terms +* are also available at +* http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +* +*/ + +#ifndef __VFREXP_H__ +#define __VFREXP_H__ + +#include "machine.h" +#include "dynlib_elementary_functions.h" + +ELEMENTARY_FUNCTIONS_IMPEXP void C2F(vfrexp)(int *n, double *x, int *ix, double *y, int *iy, double *z, int *iz); + +#endif /* __VFREXP_H__ */ + diff --git a/modules/elementary_functions/src/c/xerhlt.c b/modules/elementary_functions/src/c/xerhlt.c new file mode 100755 index 000000000..e2176b2d2 --- /dev/null +++ b/modules/elementary_functions/src/c/xerhlt.c @@ -0,0 +1,30 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) INRIA + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ + +/*--------------------------------------------------------------------------*/ + +#include <string.h> +#include <setjmp.h> +#include "xerhlt.h" +/*--------------------------------------------------------------------------*/ +jmp_buf slatec_jmp_env; +/*--------------------------------------------------------------------------*/ +void C2F(xerhlt) (char *messg, unsigned long l) +{ + longjmp(slatec_jmp_env, 1); +} +/*--------------------------------------------------------------------------*/ +int setjmp_slatec_jmp_env(void) +{ + return setjmp(slatec_jmp_env); +} +/*--------------------------------------------------------------------------*/ diff --git a/modules/elementary_functions/src/fortran/.deps/.dirstamp b/modules/elementary_functions/src/fortran/.deps/.dirstamp new file mode 100755 index 000000000..e69de29bb --- /dev/null +++ b/modules/elementary_functions/src/fortran/.deps/.dirstamp diff --git a/modules/elementary_functions/src/fortran/.dirstamp b/modules/elementary_functions/src/fortran/.dirstamp new file mode 100755 index 000000000..e69de29bb --- /dev/null +++ b/modules/elementary_functions/src/fortran/.dirstamp diff --git a/modules/elementary_functions/src/fortran/.libs/arcosh.o b/modules/elementary_functions/src/fortran/.libs/arcosh.o Binary files differnew file mode 100755 index 000000000..cc1e58b74 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/arcosh.o diff --git a/modules/elementary_functions/src/fortran/.libs/bdiag.o b/modules/elementary_functions/src/fortran/.libs/bdiag.o Binary files differnew file mode 100755 index 000000000..f0a2340ce --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/bdiag.o diff --git a/modules/elementary_functions/src/fortran/.libs/cbal.o b/modules/elementary_functions/src/fortran/.libs/cbal.o Binary files differnew file mode 100755 index 000000000..81ba73f91 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/cbal.o diff --git a/modules/elementary_functions/src/fortran/.libs/cerr.o b/modules/elementary_functions/src/fortran/.libs/cerr.o Binary files differnew file mode 100755 index 000000000..744ee5cbe --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/cerr.o diff --git a/modules/elementary_functions/src/fortran/.libs/coef.o b/modules/elementary_functions/src/fortran/.libs/coef.o Binary files differnew file mode 100755 index 000000000..50ad794d8 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/coef.o diff --git a/modules/elementary_functions/src/fortran/.libs/comqr3.o b/modules/elementary_functions/src/fortran/.libs/comqr3.o Binary files differnew file mode 100755 index 000000000..faa0c49b0 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/comqr3.o diff --git a/modules/elementary_functions/src/fortran/.libs/corth.o b/modules/elementary_functions/src/fortran/.libs/corth.o Binary files differnew file mode 100755 index 000000000..6ff618e36 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/corth.o diff --git a/modules/elementary_functions/src/fortran/.libs/cortr.o b/modules/elementary_functions/src/fortran/.libs/cortr.o Binary files differnew file mode 100755 index 000000000..fd16ed278 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/cortr.o diff --git a/modules/elementary_functions/src/fortran/.libs/coshin.o b/modules/elementary_functions/src/fortran/.libs/coshin.o Binary files differnew file mode 100755 index 000000000..9b7fb427b --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/coshin.o diff --git a/modules/elementary_functions/src/fortran/.libs/cupro.o b/modules/elementary_functions/src/fortran/.libs/cupro.o Binary files differnew file mode 100755 index 000000000..a1d4c69d9 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/cupro.o diff --git a/modules/elementary_functions/src/fortran/.libs/cuproi.o b/modules/elementary_functions/src/fortran/.libs/cuproi.o Binary files differnew file mode 100755 index 000000000..f2623c6f9 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/cuproi.o diff --git a/modules/elementary_functions/src/fortran/.libs/cusum.o b/modules/elementary_functions/src/fortran/.libs/cusum.o Binary files differnew file mode 100755 index 000000000..38b5ee058 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/cusum.o diff --git a/modules/elementary_functions/src/fortran/.libs/d1mach.o b/modules/elementary_functions/src/fortran/.libs/d1mach.o Binary files differnew file mode 100755 index 000000000..580adaf65 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/d1mach.o diff --git a/modules/elementary_functions/src/fortran/.libs/dad.o b/modules/elementary_functions/src/fortran/.libs/dad.o Binary files differnew file mode 100755 index 000000000..22b5753d5 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/dad.o diff --git a/modules/elementary_functions/src/fortran/.libs/dadd.o b/modules/elementary_functions/src/fortran/.libs/dadd.o Binary files differnew file mode 100755 index 000000000..1d6a238df --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/dadd.o diff --git a/modules/elementary_functions/src/fortran/.libs/dclmat.o b/modules/elementary_functions/src/fortran/.libs/dclmat.o Binary files differnew file mode 100755 index 000000000..cd7f0dee3 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/dclmat.o diff --git a/modules/elementary_functions/src/fortran/.libs/ddif.o b/modules/elementary_functions/src/fortran/.libs/ddif.o Binary files differnew file mode 100755 index 000000000..0beaef90b --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/ddif.o diff --git a/modules/elementary_functions/src/fortran/.libs/ddpow.o b/modules/elementary_functions/src/fortran/.libs/ddpow.o Binary files differnew file mode 100755 index 000000000..048188314 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/ddpow.o diff --git a/modules/elementary_functions/src/fortran/.libs/ddpow1.o b/modules/elementary_functions/src/fortran/.libs/ddpow1.o Binary files differnew file mode 100755 index 000000000..8cd14bdcd --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/ddpow1.o diff --git a/modules/elementary_functions/src/fortran/.libs/ddpowe.o b/modules/elementary_functions/src/fortran/.libs/ddpowe.o Binary files differnew file mode 100755 index 000000000..65d8e1e4d --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/ddpowe.o diff --git a/modules/elementary_functions/src/fortran/.libs/ddrdiv.o b/modules/elementary_functions/src/fortran/.libs/ddrdiv.o Binary files differnew file mode 100755 index 000000000..3d1bc44d6 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/ddrdiv.o diff --git a/modules/elementary_functions/src/fortran/.libs/dexpm1.o b/modules/elementary_functions/src/fortran/.libs/dexpm1.o Binary files differnew file mode 100755 index 000000000..f6ce37161 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/dexpm1.o diff --git a/modules/elementary_functions/src/fortran/.libs/dipow.o b/modules/elementary_functions/src/fortran/.libs/dipow.o Binary files differnew file mode 100755 index 000000000..440e02ac0 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/dipow.o diff --git a/modules/elementary_functions/src/fortran/.libs/dipowe.o b/modules/elementary_functions/src/fortran/.libs/dipowe.o Binary files differnew file mode 100755 index 000000000..5c30965a9 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/dipowe.o diff --git a/modules/elementary_functions/src/fortran/.libs/dlblks.o b/modules/elementary_functions/src/fortran/.libs/dlblks.o Binary files differnew file mode 100755 index 000000000..535c4d44d --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/dlblks.o diff --git a/modules/elementary_functions/src/fortran/.libs/dlgama.o b/modules/elementary_functions/src/fortran/.libs/dlgama.o Binary files differnew file mode 100755 index 000000000..4b642a167 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/dlgama.o diff --git a/modules/elementary_functions/src/fortran/.libs/dmcopy.o b/modules/elementary_functions/src/fortran/.libs/dmcopy.o Binary files differnew file mode 100755 index 000000000..e0b9b5c60 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/dmcopy.o diff --git a/modules/elementary_functions/src/fortran/.libs/dmmul.o b/modules/elementary_functions/src/fortran/.libs/dmmul.o Binary files differnew file mode 100755 index 000000000..33b62ef35 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/dmmul.o diff --git a/modules/elementary_functions/src/fortran/.libs/dmmul1.o b/modules/elementary_functions/src/fortran/.libs/dmmul1.o Binary files differnew file mode 100755 index 000000000..336df6c1f --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/dmmul1.o diff --git a/modules/elementary_functions/src/fortran/.libs/dmprod.o b/modules/elementary_functions/src/fortran/.libs/dmprod.o Binary files differnew file mode 100755 index 000000000..ff4a034a7 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/dmprod.o diff --git a/modules/elementary_functions/src/fortran/.libs/dmsum.o b/modules/elementary_functions/src/fortran/.libs/dmsum.o Binary files differnew file mode 100755 index 000000000..1d616ce98 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/dmsum.o diff --git a/modules/elementary_functions/src/fortran/.libs/drdiv.o b/modules/elementary_functions/src/fortran/.libs/drdiv.o Binary files differnew file mode 100755 index 000000000..7604846e6 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/drdiv.o diff --git a/modules/elementary_functions/src/fortran/.libs/dsearch.o b/modules/elementary_functions/src/fortran/.libs/dsearch.o Binary files differnew file mode 100755 index 000000000..c45e6c056 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/dsearch.o diff --git a/modules/elementary_functions/src/fortran/.libs/dset.o b/modules/elementary_functions/src/fortran/.libs/dset.o Binary files differnew file mode 100755 index 000000000..d3d4a605f --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/dset.o diff --git a/modules/elementary_functions/src/fortran/.libs/dsort.o b/modules/elementary_functions/src/fortran/.libs/dsort.o Binary files differnew file mode 100755 index 000000000..58573fafc --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/dsort.o diff --git a/modules/elementary_functions/src/fortran/.libs/dsum.o b/modules/elementary_functions/src/fortran/.libs/dsum.o Binary files differnew file mode 100755 index 000000000..b9ec1b63b --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/dsum.o diff --git a/modules/elementary_functions/src/fortran/.libs/dtild.o b/modules/elementary_functions/src/fortran/.libs/dtild.o Binary files differnew file mode 100755 index 000000000..8dc0ec879 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/dtild.o diff --git a/modules/elementary_functions/src/fortran/.libs/dvmul.o b/modules/elementary_functions/src/fortran/.libs/dvmul.o Binary files differnew file mode 100755 index 000000000..411f039e9 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/dvmul.o diff --git a/modules/elementary_functions/src/fortran/.libs/dwdiv.o b/modules/elementary_functions/src/fortran/.libs/dwdiv.o Binary files differnew file mode 100755 index 000000000..afa88fc6d --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/dwdiv.o diff --git a/modules/elementary_functions/src/fortran/.libs/dwpow.o b/modules/elementary_functions/src/fortran/.libs/dwpow.o Binary files differnew file mode 100755 index 000000000..605738bf0 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/dwpow.o diff --git a/modules/elementary_functions/src/fortran/.libs/dwpow1.o b/modules/elementary_functions/src/fortran/.libs/dwpow1.o Binary files differnew file mode 100755 index 000000000..fb1a26eae --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/dwpow1.o diff --git a/modules/elementary_functions/src/fortran/.libs/dwpowe.o b/modules/elementary_functions/src/fortran/.libs/dwpowe.o Binary files differnew file mode 100755 index 000000000..a3221ac66 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/dwpowe.o diff --git a/modules/elementary_functions/src/fortran/.libs/dwrdiv.o b/modules/elementary_functions/src/fortran/.libs/dwrdiv.o Binary files differnew file mode 100755 index 000000000..0368dab9d --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/dwrdiv.o diff --git a/modules/elementary_functions/src/fortran/.libs/entier.o b/modules/elementary_functions/src/fortran/.libs/entier.o Binary files differnew file mode 100755 index 000000000..f3efb1dfd --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/entier.o diff --git a/modules/elementary_functions/src/fortran/.libs/exch.o b/modules/elementary_functions/src/fortran/.libs/exch.o Binary files differnew file mode 100755 index 000000000..611282c77 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/exch.o diff --git a/modules/elementary_functions/src/fortran/.libs/find.o b/modules/elementary_functions/src/fortran/.libs/find.o Binary files differnew file mode 100755 index 000000000..2e7a8aea4 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/find.o diff --git a/modules/elementary_functions/src/fortran/.libs/franck.o b/modules/elementary_functions/src/fortran/.libs/franck.o Binary files differnew file mode 100755 index 000000000..d45ecf423 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/franck.o diff --git a/modules/elementary_functions/src/fortran/.libs/gdcp2i.o b/modules/elementary_functions/src/fortran/.libs/gdcp2i.o Binary files differnew file mode 100755 index 000000000..36e0a1d1c --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/gdcp2i.o diff --git a/modules/elementary_functions/src/fortran/.libs/getdimfromvar.o b/modules/elementary_functions/src/fortran/.libs/getdimfromvar.o Binary files differnew file mode 100755 index 000000000..9a10a089d --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/getdimfromvar.o diff --git a/modules/elementary_functions/src/fortran/.libs/getorient.o b/modules/elementary_functions/src/fortran/.libs/getorient.o Binary files differnew file mode 100755 index 000000000..44efdc687 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/getorient.o diff --git a/modules/elementary_functions/src/fortran/.libs/hilber.o b/modules/elementary_functions/src/fortran/.libs/hilber.o Binary files differnew file mode 100755 index 000000000..77e0db4b3 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/hilber.o diff --git a/modules/elementary_functions/src/fortran/.libs/i1mach.o b/modules/elementary_functions/src/fortran/.libs/i1mach.o Binary files differnew file mode 100755 index 000000000..8d964e934 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/i1mach.o diff --git a/modules/elementary_functions/src/fortran/.libs/imcopy.o b/modules/elementary_functions/src/fortran/.libs/imcopy.o Binary files differnew file mode 100755 index 000000000..a8c1e0176 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/imcopy.o diff --git a/modules/elementary_functions/src/fortran/.libs/infinity.o b/modules/elementary_functions/src/fortran/.libs/infinity.o Binary files differnew file mode 100755 index 000000000..dc468a9c0 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/infinity.o diff --git a/modules/elementary_functions/src/fortran/.libs/intp.o b/modules/elementary_functions/src/fortran/.libs/intp.o Binary files differnew file mode 100755 index 000000000..028bbab24 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/intp.o diff --git a/modules/elementary_functions/src/fortran/.libs/iset.o b/modules/elementary_functions/src/fortran/.libs/iset.o Binary files differnew file mode 100755 index 000000000..07072fbf8 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/iset.o diff --git a/modules/elementary_functions/src/fortran/.libs/isort.o b/modules/elementary_functions/src/fortran/.libs/isort.o Binary files differnew file mode 100755 index 000000000..349a47511 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/isort.o diff --git a/modules/elementary_functions/src/fortran/.libs/isova0.o b/modules/elementary_functions/src/fortran/.libs/isova0.o Binary files differnew file mode 100755 index 000000000..5cca364ec --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/isova0.o diff --git a/modules/elementary_functions/src/fortran/.libs/isoval.o b/modules/elementary_functions/src/fortran/.libs/isoval.o Binary files differnew file mode 100755 index 000000000..7aab29f17 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/isoval.o diff --git a/modules/elementary_functions/src/fortran/.libs/israt.o b/modules/elementary_functions/src/fortran/.libs/israt.o Binary files differnew file mode 100755 index 000000000..897e7714a --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/israt.o diff --git a/modules/elementary_functions/src/fortran/.libs/ivimp.o b/modules/elementary_functions/src/fortran/.libs/ivimp.o Binary files differnew file mode 100755 index 000000000..e32ee83d6 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/ivimp.o diff --git a/modules/elementary_functions/src/fortran/.libs/iwamax.o b/modules/elementary_functions/src/fortran/.libs/iwamax.o Binary files differnew file mode 100755 index 000000000..c66cc751e --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/iwamax.o diff --git a/modules/elementary_functions/src/fortran/.libs/kronc.o b/modules/elementary_functions/src/fortran/.libs/kronc.o Binary files differnew file mode 100755 index 000000000..a50377019 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/kronc.o diff --git a/modules/elementary_functions/src/fortran/.libs/kronr.o b/modules/elementary_functions/src/fortran/.libs/kronr.o Binary files differnew file mode 100755 index 000000000..458c2a33c --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/kronr.o diff --git a/modules/elementary_functions/src/fortran/.libs/lnblnk.o b/modules/elementary_functions/src/fortran/.libs/lnblnk.o Binary files differnew file mode 100755 index 000000000..cf8470d51 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/lnblnk.o diff --git a/modules/elementary_functions/src/fortran/.libs/magic.o b/modules/elementary_functions/src/fortran/.libs/magic.o Binary files differnew file mode 100755 index 000000000..d7904b1ff --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/magic.o diff --git a/modules/elementary_functions/src/fortran/.libs/mtran.o b/modules/elementary_functions/src/fortran/.libs/mtran.o Binary files differnew file mode 100755 index 000000000..9ba47f89d --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/mtran.o diff --git a/modules/elementary_functions/src/fortran/.libs/nearfloat.o b/modules/elementary_functions/src/fortran/.libs/nearfloat.o Binary files differnew file mode 100755 index 000000000..2a2721c4e --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/nearfloat.o diff --git a/modules/elementary_functions/src/fortran/.libs/orthes.o b/modules/elementary_functions/src/fortran/.libs/orthes.o Binary files differnew file mode 100755 index 000000000..68f5eb66a --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/orthes.o diff --git a/modules/elementary_functions/src/fortran/.libs/ortran.o b/modules/elementary_functions/src/fortran/.libs/ortran.o Binary files differnew file mode 100755 index 000000000..d90cd95e1 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/ortran.o diff --git a/modules/elementary_functions/src/fortran/.libs/pythag.o b/modules/elementary_functions/src/fortran/.libs/pythag.o Binary files differnew file mode 100755 index 000000000..9473a972f --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/pythag.o diff --git a/modules/elementary_functions/src/fortran/.libs/rat.o b/modules/elementary_functions/src/fortran/.libs/rat.o Binary files differnew file mode 100755 index 000000000..9ba086bb8 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/rat.o diff --git a/modules/elementary_functions/src/fortran/.libs/rcopy.o b/modules/elementary_functions/src/fortran/.libs/rcopy.o Binary files differnew file mode 100755 index 000000000..2fe3e6867 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/rcopy.o diff --git a/modules/elementary_functions/src/fortran/.libs/rcsort.o b/modules/elementary_functions/src/fortran/.libs/rcsort.o Binary files differnew file mode 100755 index 000000000..b942b03ec --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/rcsort.o diff --git a/modules/elementary_functions/src/fortran/.libs/round.o b/modules/elementary_functions/src/fortran/.libs/round.o Binary files differnew file mode 100755 index 000000000..8e5ee3856 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/round.o diff --git a/modules/elementary_functions/src/fortran/.libs/simple.o b/modules/elementary_functions/src/fortran/.libs/simple.o Binary files differnew file mode 100755 index 000000000..1dd123ca1 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/simple.o diff --git a/modules/elementary_functions/src/fortran/.libs/split.o b/modules/elementary_functions/src/fortran/.libs/split.o Binary files differnew file mode 100755 index 000000000..92a5f8188 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/split.o diff --git a/modules/elementary_functions/src/fortran/.libs/urand.o b/modules/elementary_functions/src/fortran/.libs/urand.o Binary files differnew file mode 100755 index 000000000..eb0bfd5ac --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/urand.o diff --git a/modules/elementary_functions/src/fortran/.libs/vpythag.o b/modules/elementary_functions/src/fortran/.libs/vpythag.o Binary files differnew file mode 100755 index 000000000..bbf42e092 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/vpythag.o diff --git a/modules/elementary_functions/src/fortran/.libs/wacos.o b/modules/elementary_functions/src/fortran/.libs/wacos.o Binary files differnew file mode 100755 index 000000000..335dac2e9 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wacos.o diff --git a/modules/elementary_functions/src/fortran/.libs/wasin.o b/modules/elementary_functions/src/fortran/.libs/wasin.o Binary files differnew file mode 100755 index 000000000..f8c32bf0d --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wasin.o diff --git a/modules/elementary_functions/src/fortran/.libs/wasum.o b/modules/elementary_functions/src/fortran/.libs/wasum.o Binary files differnew file mode 100755 index 000000000..47b60d0f6 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wasum.o diff --git a/modules/elementary_functions/src/fortran/.libs/watan.o b/modules/elementary_functions/src/fortran/.libs/watan.o Binary files differnew file mode 100755 index 000000000..1a79965ae --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/watan.o diff --git a/modules/elementary_functions/src/fortran/.libs/waxpy.o b/modules/elementary_functions/src/fortran/.libs/waxpy.o Binary files differnew file mode 100755 index 000000000..174109cb8 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/waxpy.o diff --git a/modules/elementary_functions/src/fortran/.libs/wbdiag.o b/modules/elementary_functions/src/fortran/.libs/wbdiag.o Binary files differnew file mode 100755 index 000000000..9b3afc88d --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wbdiag.o diff --git a/modules/elementary_functions/src/fortran/.libs/wcerr.o b/modules/elementary_functions/src/fortran/.libs/wcerr.o Binary files differnew file mode 100755 index 000000000..d6526f834 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wcerr.o diff --git a/modules/elementary_functions/src/fortran/.libs/wclmat.o b/modules/elementary_functions/src/fortran/.libs/wclmat.o Binary files differnew file mode 100755 index 000000000..4e4bf9b35 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wclmat.o diff --git a/modules/elementary_functions/src/fortran/.libs/wddiv.o b/modules/elementary_functions/src/fortran/.libs/wddiv.o Binary files differnew file mode 100755 index 000000000..f49831591 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wddiv.o diff --git a/modules/elementary_functions/src/fortran/.libs/wdiv.o b/modules/elementary_functions/src/fortran/.libs/wdiv.o Binary files differnew file mode 100755 index 000000000..de910c1fc --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wdiv.o diff --git a/modules/elementary_functions/src/fortran/.libs/wdotci.o b/modules/elementary_functions/src/fortran/.libs/wdotci.o Binary files differnew file mode 100755 index 000000000..08ef4178f --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wdotci.o diff --git a/modules/elementary_functions/src/fortran/.libs/wdotcr.o b/modules/elementary_functions/src/fortran/.libs/wdotcr.o Binary files differnew file mode 100755 index 000000000..b5fafdf4f --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wdotcr.o diff --git a/modules/elementary_functions/src/fortran/.libs/wdpow.o b/modules/elementary_functions/src/fortran/.libs/wdpow.o Binary files differnew file mode 100755 index 000000000..50d729c9e --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wdpow.o diff --git a/modules/elementary_functions/src/fortran/.libs/wdpow1.o b/modules/elementary_functions/src/fortran/.libs/wdpow1.o Binary files differnew file mode 100755 index 000000000..dff5c51fd --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wdpow1.o diff --git a/modules/elementary_functions/src/fortran/.libs/wdpowe.o b/modules/elementary_functions/src/fortran/.libs/wdpowe.o Binary files differnew file mode 100755 index 000000000..aabf185e4 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wdpowe.o diff --git a/modules/elementary_functions/src/fortran/.libs/wdrdiv.o b/modules/elementary_functions/src/fortran/.libs/wdrdiv.o Binary files differnew file mode 100755 index 000000000..9ee24a289 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wdrdiv.o diff --git a/modules/elementary_functions/src/fortran/.libs/wexchn.o b/modules/elementary_functions/src/fortran/.libs/wexchn.o Binary files differnew file mode 100755 index 000000000..0244f0468 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wexchn.o diff --git a/modules/elementary_functions/src/fortran/.libs/wexpm1.o b/modules/elementary_functions/src/fortran/.libs/wexpm1.o Binary files differnew file mode 100755 index 000000000..1af5c6978 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wexpm1.o diff --git a/modules/elementary_functions/src/fortran/.libs/wipow.o b/modules/elementary_functions/src/fortran/.libs/wipow.o Binary files differnew file mode 100755 index 000000000..063f6fde8 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wipow.o diff --git a/modules/elementary_functions/src/fortran/.libs/wipowe.o b/modules/elementary_functions/src/fortran/.libs/wipowe.o Binary files differnew file mode 100755 index 000000000..8376d274d --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wipowe.o diff --git a/modules/elementary_functions/src/fortran/.libs/wlog.o b/modules/elementary_functions/src/fortran/.libs/wlog.o Binary files differnew file mode 100755 index 000000000..7ab42ee3f --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wlog.o diff --git a/modules/elementary_functions/src/fortran/.libs/wmmul.o b/modules/elementary_functions/src/fortran/.libs/wmmul.o Binary files differnew file mode 100755 index 000000000..dfbfededc --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wmmul.o diff --git a/modules/elementary_functions/src/fortran/.libs/wmprod.o b/modules/elementary_functions/src/fortran/.libs/wmprod.o Binary files differnew file mode 100755 index 000000000..4fea67e9e --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wmprod.o diff --git a/modules/elementary_functions/src/fortran/.libs/wmsum.o b/modules/elementary_functions/src/fortran/.libs/wmsum.o Binary files differnew file mode 100755 index 000000000..a742a92e3 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wmsum.o diff --git a/modules/elementary_functions/src/fortran/.libs/wmul.o b/modules/elementary_functions/src/fortran/.libs/wmul.o Binary files differnew file mode 100755 index 000000000..42bf48eea --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wmul.o diff --git a/modules/elementary_functions/src/fortran/.libs/wrscal.o b/modules/elementary_functions/src/fortran/.libs/wrscal.o Binary files differnew file mode 100755 index 000000000..d31e48250 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wrscal.o diff --git a/modules/elementary_functions/src/fortran/.libs/wscal.o b/modules/elementary_functions/src/fortran/.libs/wscal.o Binary files differnew file mode 100755 index 000000000..752d66959 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wscal.o diff --git a/modules/elementary_functions/src/fortran/.libs/wshrsl.o b/modules/elementary_functions/src/fortran/.libs/wshrsl.o Binary files differnew file mode 100755 index 000000000..c8920ed0a --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wshrsl.o diff --git a/modules/elementary_functions/src/fortran/.libs/wsign.o b/modules/elementary_functions/src/fortran/.libs/wsign.o Binary files differnew file mode 100755 index 000000000..bdadd9e8e --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wsign.o diff --git a/modules/elementary_functions/src/fortran/.libs/wsqrt.o b/modules/elementary_functions/src/fortran/.libs/wsqrt.o Binary files differnew file mode 100755 index 000000000..858e63980 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wsqrt.o diff --git a/modules/elementary_functions/src/fortran/.libs/wswap.o b/modules/elementary_functions/src/fortran/.libs/wswap.o Binary files differnew file mode 100755 index 000000000..0df244788 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wswap.o diff --git a/modules/elementary_functions/src/fortran/.libs/wtan.o b/modules/elementary_functions/src/fortran/.libs/wtan.o Binary files differnew file mode 100755 index 000000000..f60a3bc8f --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wtan.o diff --git a/modules/elementary_functions/src/fortran/.libs/wvmul.o b/modules/elementary_functions/src/fortran/.libs/wvmul.o Binary files differnew file mode 100755 index 000000000..46952931a --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wvmul.o diff --git a/modules/elementary_functions/src/fortran/.libs/wwdiv.o b/modules/elementary_functions/src/fortran/.libs/wwdiv.o Binary files differnew file mode 100755 index 000000000..fc157262b --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wwdiv.o diff --git a/modules/elementary_functions/src/fortran/.libs/wwpow.o b/modules/elementary_functions/src/fortran/.libs/wwpow.o Binary files differnew file mode 100755 index 000000000..ea348b97d --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wwpow.o diff --git a/modules/elementary_functions/src/fortran/.libs/wwpow1.o b/modules/elementary_functions/src/fortran/.libs/wwpow1.o Binary files differnew file mode 100755 index 000000000..da05a9551 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wwpow1.o diff --git a/modules/elementary_functions/src/fortran/.libs/wwpowe.o b/modules/elementary_functions/src/fortran/.libs/wwpowe.o Binary files differnew file mode 100755 index 000000000..9a7369831 --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wwpowe.o diff --git a/modules/elementary_functions/src/fortran/.libs/wwrdiv.o b/modules/elementary_functions/src/fortran/.libs/wwrdiv.o Binary files differnew file mode 100755 index 000000000..1bd9262be --- /dev/null +++ b/modules/elementary_functions/src/fortran/.libs/wwrdiv.o diff --git a/modules/elementary_functions/src/fortran/Core_f_Import.def b/modules/elementary_functions/src/fortran/Core_f_Import.def new file mode 100755 index 000000000..c75b19487 --- /dev/null +++ b/modules/elementary_functions/src/fortran/Core_f_Import.def @@ -0,0 +1,13 @@ + LIBRARY core_f.dll + + +EXPORTS +; +;core_f +; +allops_ +createref_ +funnam_ +ref2val_ +setfunnam_ +putfunnam_ diff --git a/modules/elementary_functions/src/fortran/Integer_Import.def b/modules/elementary_functions/src/fortran/Integer_Import.def new file mode 100755 index 000000000..d84c8c20e --- /dev/null +++ b/modules/elementary_functions/src/fortran/Integer_Import.def @@ -0,0 +1,5 @@ +LIBRARY integer.dll + + +EXPORTS +tpconv_
\ No newline at end of file diff --git a/modules/elementary_functions/src/fortran/Output_stream_Import.def b/modules/elementary_functions/src/fortran/Output_stream_Import.def new file mode 100755 index 000000000..1ca28750c --- /dev/null +++ b/modules/elementary_functions/src/fortran/Output_stream_Import.def @@ -0,0 +1,7 @@ +LIBRARY output_stream.dll + + +EXPORTS +msgs_ +error_ +basout_ diff --git a/modules/elementary_functions/src/fortran/String_Import.def b/modules/elementary_functions/src/fortran/String_Import.def new file mode 100755 index 000000000..0f0e14f33 --- /dev/null +++ b/modules/elementary_functions/src/fortran/String_Import.def @@ -0,0 +1,6 @@ +LIBRARY string.dll + + +EXPORTS +cvstr_ +codetoascii_
\ No newline at end of file diff --git a/modules/elementary_functions/src/fortran/arcosh.f b/modules/elementary_functions/src/fortran/arcosh.f new file mode 100755 index 000000000..e508c6af9 --- /dev/null +++ b/modules/elementary_functions/src/fortran/arcosh.f @@ -0,0 +1,35 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + double precision function arcosh(x) +c!but +c calcule l'arcosinus hyperbolique d'un double precision +c!liste d'appel +c double precision function arcosh(x) +c double precision x +c + double precision x + if (x.lt.1.0d+0) go to 10 + arcosh = log(x+sqrt(x*x-1.0d+0)) + return +10 arcosh = 0.0d+0 + return + end + double precision function arsinh(x) +c!but +c calcule l'arcsinus hyperbolique d'un double precision +c!liste d'appel +c double precision function arsinh(x) +c double precision x +c! + double precision x +c + arsinh = log(x+sqrt(x*x+1.0d+0)) + return + end diff --git a/modules/elementary_functions/src/fortran/arcosh.lo b/modules/elementary_functions/src/fortran/arcosh.lo new file mode 100755 index 000000000..ac1986f30 --- /dev/null +++ b/modules/elementary_functions/src/fortran/arcosh.lo @@ -0,0 +1,12 @@ +# src/fortran/arcosh.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/arcosh.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/bdiag.f b/modules/elementary_functions/src/fortran/bdiag.f new file mode 100755 index 000000000..7dde9513f --- /dev/null +++ b/modules/elementary_functions/src/fortran/bdiag.f @@ -0,0 +1,511 @@ + subroutine bdiag(lda,n,a,epsshr,rmax,er,ei,bs,x,xi,scale, + 1 job,fail) +c +c!purpose +c dbdiag reduces a matrix a to block diagonal form by first +c reducing it to quasi-triangular form by hqror2 and then by +c solving the matrix equation -a11*p+p*a22=a12 to introduce zeros +c above the diagonal. +c right transformation is factored : p*d*u*y ;where: +c p is a permutation matrix and d positive diagonal matrix +c u is orthogonal and y block upper triangular with identity +c blocks on the diagonal +c +c!calling sequence +c +c subroutine bdiag(lda,n,a,epsshr,rmax,er,ei,bs,x,xi,scale, +c * job,fail) +c +c integer lda, n, bs, job +c double precision a,er,ei,x,xi,rmax,epsshr,scale +c dimension a(lda,n),x(lda,n),xi(lda,n),er(n),ei(n),bs(n) +c dimension scale(n) +c logical fail +c +c starred parameters are altered by the subroutine +c +c +c *a an array that initially contains the m x n matrix +c to be reduced. on return, see job +c +c lda the leading dimension of array a. and array x,xi. +c +c n the order of the matrices a,x,xi +c +c epsshr the minimal conditionnement allowed for linear sytems +c +c rmax the maximum size allowed for any element of the +c transformations. +c +c *er a singly subscripted real array containing the real +c parts of the eigenvalues. +c +c *ei a singly subscripted real array containg the imaginary +c parts of the eigenvalues. +c +c *bs a singly subscripted integer array that contains block +c structure information. if there is a block of order +c k starting at a(l,l) in the output matrix a, then +c bs(l) contains the positive integer k, bs(l+1) contains +c -(k-1), bs(la+2) = -(k-2), ..., bs(l+k-1) = -1. +c thus a positive integer in the l-th entry of bs +c indicates a new block of order bs(l) starting at a(l,l). +c +c *x contains, either right reducing transformation u*y, +c either orthogonal tranformation u (see job) +c +c *xi xi contains the inverse reducing matrix transformation +c or y matrix (see job) +c +c *scale contains the scale factor and definitions of p size(n) +c +c job integer parametre specifying outputed transformations +c job=0 : a contains block diagonal form +c x right transformation +c xi dummy variable +c job=1:like job=0 and xi contain x**-1 +c job=2 a contains block diagonal form +c x contains u and xi contain y +c job=3: a contains: +c -block diagonal form in the diagonal blocks +c -a factorization of y in the upper triangular +c x contains u +c xi dummy +c *fail a logical variable which is false on normal return and +c true if there is any error in bdiag. +c +c +c!auxiliary routines +c orthes ortran (eispack) +c hqror2 exch split (eispack.extensions) +c dset ddot (blas) +c real dble abs (fortran) +c shrslv dad +c +c! +c + integer lda, n, bs, job + double precision a,er,ei,x,xi,rmax,epsshr,scale(n) + dimension a(lda,n),x(lda,n),xi(lda,n),er(n),ei(n),bs(n) + logical fail,fails +c + double precision c,cav,d,e1,e2,rav,temp,zero,one,mone,ddot,eps + double precision dlamch + integer da11,da22,i,j,k,km1,km2,l11,l22,l22m1,nk,ino + integer low,igh + data zero, one, mone /0.0d+0,1.0d+0,-1.0d+0/ +c +c + fail = .false. + fails= .true. + ino = -1 +c +c compute eps the l1 norm of the a matrix +c + eps=0.0d0 + do 11 j=1,n + temp=0.0d0 + do 10 i=1,n + temp=temp+abs(a(i,j)) + 10 continue + eps=max(eps,temp) + 11 continue + if (eps.eq.0.0d0) eps=1.0d0 + eps=dlamch('p')*eps + + +c +c convert a to upper hessenberg form. +c + call balanc(lda, n, a, low, igh, scale) + call orthes(lda, n, low, igh, a, er) + call ortran(lda, n, low, igh, a, er, x) +c +c convert a to quasi-upper triangular form by qr method. +c + call hqror2(lda,n,1,n,a,er,ei,x,ierr,21) +c +c check to see if hqror2 failed in computing any eigenvalue +c +c + if(ierr.gt.1) goto 600 +c +c reduce a to block diagonal form +c +c +c segment a into 4 matrices: a11, a da11 x da11 block +c whose (1,1)-element is at a(l11,l11)) a22, a da22 x da22 +c block whose (1,1)-element is at a(l22,l22)) a12, +c a da11 x da22 block whose (1,1)-element is at a(l11,l22)) +c and a21, a da22 x da11 block = 0 whose (1,1)- +c element is at a(l22,l11). +c +c +c +c this loop uses l11 as loop index and splits off a block +c starting at a(l11,l11). +c +c + l11 = 1 + 40 continue + if (l11.gt.n) go to 350 + l22 = l11 +c +c this loop uses da11 as loop variable and attempts to split +c off a block of size da11 starting at a(l11,l11) +c + 50 continue + if (l22.ne.l11) go to 60 + da11 = 1 + if(l11 .eq. n) go to 51 + if(abs(a(l11+1,l11)) .gt.eps ) then + da11 = 2 + endif + 51 continue + l22 = l11 + da11 + l22m1 = l22 - 1 + go to 240 + 60 continue +c +c +c compute the average of the eigenvalues in a11 +c + rav = zero + cav = zero + do 70 i=l11,l22m1 + rav = rav + er(i) + cav = cav + abs(ei(i)) + 70 continue + rav = rav/dble(real(da11) ) + cav = cav/dble(real(da11) ) +c +c loop on eigenvalues of a22 to find the one closest to the av +c + d = (rav-er(l22))**2 + (cav-ei(l22))**2 + k = l22 + l = l22 + 1 + if(l22 .eq. n) go to 71 + if(abs(a(l22+1,l22)) .gt. eps) l = l22 + 2 + 71 continue + 80 continue + if (l.gt.n) go to 100 + c = (rav-er(l))**2 + (cav-ei(l))**2 + if (c.ge.d) go to 90 + k = l + d = c + 90 continue + l = l + 1 + if(l.gt.n) go to 100 + if (abs(a(l,l-1)).gt.eps) l=l+1 + go to 80 + 100 continue +c +c +c loop to move the eigenvalue just located +c into first position of block a22. +c + if (k.eq.n) goto 105 + if (abs(a(k+1,k)).gt.eps) go to 150 +c +c the block we're moving to add to a11 is a 1 x 1 +c + 105 nk = 1 + 110 continue + if (k.eq.l22) go to 230 + km1 = k - 1 + if (abs(a(km1,k-2)).lt.eps) go to 140 +c +c we're swapping the closest block with a 2 x 2 +c + km2 = k - 2 + call exch(lda,n,a, x, km2, 2, 1) +c +c try to split this block into 2 real eigenvalues +c + call split(a, x, n, km1, e1, e2, lda, lda) + if (a(k,km1).eq.zero) go to 120 +c +c block is still complex. +c + er(km2) = er(k) + ei(km2) = zero + er(k) = e1 + er(km1) = e1 + ei(km1) = e2 + ei(k) = -e2 + go to 130 +c +c complex block split into two real eigenvalues. +c + 120 continue + er(km2) = er(k) + er(km1) = e1 + er(k) = e2 + ei(km2) = zero + ei(km1) = zero + 130 k = km2 + if (k.le.l22) go to 230 + go to 110 +c +c +c we're swapping the closest block with a 1 x 1. +c + 140 continue + call exch(lda,n,a, x, km1, 1, 1) + temp = er(k) + er(k) = er(km1) + er(km1) = temp + k = km1 + if (k.le.l22) go to 230 + go to 110 +c +c the block we're moving to add to a11 is a 2 x 2. +c + 150 continue + nk = 2 + 160 continue + if (k.eq.l22) go to 230 + km1 = k - 1 + if (abs(a(km1,k-2)).lt.eps) goto 190 +c +c we're swapping the closest block with a 2 x 2 block. +c + km2 = k - 2 + call exch(lda,n,a, x, km2, 2, 2) +c +c try to split swapped block into two reals. +c + call split(a, x, n, k, e1, e2, lda, lda) + er(km2) = er(k) + er(km1) = er(k+1) + ei(km2) = ei(k) + ei(km1) = ei(k+1) + if (a(k+1,k).eq.zero) go to 170 +c +c still complex block. +c + er(k) = e1 + er(k+1) = e1 + ei(k) = e2 + ei(k+1) = -e2 + go to 180 +c +c two real roots. +c + 170 continue + er(k) = e1 + er(k+1) = e2 + ei(k) = zero + ei(k+1) = zero + 180 continue + k = km2 + if (k.eq.l22) go to 210 + go to 160 +c +c we're swapping the closest block with a 1 x 1. +c + 190 continue + call exch(lda,n,a, x, km1, 1, 2) + er(k+1) = er(km1) + er(km1) = er(k) + ei(km1) = ei(k) + ei(k) = ei(k+1) + ei(k+1) = zero + go to 200 +c + 200 continue + k = km1 + if (k.eq.l22) go to 210 + go to 160 +c +c try to split relocated complex block. +c + 210 continue + call split(a, x, n, k, e1, e2, lda, lda) + if (a(k+1,k).eq.zero) go to 220 +c +c still complex. +c + er(k) = e1 + er(k+1) = e1 + ei(k) = e2 + ei(k+1) = -e2 + go to 230 +c +c split into two real eigenvalues. +c + 220 continue + er(k) = e1 + er(k+1) = e2 + ei(k) = zero + ei(k+1) = zero +c + 230 continue + da11 = da11 + nk + l22 = l11 + da11 + l22m1 = l22 - 1 + 240 continue + if (l22.gt.n) go to 290 +c +c attempt to split off a block of size da11. +c + da22 = n - l22 + 1 +c +c save a12 in its transpose form in block a21. +c + do 260 j=l11,l22m1 + do 250 i=l22,n + a(i,j) = a(j,i) + 250 continue + 260 continue +c +c +c convert a11 to lower quasi-triangular and multiply it by -1 and +c a12 appropriately (for solving -a11*p+p*a22=a12). +c + call dad(a, lda, l11, l22m1, l11, n, one, 0) + call dad(a, lda, l11, l22m1, l11, l22m1, mone, 1) +c +c solve -a11*p + p*a22 = a12. +c + call shrslv(a(l11,l11), a(l22,l22), a(l11,l22), da11, + * da22, lda, lda, lda, eps,epsshr,rmax, fails) + if (.not.fails) go to 290 +c +c change a11 back to upper quasi-triangular. +c + call dad(a, lda, l11, l22m1, l11, l22m1, one, 1) + call dad(a, lda, l11, l22m1, l11, l22m1, mone, 0) +c +c was unable to solve for p - try again +c +c +c move saved a12 back into its correct position. +c + do 280 j=l11,l22m1 + do 270 i=l22,n + a(j,i) = a(i,j) + a(i,j) = zero + 270 continue + 280 continue +c +c + go to 50 + 290 continue +c +c change solution to p to proper form. +c + if (l22.gt.n) go to 300 + call dad(a, lda, l11, l22m1, l11, n, one, 0) + call dad(a, lda, l11, l22m1, l11, l22m1, mone, 1) + +c +c store block size in array bs. +c + 300 bs(l11) = da11 + j = da11 - 1 + if (j.eq.0) go to 320 + do 310 i=1,j + l11pi = l11 + i + bs(l11pi) = -(da11-i) + 310 continue + 320 continue + l11 = l22 + go to 40 + 350 continue + fail=.false. +c +c set transformations matrices as required +c + if(job.eq.3) return +c +c compute inverse transformation + if(job.ne.1) goto 450 + do 410 i=1,n + do 410 j=1,n + xi(i,j)=x(j,i) + 410 continue + l22=1 + 420 l11=l22 + l22=l11+bs(l11) + if(l22.gt.n) goto 431 + l22m1=l22-1 + do 430 i=l11,l22m1 + do 430 j=1,n + xi(i,j)=xi(i,j)-ddot(n-l22m1,a(i,l22),lda,xi(l22,j),1) + 430 continue + goto 420 +c in-lines back-tranfc in-lines right transformations of xi + 431 continue + if (igh .ne. low) then + do 435 j=low,igh + temp=1.0d+00/scale(j) + do 434 i=1,n + xi(i,j)=xi(i,j)*temp + 434 continue + 435 continue + endif + do 445 ii=1,n + i=ii + if (i.ge.low .and. i.le.igh) goto 445 + if (i.lt.low) i=low-ii + k=scale(i) + if (k.eq.i) goto 445 + do 444 j=1,n + temp=xi(j,i) + xi(j,i)=xi(j,k) + xi(j,k)=temp + 444 continue + 445 continue +c + 450 continue + if(job.eq.2) goto 500 +c compute right transformation + l22=1 + 460 l11=l22 + l22=l11+bs(l11) + if(l22.gt.n) goto 480 + do 470 j=l22,n + do 470 i=1,n + x(i,j)=x(i,j)+ddot(l22-l11,x(i,l11),lda,a(l11,j),1) + 470 continue + goto 460 +c + 480 continue + call balbak( lda, n, low, igh, scale, n, x) + goto 550 +c +c extract non orthogonal tranformation from a + 500 continue + do 510 j=1,n + call dset(n,zero,xi(1,j),1) + 510 continue + call dset(n,one,xi(1,1),lda+1) + l22=1 + 520 l11=l22 + if(l11.gt.n) goto 550 + l22=l11+bs(l11) + do 530 j=l22,n + do 530 i=1,n + xi(i,j)=xi(i,j)+ddot(l22-l11,xi(i,l11),lda,a(l11,j),1) + 530 continue + goto 520 +c +c set zeros in the matrix a + 550 l11=1 + 560 l22=l11+bs(l11) + if(l22.gt.n) return + l22m1=l22-1 + do 570 j=l11,l22m1 + call dset(n-l22m1,zero,a(j,l22),lda) + call dset(n-l22m1,zero,a(l22,j),1) + 570 continue + l11=l22 + goto 560 +c +c error return. +c + 600 continue + fail = .true. +c + end diff --git a/modules/elementary_functions/src/fortran/bdiag.lo b/modules/elementary_functions/src/fortran/bdiag.lo new file mode 100755 index 000000000..8fda324f7 --- /dev/null +++ b/modules/elementary_functions/src/fortran/bdiag.lo @@ -0,0 +1,12 @@ +# src/fortran/bdiag.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/bdiag.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/cacsd_f_Import.def b/modules/elementary_functions/src/fortran/cacsd_f_Import.def new file mode 100755 index 000000000..6616de054 --- /dev/null +++ b/modules/elementary_functions/src/fortran/cacsd_f_Import.def @@ -0,0 +1,6 @@ +LIBRARY cacsd_f.dll + + +EXPORTS +giv_ +shrslv_ diff --git a/modules/elementary_functions/src/fortran/cbal.f b/modules/elementary_functions/src/fortran/cbal.f new file mode 100755 index 000000000..c70bfa899 --- /dev/null +++ b/modules/elementary_functions/src/fortran/cbal.f @@ -0,0 +1,203 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + subroutine cbal(nm,n,ar,ai,low,igh,scale) +c + integer i,j,k,l,m,n,jj,nm,igh,low,iexc + double precision ar(nm,n),ai(nm,n),scale(n) + double precision c,f,g,r,s,b2,radix + logical noconv +c +c!purpose +c +c this subroutine balances a complex matrix and isolates +c eigenvalues whenever possible. +c +c!calling sequence +c subroutine cbal(nm,n,ar,ai,low,igh,scale) +c +c integer n,nm,igh,low +c double precision ar(nm,n),ai(nm,n),scale(n) +c logical noconv +c +c on input: +c +c nm must be set to the row dimension of two-dimensional +c array parameters as declared in the calling program +c dimension statement; +c +c n is the order of the matrix; +c +c ar and ai contain the real and imaginary parts, +c respectively, of the complex matrix to be balanced. +c +c on output: +c +c ar and ai contain the real and imaginary parts, +c respectively, of the balanced matrix; +c +c low and igh are two integers such that ar(i,j) and ai(i,j) +c are equal to zero if +c (1) i is greater than j and +c (2) j=1,...,low-1 or i=igh+1,...,n; +c +c scale contains information determining the +c permutations and scaling factors used. +c +c suppose that the principal submatrix in rows low through igh +c has been balanced, that p(j) denotes the index interchanged +c with j during the permutation step, and that the elements +c of the diagonal matrix used are denoted by d(i,j). then +c scale(j) = p(j), for j = 1,...,low-1 +c = d(j,j) j = low,...,igh +c = p(j) j = igh+1,...,n. +c the order in which the interchanges are made is n to igh+1, +c then 1 to low-1. +c +c note that 1 is returned for igh if igh is zero formally. +c +c the algol procedure exc contained in cbalance appears in +c cbal in line. (note that the algol roles of identifiers +c k,l have been reversed.) +c +c arithmetic is real throughout. +c +c!originator +c this subroutine is a translation of the algol procedure +c cbalance, which is a complex version of balance, +c num. math. 13, 293-304(1969) by parlett and reinsch. +c handbook for auto. comp., vol.ii-linear algebra, 315-326(1971). +c questions and comments should be directed to b. s. garbow, +c applied mathematics division, argonne national laboratory +c +c! +c ------------------------------------------------------------------ +c +c :::::::::: radix is a machine dependent parameter specifying +c the base of the machine floating point representation. +c radix = 16.0d+0 for long form arithmetic +c on s360 :::::::::: + data radix/2.0d+0/ +c + b2 = radix * radix + k = 1 + l = n + go to 100 +c :::::::::: in-line procedure for row and +c column exchange :::::::::: + 20 scale(m) = j + if (j .eq. m) go to 50 +c + do 30 i = 1, l + f = ar(i,j) + ar(i,j) = ar(i,m) + ar(i,m) = f + f = ai(i,j) + ai(i,j) = ai(i,m) + ai(i,m) = f + 30 continue +c + do 40 i = k, n + f = ar(j,i) + ar(j,i) = ar(m,i) + ar(m,i) = f + f = ai(j,i) + ai(j,i) = ai(m,i) + ai(m,i) = f + 40 continue +c + 50 go to (80,130), iexc +c :::::::::: search for rows isolating an eigenvalue +c and push them down :::::::::: + 80 if (l .eq. 1) go to 280 + l = l - 1 +c :::::::::: for j=l step -1 until 1 do -- :::::::::: + 100 do 120 jj = 1, l + j = l + 1 - jj +c + do 110 i = 1, l + if (i .eq. j) go to 110 + if (ar(j,i) .ne. 0.0d+0 .or. ai(j,i) .ne. 0.0d+0) go to 120 + 110 continue +c + m = l + iexc = 1 + go to 20 + 120 continue +c + go to 140 +c :::::::::: search for columns isolating an eigenvalue +c and push them left :::::::::: + 130 k = k + 1 +c + 140 do 170 j = k, l +c + do 150 i = k, l + if (i .eq. j) go to 150 + if (ar(i,j) .ne. 0.0d+0 .or. ai(i,j) .ne. 0.0d+0) go to 170 + 150 continue +c + m = k + iexc = 2 + go to 20 + 170 continue +c :::::::::: now balance the submatrix in rows k to l :::::::::: + do 180 i = k, l + 180 scale(i) = 1.0d+0 +c :::::::::: iterative loop for norm reduction :::::::::: + 190 noconv = .false. +c + do 270 i = k, l + c = 0.0d+0 + r = 0.0d+0 +c + do 200 j = k, l + if (j .eq. i) go to 200 + c = c + abs(ar(j,i)) + abs(ai(j,i)) + r = r + abs(ar(i,j)) + abs(ai(i,j)) + 200 continue +c :::::::::: guard against zero c or r due to underflow :::::::::: + if (c .eq. 0.0d+0 .or. r .eq. 0.0d+0) go to 270 + g = r / radix + f = 1.0d+0 + s = c + r + 210 if (c .ge. g) go to 220 + f = f * radix + c = c * b2 + go to 210 + 220 g = r * radix + 230 if (c .lt. g) go to 240 + f = f / radix + c = c / b2 + go to 230 +c :::::::::: now balance :::::::::: + 240 if ((c + r) / f .ge. 0.950d+0 * s) go to 270 + g = 1.0d+0 / f + scale(i) = scale(i) * f + noconv = .true. +c + do 250 j = k, n + ar(i,j) = ar(i,j) * g + ai(i,j) = ai(i,j) * g + 250 continue +c + do 260 j = 1, l + ar(j,i) = ar(j,i) * f + ai(j,i) = ai(j,i) * f + 260 continue +c + 270 continue +c + if (noconv) go to 190 +c + 280 low = k + igh = l + return +c :::::::::: last card of cbal :::::::::: + end diff --git a/modules/elementary_functions/src/fortran/cbal.lo b/modules/elementary_functions/src/fortran/cbal.lo new file mode 100755 index 000000000..3f20096fa --- /dev/null +++ b/modules/elementary_functions/src/fortran/cbal.lo @@ -0,0 +1,12 @@ +# src/fortran/cbal.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/cbal.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/cerr.f b/modules/elementary_functions/src/fortran/cerr.f new file mode 100755 index 000000000..9481bb9d7 --- /dev/null +++ b/modules/elementary_functions/src/fortran/cerr.f @@ -0,0 +1,107 @@ + subroutine cerr(a,w,ia,n,ndng,m,maxc) +c!purpose +c cerr evaluate the error introduced by pade +c approximant and normalise the matrix a accordingly +c!calling sequence +c +c subroutine cerr(a,w,ia,n,ndng,m,maxc) +c +c a : array containing the matrix a +c +c w : work space array of size 2*n*n + n +c +c ia : leading dimension of array a +c +c n : size of matrix a +c +c ndng : degree of pade approximant +c +c m : the factor of normalization is 2**(-m) +c +c maxc : maximum admissible for m +c +c!auxiliary routines +c dmmul dmcopy gdcp2i (blas.extension) +c dset dcopy ddot (blas) +c abs real dble (fortran) +c! +c + integer ia,n,ndng,m,maxc + double precision a,w + dimension a(ia,n),w(*) +c +c internal variables + integer k,mm,i,j,mt + double precision norm,alpha,zero,two,norm1,one,ddot + logical itab(15) +c + data zero, one, two /0.0d+0,1.0d+0,2.0d+0/ +c +c + norm=0.0d+0 + n2=n*n + k1=1 + ke=k1+n2 + kw=ke+n2 + k = 2*ndng + call dmmul(a,ia,a,ia,w(ke),n,n,n,n) + call gdcp2i(k, itab, mt) + if (.not.itab(1)) go to 30 + norm = zero + do 20 i=1,n + alpha = zero + do 10 j=1,n + alpha = alpha + abs(a(i,j)) + 10 continue + if (alpha.gt.norm) norm = alpha + 20 continue + call dmcopy(a,ia,w(k1),n,n,n) + go to 40 + 30 call dset(n2,0.0d+0,w(k1),1) + call dset(n,1.0d+0,w(k1),n+1) + 40 if (mt.eq.1) go to 110 + do 100 i1=2,mt + do 70 j=1,n + l = 0 + do 50 i=1,n + w(kw-1+i) = ddot(n,w(k1-1+j),n,w(ke+l),1) + l = l + n + 50 continue + call dcopy(n,w(kw),1,w(k1-1+j),n) + 70 continue + if (.not.itab(i1)) go to 100 + norm1 = zero + do 90 i=1,n + alpha = zero + l = i - 1 + do 80 j=1,n + alpha = alpha + abs(w(k1+l)) + l = l + n + 80 continue + if (alpha.gt.norm1) norm1 = alpha + 90 continue + norm = norm*norm1 + 100 continue + 110 continue + norm = norm/dble(real(k+1)) + do 120 i=1,ndng + norm = norm/dble(real((k-i+1)**2)) + 120 continue + norm = 8.0d+0*norm + mm = 0 + 130 if (norm+one .le. one) go to 140 + mm = mm + 1 + alpha = two**mm + norm = norm/alpha + if ((mm+m).gt.maxc) go to 140 + go to 130 + 140 continue + alpha = (two**mm) + do 160 i=1,n + do 150 j=1,n + a(i,j) = a(i,j)/alpha + 150 continue + 160 continue + m = m + mm + return + end diff --git a/modules/elementary_functions/src/fortran/cerr.lo b/modules/elementary_functions/src/fortran/cerr.lo new file mode 100755 index 000000000..d10b8bcb1 --- /dev/null +++ b/modules/elementary_functions/src/fortran/cerr.lo @@ -0,0 +1,12 @@ +# src/fortran/cerr.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/cerr.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/coef.f b/modules/elementary_functions/src/fortran/coef.f new file mode 100755 index 000000000..184333a72 --- /dev/null +++ b/modules/elementary_functions/src/fortran/coef.f @@ -0,0 +1,115 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) Bruno Pincon +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + subroutine coef(ierr) +c!purpose +c coef compute the lengh,and the coefficients of the +c exponential pade approximant +c +c!calling sequence +c subroutine coef(ierr) +c common /dcoeff/ b,n +c +c double precision b(41) +c integer n,ierr +c ierr error indicator : if ierr.ne.0 n is too large +c machine precision can't be achieved +c +c b array containing pade coefficients +c +c n lengh of pade approximation +c +c!auxiliary routines +c exp dble real mod (fortran) +c!originator +c j.roche - laboratoire d'automatique de grenoble +c! + double precision b(41) + integer n,ierr +c internal variables + integer m, i, ir, id, ie, j, j1, n1, im1, ip1, k + double precision a, b1, b2, b3, zero, one, two, cnst, half + dimension a(41), m(21) +cDEC$ IF DEFINED (FORDLL) +cDEC$ ATTRIBUTES DLLIMPORT:: /dcoeff/ +cDEC$ ENDIF + common /dcoeff/ b, n + data zero, one, two, cnst, half /0.0d+0,1.0d+0,2.0d+0, + * 0.556930d+0,0.50d+0/ +c + ierr=0 +c +c determination of the pade approximants type +c + n = 1 + b1 = exp(one) + b3 = 6. + b2 = b1/(b3*(cnst-one)) + b2 = abs(b2) + 10 if (b2+one.le.one) go to 20 + n = n + 1 + b3 = b3*(4.0d+0*dble(real(n))+two) + b2 = b1/(b3*((dble(real(n))*cnst-one)**n)) + go to 10 + 20 continue + if(n.gt.40) ierr=n + n=min(n,40) +c +c compute the coefficients of pade approximants +c + n1 = n + 1 + n2 = (n+2)/2 + a(1) = one + a(2) = half + do 30 i=2,n + im1 = i - 1 + ip1 = i + 1 + a(ip1) = a(i)*dble(real(n-im1))/dble(real(i*(2*n-im1) + * )) + 30 continue +c +c compute the coefficients of pade approximants in chebychef system +c + do 40 i=1,n2 + m(i) = 0 + 40 continue + do 50 i=1,n1 + b(i) = zero + 50 continue + m(1) = 1 + b(1) = a(1) + b(2) = a(2) + i = 0 + b3 = one + 60 i = i + 1 + b3 = b3*half + ir = mod(i,2) + id = (i+3)/2 + ie = id + if (ir .eq. 0) then + goto 70 + else + goto 80 + endif + 70 m(id) = m(id) + m(id) + 80 m(id) = m(id) + m(id-1) + id = id - 1 + if ((id-1) .eq. 0) goto 90 + goto 80 + 90 j = i + 2 + j1 = j + do 100 k=1,ie + b2 = m(k) + b1 = a(j1)*b2*b3 + b(j) = b(j) + b1 + j = j - 2 + 100 continue + if (n1-i.ne.2) go to 60 + return + end diff --git a/modules/elementary_functions/src/fortran/coef.lo b/modules/elementary_functions/src/fortran/coef.lo new file mode 100755 index 000000000..a677f888b --- /dev/null +++ b/modules/elementary_functions/src/fortran/coef.lo @@ -0,0 +1,12 @@ +# src/fortran/coef.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/coef.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/comqr3.f b/modules/elementary_functions/src/fortran/comqr3.f new file mode 100755 index 000000000..db2511aa2 --- /dev/null +++ b/modules/elementary_functions/src/fortran/comqr3.f @@ -0,0 +1,300 @@ + subroutine comqr3(nm,n,low,igh,hr,hi,wr,wi,zr,zi,ierr,job) +c + integer i,j,l,n,en,ll,nm,igh,ip1, + x itn,its,low,lp1,enm1,iend,ierr + double precision hr(nm,n),hi(nm,n),wr(n),wi(n),zr(nm,n),zi(nm,n) + double precision si,sr,ti,tr,xi,xr,yi,yr,zzi,zzr,norm + double precision pythag +c +c!originator +c this subroutine is a translation of a unitary analogue of the +c algol procedure comlr2, num. math. 16, 181-204(1970) by peters +c and wilkinson. +c handbook for auto. comp., vol.ii-linear algebra, 372-395(1971). +c the unitary analogue substitutes the qr algorithm of francis +c (comp. jour. 4, 332-345(1962)) for the lr algorithm. +c +c modified by c. moler +c!purpose +c this subroutine finds the eigenvalues of a complex upper +c hessenberg matrix by the qr method. The unitary transformation +c can also be accumulated if corth has been used to reduce +c this general matrix to hessenberg form. +c +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c MODIFICATION OF EISPACK COMQR+COMQR2 +c 1. job parameter added +c 2. code concerning eigenvector computation deleted +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c +c!calling sequence +c subroutine comqr3(nm,n,low,igh,hr,hi,wr,wi,zr,zi,ierr +c * ,job) +c +c on input. +c +c nm must be set to the row dimension of two-dimensional +c array parameters as declared in the calling program +c dimension statement. +c +c n is the order of the matrix. +c +c low and igh are integers determined by the balancing +c subroutine cbal. if cbal has not been used, +c set low=1, igh=n. +c +c hr and hi contain the real and imaginary parts, +c respectively, of the complex upper hessenberg matrix. +c their lower triangles below the subdiagonal contain further +c information about the transformations which were used in the +c reduction by corth, if performed. +c +c zr and zi contain the real and imaginary parts,respectively +c of the unitary similarity used to put h on hessenberg form +c or a unitary matrix ,if vectors are desired +c +c job indicate the job to be performed: job=xy +c if y=0 no accumulation of the unitary transformation +c if y=1 transformation accumulated in z +c +c on output. +c the upper hessenberg portions of hr and hi have been destroyed +c +c +c wr and wi contain the real and imaginary parts, +c respectively, of the eigenvalues. if an error +c exit is made, the eigenvalues should be correct +c for indices ierr+1,...,n. +c +c zr and zi contain the real and imaginary parts, +c respectively, of the eigenvectors. the eigenvectors +c are unnormalized. if an error exit is made, none of +c the eigenvectors has been found. +c +c ierr is set to +c zero for normal return, +c j if the j-th eigenvalue has not been +c determined after a total of 30*n iterations. + +c +c questions and comments should be directed to b. s. garbow, +c applied mathematics division, argonne national laboratory +c +c!auxiliary routines +c pythag +c! +c ------------------------------------------------------------------ +c + ierr = 0 +c***** + jx=job/10 + jy=job-10*jx +c +c .......... create real subdiagonal elements .......... + iend=igh-low-1 + if(iend.lt.0) goto 180 + 150 l = low + 1 +c + do 170 i = l, igh + ll = min(i+1,igh) + if (hi(i,i-1) .eq. 0.0d+0) go to 170 + norm = pythag(hr(i,i-1),hi(i,i-1)) + yr = hr(i,i-1)/norm + yi = hi(i,i-1)/norm + hr(i,i-1) = norm + hi(i,i-1) = 0.0d+0 +c + do 155 j = i, n + si = yr*hi(i,j) - yi*hr(i,j) + hr(i,j) = yr*hr(i,j) + yi*hi(i,j) + hi(i,j) = si + 155 continue +c + do 160 j = 1, ll + si = yr*hi(j,i) + yi*hr(j,i) + hr(j,i) = yr*hr(j,i) - yi*hi(j,i) + hi(j,i) = si + 160 continue +c***** + if (jy .eq. 0) go to 170 +c***** + do 165 j = low, igh + si = yr*zi(j,i) + yi*zr(j,i) + zr(j,i) = yr*zr(j,i) - yi*zi(j,i) + zi(j,i) = si + 165 continue +c + 170 continue +c .......... store roots isolated by cbal .......... +c + 180 do 200 i = 1, n + if (i .ge. low .and. i .le. igh) go to 200 + wr(i) = hr(i,i) + wi(i) = hi(i,i) + 200 continue +c + 210 continue + en = igh + tr = 0.0d+0 + ti = 0.0d+0 + itn = 30*n +c .......... search for next eigenvalue .......... + 220 if (en .lt. low) go to 1001 + its = 0 + enm1 = en - 1 +c .......... look for single small sub-diagonal element +c for l=en step -1 until low do -- .......... + 240 do 260 ll = low, en + l = en + low - ll + if (l .eq. low) go to 300 +c***** + xr = abs(hr(l-1,l-1)) + abs(hi(l-1,l-1) + x + abs(hr(l,l)) +abs(hi(l,l))) + yr = xr + abs(hr(l,l-1)) + if (xr .eq. yr) go to 300 +c***** + 260 continue +c .......... form shift .......... + 300 if (l .eq. en) go to 660 + if (itn .eq. 0) go to 1000 + if (its .eq. 10 .or. its .eq. 20) go to 320 + sr = hr(en,en) + si = hi(en,en) + xr = hr(enm1,en)*hr(en,enm1) + xi = hi(enm1,en)*hr(en,enm1) + if (xr .eq. 0.0d+0 .and. xi .eq. 0.0d+0) go to 340 + yr = (hr(enm1,enm1) - sr)/2.0d+0 + yi = (hi(enm1,enm1) - si)/2.0d+0 + call wsqrt(yr**2-yi**2+xr,2.0d+0*yr*yi+xi,zzr,zzi) + if (yr*zzr + yi*zzi .ge. 0.0d+0) go to 310 + zzr = -zzr + zzi = -zzi + 310 call cdiv(xr,xi,yr+zzr,yi+zzi,zzr,zzi) + sr = sr - zzr + si = si - zzi + go to 340 +c .......... form exceptional shift .......... + 320 sr = abs(hr(en,enm1)) + abs(hr(enm1,en-2)) + si = 0.0d+0 +c + 340 do 360 i = low, en + hr(i,i) = hr(i,i) - sr + hi(i,i) = hi(i,i) - si + 360 continue +c + tr = tr + sr + ti = ti + si + its = its + 1 + itn = itn - 1 +c .......... reduce to triangle (rows) .......... + lp1 = l + 1 +c + do 500 i = lp1, en + sr = hr(i,i-1) + hr(i,i-1) = 0.0d+0 + norm = pythag(pythag(hr(i-1,i-1),hi(i-1,i-1)),sr) + xr = hr(i-1,i-1)/norm + wr(i-1) = xr + xi = hi(i-1,i-1)/norm + wi(i-1) = xi + hr(i-1,i-1) = norm + hi(i-1,i-1) = 0.0d+0 + hi(i,i-1) = sr/norm +c + do 490 j = i, n + yr = hr(i-1,j) + yi = hi(i-1,j) + zzr = hr(i,j) + zzi = hi(i,j) + hr(i-1,j) = xr*yr + xi*yi + hi(i,i-1)*zzr + hi(i-1,j) = xr*yi - xi*yr + hi(i,i-1)*zzi + hr(i,j) = xr*zzr - xi*zzi - hi(i,i-1)*yr + hi(i,j) = xr*zzi + xi*zzr - hi(i,i-1)*yi + 490 continue +c + 500 continue +c + si = hi(en,en) + if (si .eq. 0.0d+0) go to 540 + norm = pythag(hr(en,en),si) + sr = hr(en,en)/norm + si = si/norm + hr(en,en) = norm + hi(en,en) = 0.0d+0 + if (en .eq. n) go to 540 + ip1 = en + 1 +c + do 520 j = ip1, n + yr = hr(en,j) + yi = hi(en,j) + hr(en,j) = sr*yr + si*yi + hi(en,j) = sr*yi - si*yr + 520 continue +c .......... inverse operation (columns) .......... + 540 do 600 j = lp1, en + xr = wr(j-1) + xi = wi(j-1) +c + do 580 i = 1, j + yr = hr(i,j-1) + yi = 0.0d+0 + zzr = hr(i,j) + zzi = hi(i,j) + if (i .eq. j) go to 560 + yi = hi(i,j-1) + hi(i,j-1) = xr*yi + xi*yr + hi(j,j-1)*zzi + 560 hr(i,j-1) = xr*yr - xi*yi + hi(j,j-1)*zzr + hr(i,j) = xr*zzr + xi*zzi - hi(j,j-1)*yr + hi(i,j) = xr*zzi - xi*zzr - hi(j,j-1)*yi + 580 continue +c***** + if (jy .eq. 0) go to 600 +c***** + do 590 i = low, igh + yr = zr(i,j-1) + yi = zi(i,j-1) + zzr = zr(i,j) + zzi = zi(i,j) + zr(i,j-1) = xr*yr - xi*yi + hi(j,j-1)*zzr + zi(i,j-1) = xr*yi + xi*yr + hi(j,j-1)*zzi + zr(i,j) = xr*zzr + xi*zzi - hi(j,j-1)*yr + zi(i,j) = xr*zzi - xi*zzr - hi(j,j-1)*yi + 590 continue +c + 600 continue +c + if (si .eq. 0.0d+0) go to 240 +c + do 630 i = 1, en + yr = hr(i,en) + yi = hi(i,en) + hr(i,en) = sr*yr - si*yi + hi(i,en) = sr*yi + si*yr + 630 continue +c***** + if (jy .eq. 0) go to 240 +c***** + do 640 i = low, igh + yr = zr(i,en) + yi = zi(i,en) + zr(i,en) = sr*yr - si*yi + zi(i,en) = sr*yi + si*yr + 640 continue +c + go to 240 +c .......... a root found .......... + 660 hr(en,en) = hr(en,en) + tr + wr(en) = hr(en,en) + hi(en,en) = hi(en,en) + ti + wi(en) = hi(en,en) + en = enm1 + go to 220 +c .......... all roots found. .......... + +c go to 1001 +c +c .......... set error -- no convergence to an +c eigenvalue after 30 iterations .......... + 1000 ierr = en + 1001 return + end diff --git a/modules/elementary_functions/src/fortran/comqr3.lo b/modules/elementary_functions/src/fortran/comqr3.lo new file mode 100755 index 000000000..ffe68e931 --- /dev/null +++ b/modules/elementary_functions/src/fortran/comqr3.lo @@ -0,0 +1,12 @@ +# src/fortran/comqr3.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/comqr3.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/core_Import.def b/modules/elementary_functions/src/fortran/core_Import.def new file mode 100755 index 000000000..2096aee0d --- /dev/null +++ b/modules/elementary_functions/src/fortran/core_Import.def @@ -0,0 +1,35 @@ + LIBRARY core.dll + + +EXPORTS +; +;core +; +adre_ +intersci_ +; +vstk_ +com_ +stack_ +recu_ +iop_ +errgst_ +cha1_ +checkrhs_ +checklhs_ +cremat_ +gettype_ +getsmat_ +getmat_ +getscalar_ +objvide_ +cresmat2_ +isanan_ +returnananfortran_ +crebmat_ +getrvect_ +getrmat_ +copyobj_ +getilist_ +getlistmat_ +checkval_
\ No newline at end of file diff --git a/modules/elementary_functions/src/fortran/corth.f b/modules/elementary_functions/src/fortran/corth.f new file mode 100755 index 000000000..d9d2331b9 --- /dev/null +++ b/modules/elementary_functions/src/fortran/corth.f @@ -0,0 +1,142 @@ + subroutine corth(nm,n,low,igh,ar,ai,ortr,orti) +c + integer i,j,m,n,ii,jj,la,mp,nm,igh,kp1,low + double precision ar(nm,n),ai(nm,n),ortr(igh),orti(igh) + double precision f,g,h,fi,fr,scale +c +c!purpose +c +c given a complex general matrix, this subroutine +c reduces a submatrix situated in rows and columns +c low through igh to upper hessenberg form by +c unitary similarity transformations. +c +c!calling sequence +c subroutine corth(nm,n,low,igh,ar,ai,ortr,orti) +c +c integer i,j,m,n,ii,jj,la,mp,nm,igh,kp1,low +c double precision ar(nm,n),ai(nm,n),ortr(igh),orti(igh) +c double precision f,g,h,fi,fr,scale +c +c on input: +c +c nm must be set to the row dimension of two-dimensional +c array parameters as declared in the calling program +c dimension statement; +c +c n is the order of the matrix; +c +c low and igh are integers determined by the balancing +c subroutine cbal. if cbal has not been used, +c set low=1, igh=n; +c +c ar and ai contain the real and imaginary parts, +c respectively, of the complex input matrix. +c +c on output: +c +c ar and ai contain the real and imaginary parts, +c respectively, of the hessenberg matrix. information +c about the unitary transformations used in the reduction +c is stored in the remaining triangles under the +c hessenberg matrix; +c +c ortr and orti contain further information about the +c transformations. only elements low through igh are used. +c +c!originator +c +c this subroutine is a translation of a complex analogue of +c the algol procedure orthes, num. math. 12, 349-368(1968) +c by martin and wilkinson. +c handbook for auto. comp., vol.ii-linear algebra, 339-358(1971). +c questions and comments should be directed to b. s. garbow, +c applied mathematics division, argonne national laboratory +c +c! +c ------------------------------------------------------------------ +c + la = igh - 1 + kp1 = low + 1 + if (la .lt. kp1) go to 200 +c + do 180 m = kp1, la + h = 0.0d+0 + ortr(m) = 0.0d+0 + orti(m) = 0.0d+0 + scale = 0.0d+0 +c :::::::::: scale column (algol tol then not needed) :::::::::: + do 90 i = m, igh + 90 scale = scale + abs(ar(i,m-1)) + abs(ai(i,m-1)) +c + if (scale .eq. 0.0d+0) go to 180 + mp = m + igh +c :::::::::: for i=igh step -1 until m do -- :::::::::: + do 100 ii = m, igh + i = mp - ii + ortr(i) = ar(i,m-1) / scale + orti(i) = ai(i,m-1) / scale + h = h + ortr(i) * ortr(i) + orti(i) * orti(i) + 100 continue +c + g = sqrt(h) + f = sqrt(ortr(m)*ortr(m)+orti(m)*orti(m)) + if (f .eq. 0.0d+0) go to 103 + h = h + f * g + g = g / f + ortr(m) = (1.0d+0 + g) * ortr(m) + orti(m) = (1.0d+0 + g) * orti(m) + go to 105 +c + 103 ortr(m) = g + ar(m,m-1) = scale +c :::::::::: form (i-(u*ut)/h) * a :::::::::: + 105 do 130 j = m, n + fr = 0.0d+0 + fi = 0.0d+0 +c :::::::::: for i=igh step -1 until m do -- :::::::::: + do 110 ii = m, igh + i = mp - ii + fr = fr + ortr(i) * ar(i,j) + orti(i) * ai(i,j) + fi = fi + ortr(i) * ai(i,j) - orti(i) * ar(i,j) + 110 continue +c + fr = fr / h + fi = fi / h +c + do 120 i = m, igh + ar(i,j) = ar(i,j) - fr * ortr(i) + fi * orti(i) + ai(i,j) = ai(i,j) - fr * orti(i) - fi * ortr(i) + 120 continue +c + 130 continue +c :::::::::: form (i-(u*ut)/h)*a*(i-(u*ut)/h) :::::::::: + do 160 i = 1, igh + fr = 0.0d+0 + fi = 0.0d+0 +c :::::::::: for j=igh step -1 until m do -- :::::::::: + do 140 jj = m, igh + j = mp - jj + fr = fr + ortr(j) * ar(i,j) - orti(j) * ai(i,j) + fi = fi + ortr(j) * ai(i,j) + orti(j) * ar(i,j) + 140 continue +c + fr = fr / h + fi = fi / h +c + do 150 j = m, igh + ar(i,j) = ar(i,j) - fr * ortr(j) - fi * orti(j) + ai(i,j) = ai(i,j) + fr * orti(j) - fi * ortr(j) + 150 continue +c + 160 continue +c + ortr(m) = scale * ortr(m) + orti(m) = scale * orti(m) + ar(m,m-1) = -g * ar(m,m-1) + ai(m,m-1) = -g * ai(m,m-1) + 180 continue +c + 200 return +c :::::::::: last card of corth :::::::::: + end diff --git a/modules/elementary_functions/src/fortran/corth.lo b/modules/elementary_functions/src/fortran/corth.lo new file mode 100755 index 000000000..ce04b2577 --- /dev/null +++ b/modules/elementary_functions/src/fortran/corth.lo @@ -0,0 +1,12 @@ +# src/fortran/corth.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/corth.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/cortr.f b/modules/elementary_functions/src/fortran/cortr.f new file mode 100755 index 000000000..18ef9ef34 --- /dev/null +++ b/modules/elementary_functions/src/fortran/cortr.f @@ -0,0 +1,99 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine cortr(nm,n,low,igh,hr,hi,ortr,orti,zr,zi) +c!purpose +c cortr accumulate the unitary similarities performed by corth +c!calling sequence +c +c subroutine cortr(nm,n,low,igh,hr,hi,ortr,orti,zr,zi) +c +c on input. +c +c nm must be set to the row dimension of two-dimensional +c array parameters as declared in the calling program +c dimension statement. +c +c n is the order of the matrix. +c +c low and igh are integers determined by the balancing +c subroutine cbal. if cbal has not been used, +c set low=1, igh=n. +c +c hr and hi contain the real and imaginary parts, +c respectively, of the complex upper hessenberg matrix. +c their lower triangles below the subdiagonal contain further +c information about the transformations which were used in the +c reduction by corth, if performed. if the eigenvectors of +c the hessenberg matrix are desired, these elements may be +c arbitrary. +c +c +c on output. +c +c zr and zi contain the real and imaginary parts, +c respectivelyof the tranformations performed +c +c! + double precision hr(nm,n),hi(nm,n),zr(nm,n),zi(nm,n),ortr(igh) + double precision orti(igh),sr,si,norm +c .......... initialize eigenvector matrix .......... + do 100 i = 1, n +c + do 100 j = 1, n + zr(i,j) = 0.0d+0 + zi(i,j) = 0.0d+0 + if (i .eq. j) zr(i,j) = 1.0d+0 + 100 continue +c .......... form the matrix of accumulated transformations +c from the information left by corth .......... + iend = igh - low - 1 + if (iend .le. 0) then + goto 150 + else + goto 105 + endif +c .......... for i=igh-1 step -1 until low+1 do -- .......... + 105 do 140 ii = 1, iend + i = igh - ii +cx if (ortr(i) .eq. 0.0d+0 .and. orti(i) .eq. 0.0d+0) go to 140 +cx if (hr(i,i-1).eq.0.0d+0 .and. hi(i,i-1).eq.0.0d+0) go to 140 +c .......... norm below is negative of h formed in corth .......... + norm = hr(i,i-1)*ortr(i) + hi(i,i-1)*orti(i) + if (norm.eq.0.0d+00) goto 140 + ip1 = i + 1 +c + do 110 k = ip1, igh + ortr(k) = hr(k,i-1) + orti(k) = hi(k,i-1) + 110 continue +c + do 130 j = i, igh + sr = 0.0d+0 + si = 0.0d+0 +c + do 115 k = i, igh + sr = sr + ortr(k)*zr(k,j) + orti(k)*zi(k,j) + si = si + ortr(k)*zi(k,j) - orti(k)*zr(k,j) + 115 continue +c + sr = sr/norm + si = si/norm +c + do 120 k = i, igh + zr(k,j) = zr(k,j) + sr*ortr(k) - si*orti(k) + zi(k,j) = zi(k,j) + sr*orti(k) + si*ortr(k) + 120 continue +c + 130 continue +c + 140 continue +c***** + 150 return + end diff --git a/modules/elementary_functions/src/fortran/cortr.lo b/modules/elementary_functions/src/fortran/cortr.lo new file mode 100755 index 000000000..84298bcf1 --- /dev/null +++ b/modules/elementary_functions/src/fortran/cortr.lo @@ -0,0 +1,12 @@ +# src/fortran/cortr.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/cortr.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/coshin.f b/modules/elementary_functions/src/fortran/coshin.f new file mode 100755 index 000000000..9859f4a22 --- /dev/null +++ b/modules/elementary_functions/src/fortran/coshin.f @@ -0,0 +1,25 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c +C/MEMBR ADD NAME=COSHIN,SSI=0 +c +c fonction: coshin +c fonction cosinus hyperbolique inverse de x +c en double precision +c acheve le 05/12/85 +c ecrit par philippe touron +c +c +c sous programmes appeles: aucun +c + double precision function coshin(x) + double precision x + coshin=log(x+sqrt(x*x-1.0d+0)) + return + end diff --git a/modules/elementary_functions/src/fortran/coshin.lo b/modules/elementary_functions/src/fortran/coshin.lo new file mode 100755 index 000000000..adfa1e886 --- /dev/null +++ b/modules/elementary_functions/src/fortran/coshin.lo @@ -0,0 +1,12 @@ +# src/fortran/coshin.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/coshin.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/cupro.f b/modules/elementary_functions/src/fortran/cupro.f new file mode 100755 index 000000000..bce4a6aa7 --- /dev/null +++ b/modules/elementary_functions/src/fortran/cupro.f @@ -0,0 +1,19 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine cupro(n,w) +c Utility fct: cumulated product +c + double precision w(*),t + t=1.0d0 + do 1 k=1,n + w(k)=t*w(k) + t=w(k) + 1 continue + end diff --git a/modules/elementary_functions/src/fortran/cupro.lo b/modules/elementary_functions/src/fortran/cupro.lo new file mode 100755 index 000000000..b327ac069 --- /dev/null +++ b/modules/elementary_functions/src/fortran/cupro.lo @@ -0,0 +1,12 @@ +# src/fortran/cupro.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/cupro.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/cuproi.f b/modules/elementary_functions/src/fortran/cuproi.f new file mode 100755 index 000000000..0686b99be --- /dev/null +++ b/modules/elementary_functions/src/fortran/cuproi.f @@ -0,0 +1,24 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine cuproi(n,wr,wi) +c Utility fct: cumulated product, complex argument +c + double precision wr(*),wi(*),tr,ti,wwr + tr=1.0d0 + ti=0.0d0 + do 1 k=1,n +c w(k)=t*w(k) + wwr=wr(k) + wr(k)=tr*wwr-ti*wi(k) + wi(k)=tr*wi(k)+ti*wwr + tr=wr(k) + ti=wi(k) + 1 continue + end diff --git a/modules/elementary_functions/src/fortran/cuproi.lo b/modules/elementary_functions/src/fortran/cuproi.lo new file mode 100755 index 000000000..3bbef3087 --- /dev/null +++ b/modules/elementary_functions/src/fortran/cuproi.lo @@ -0,0 +1,12 @@ +# src/fortran/cuproi.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/cuproi.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/cusum.f b/modules/elementary_functions/src/fortran/cusum.f new file mode 100755 index 000000000..6d679d360 --- /dev/null +++ b/modules/elementary_functions/src/fortran/cusum.f @@ -0,0 +1,19 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine cusum(n,w) +c Utility fct: cumulated sum + double precision w(*),t + t=0.0d0 + do 1 k=1,n + w(k)=t+w(k) + t=w(k) + 1 continue + end + diff --git a/modules/elementary_functions/src/fortran/cusum.lo b/modules/elementary_functions/src/fortran/cusum.lo new file mode 100755 index 000000000..600d3d192 --- /dev/null +++ b/modules/elementary_functions/src/fortran/cusum.lo @@ -0,0 +1,12 @@ +# src/fortran/cusum.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/cusum.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/d1mach.f b/modules/elementary_functions/src/fortran/d1mach.f new file mode 100755 index 000000000..54c4ca89a --- /dev/null +++ b/modules/elementary_functions/src/fortran/d1mach.f @@ -0,0 +1,47 @@ + DOUBLE PRECISION FUNCTION D1MACH(I) +C +C Double-precision machine constants. +C This implementation for use in MATLAB Fortran Mex-files. +C +C D1MACH(1) = realmin = B**(EMIN-1), the smallest positive magnitude. +C D1MACH(2) = realmax = B**EMAX*(1 - B**(-T)), the largest magnitude. +C D1MACH(3) = eps/2 = B**(-T), the smallest relative spacing. +C D1MACH(4) = eps = B**(1-T), the largest relative spacing. +C D1MACH(5) = LOG10(B) +C +c DLAMCH +* = 'E' or 'e', DLAMCH := eps +* = 'S' or 's , DLAMCH := sfmin +* = 'B' or 'b', DLAMCH := base +* = 'P' or 'p', DLAMCH := eps*base +* = 'N' or 'n', DLAMCH := t +* = 'R' or 'r', DLAMCH := rnd +* = 'M' or 'm', DLAMCH := emin +* = 'U' or 'u', DLAMCH := rmin +* = 'L' or 'l', DLAMCH := emax +* = 'O' or 'o', DLAMCH := rmax +* +* where +* +* eps = relative machine precision +* sfmin = safe minimum, such that 1/sfmin does not overflow +* base = base of the machine +* prec = eps*base +* t = number of (base) digits in the mantissa +* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise +* emin = minimum exponent before (gradual) underflow +* rmin = underflow threshold - base**(emin-1) +* emax = largest exponent before overflow +* rmax = overflow threshold - (base**emax)*(1-eps) +* + + + double precision DLAMCH + IF (I .EQ. 1) D1MACH = DLAMCH('U') + IF (I .EQ. 2) D1MACH = DLAMCH('O') + IF (I .EQ. 3) D1MACH = DLAMCH('E') + IF (I .EQ. 4) D1MACH = DLAMCH('P') + IF (I .EQ. 5) D1MACH = log10(DLAMCH('B')) + RETURN + END + diff --git a/modules/elementary_functions/src/fortran/d1mach.lo b/modules/elementary_functions/src/fortran/d1mach.lo new file mode 100755 index 000000000..500eba5d8 --- /dev/null +++ b/modules/elementary_functions/src/fortran/d1mach.lo @@ -0,0 +1,12 @@ +# src/fortran/d1mach.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/d1mach.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/dad.f b/modules/elementary_functions/src/fortran/dad.f new file mode 100755 index 000000000..8e44739cf --- /dev/null +++ b/modules/elementary_functions/src/fortran/dad.f @@ -0,0 +1,106 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine dad(a, na, i1, i2, j1, j2, r, isw) +c +c!purpose +c +c dad compute the matrix product a=d*a or a=a*d +c where d is the matrix with ones on the anti- +c diagonal and a the input matrix. it also +c multiplies each element of the product with +c the constant r +c!calling sequence +c +c subroutine dad(a, na, i1, i2, j1, j2, r, isw) +c integer i1, i2, j1, j2, na, isw +c double precision a, r +c dimension a(na,*) +c +c a : input matrix +c +c na: leading dimension of a +c +c i1,i2 : the first and the last rows of a to be considered +c +c j1,j2 : the first and the last columns of a to be considered +c +c r: constant factor +c +c isw: parameter specifying the product to be done +c isw=0 : d*a +c isw=1 : a*d +c +c!auxiliary routines +c ifix real mod (fortran) +c + integer i1, i2, j1, j2, na, isw + double precision a, r + dimension a(na,*) +c internal variables +c + integer i1i ,i2i,j1j,j2j,nrd2,ip1,i,j,ncd2 + double precision temp +c + if (isw.eq.1) go to 60 + if (i1.eq.i2) go to 40 +c + nrd2 = ifix(real((i2-i1+1)/2)) + do 20 j=j1,j2 + do 10 ip1=1,nrd2 + i = ip1 - 1 + i1i = i1 + i + i2i = i2 - i + temp = a(i1i,j) + a(i1i,j) = a(i2i,j)*r + a(i2i,j) = temp*r + 10 continue + 20 continue + if (mod(i2-i1,2).eq.1) return + i = i1 + nrd2 + do 30 j=j1,j2 + a(i,j) = a(i,j)*r + 30 continue + return + 40 continue + do 50 j=j1,j2 + a(i1,j) = a(i1,j)*r + 50 continue + return +c +c +c computes the product ad where d is as above. +c +c +c + 60 continue + if (j1.eq.j2) go to 100 + ncd2 = ifix(real((j2-j1+1)/2)) + do 80 jp1=1,ncd2 + j = jp1 - 1 + do 70 i=i1,i2 + j1j = j1 + j + j2j = j2 - j + temp = a(i,j1j) + a(i,j1j) = a(i,j2j)*r + a(i,j2j) = temp*r + 70 continue + 80 continue + if (mod(j2-j1,2).eq.1) return + j = j1 + ncd2 + do 90 i=i1,i2 + a(i,j) = a(i,j)*r + 90 continue + return + 100 continue + do 110 i=i1,i2 + a(i,j1) = a(i,j1)*r + 110 continue + return + end diff --git a/modules/elementary_functions/src/fortran/dad.lo b/modules/elementary_functions/src/fortran/dad.lo new file mode 100755 index 000000000..e9df46712 --- /dev/null +++ b/modules/elementary_functions/src/fortran/dad.lo @@ -0,0 +1,12 @@ +# src/fortran/dad.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dad.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/dadd.f b/modules/elementary_functions/src/fortran/dadd.f new file mode 100755 index 000000000..c401015d4 --- /dev/null +++ b/modules/elementary_functions/src/fortran/dadd.f @@ -0,0 +1,58 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine dadd(n,dx,incx,dy,incy) +c!but +c +c cette subroutine ajoute le vecteur x, de taille n, au +c vecteur y. (y=y+x) +c dans le cas de deux increments egaux a 1, cette subroutine +c emploie des boucles "epanouies". +c dans le cas ou les increments sont negatifs cette +c subroutine prend les composantes en ordre inverse. +c +c!liste d'appel +c +c subroutine dadd(n,dx,incx,dy,incy) +c +c n: taille du vecteur x +c +c dx: vecteur double precision contenant x +c +c dy: vecteur double precision contenant y +c +c incx, incy: increments entre les composantes des vecteurs. +c + double precision dx(*),dy(*) + integer i,incx,incy,ix,iy,n +c + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments not equal to 1 +c + 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) = dx(ix) + dy(iy) + ix = ix + incx + iy = iy + incy + 10 continue + return +c +c code for both increments equal to 1 +c + 20 continue + do 30 i = 1,n + dy(i) = dx(i) + dy(i) + 30 continue +c + end diff --git a/modules/elementary_functions/src/fortran/dadd.lo b/modules/elementary_functions/src/fortran/dadd.lo new file mode 100755 index 000000000..49bdec6cd --- /dev/null +++ b/modules/elementary_functions/src/fortran/dadd.lo @@ -0,0 +1,12 @@ +# src/fortran/dadd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dadd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/dclmat.f b/modules/elementary_functions/src/fortran/dclmat.f new file mode 100755 index 000000000..e7c8662bc --- /dev/null +++ b/modules/elementary_functions/src/fortran/dclmat.f @@ -0,0 +1,69 @@ + subroutine dclmat(ia, n, a, b, ib, w, c, ndng) +c +c%purpose +c computes a matrix polynomial representated in a chebyshev +c base by the clenshaw method. +c +c%calling sequence +c +c subroutine dclmat(ia, n, a, b, ib,w , c, ndng) +c +c integer ia,n,ib,ndng +c double precision a,b,w,c +c dimension a(ia,n), b(ib,n), c(*), w(*) +c +c ia: the leading dimension of array a. +c n: the order of the matrices a,b. +c a: the array that contains the n*n matrix a +c b: the array that contains the n*n matrix +c pol(a). +c ib:the leading dimension of array b. +c w : work-space array of size n+n +c c: vectors which contains the coefficients +c of the polynome. +c ndng: the polynomial order. +c +c%auxiliary routines +c dmmul (blas.extension) +c% +c + integer ia,n,ib,ndng + double precision a,b,w,c + dimension a(ia,n), b(ib,n), c(*), w(*) +c internal variables +c + integer i1,i,im1,j,ndng1,ndng2 + double precision two,zero,rc,wd,w1,half + data zero, two, half /0.0d+0,2.0d+0,0.50d+0/ +c + ndng1 = ndng + 2 + ndng2 = ndng - 1 + rc = c(ndng1-1) + wd = c(1) + do 60 j=1,n + do 10 i=1,n + w(n+i) = zero + w(i) = zero + 10 continue + do 30 i1=1,ndng + im1 = ndng1 - i1 + call dmmul(a,ia,w,n,b(1,j),ib,n,n,1) + do 20 i=1,n + w1 = two*b(i,j) - w(n+i) + w(n+i) = w(i) + w(i) = w1 + 20 continue + w(j) = w(j) + c(im1) + 30 continue + call dmmul(a,ia,w,n,b(1,j),ib,n,n,1) + do 40 i=1,n + w(i) = two*b(i,j) - w(n+i) + 40 continue + w(j) = w(j) + wd + do 50 i=1,n + b(i,j) = (w(i)-w(n+i))*half + 50 continue + b(j,j) = b(j,j) + half*wd + 60 continue + return + end diff --git a/modules/elementary_functions/src/fortran/dclmat.lo b/modules/elementary_functions/src/fortran/dclmat.lo new file mode 100755 index 000000000..0118ed45f --- /dev/null +++ b/modules/elementary_functions/src/fortran/dclmat.lo @@ -0,0 +1,12 @@ +# src/fortran/dclmat.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dclmat.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/ddif.f b/modules/elementary_functions/src/fortran/ddif.f new file mode 100755 index 000000000..60479f073 --- /dev/null +++ b/modules/elementary_functions/src/fortran/ddif.f @@ -0,0 +1,35 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c +C/MEMBR ADD NAME=DDIF,SSI=0 +c + subroutine ddif(n,a,na,b,nb) +c!but +c ddif effectue l'operation vectorielle b=b-a +c!liste d'appel +c subroutine ddif(n,a,na,b,nb) +c double precision a(*),b(*) +c integer n,na,nb +c +c n : nombre d'elements des vecteurs a et b +c a : tableau contenant a +c na : increment entre deux elements consecutifs de a +c na > 0 +c b,nb : definitions similaires a celles de a et na +c! + double precision a(*),b(*) + ia=1 + ib=1 + do 10 i=1,n + b(ib)=b(ib)-a(ia) + ia=ia+na + ib=ib+nb + 10 continue + return + end diff --git a/modules/elementary_functions/src/fortran/ddif.lo b/modules/elementary_functions/src/fortran/ddif.lo new file mode 100755 index 000000000..aac1aa4c3 --- /dev/null +++ b/modules/elementary_functions/src/fortran/ddif.lo @@ -0,0 +1,12 @@ +# src/fortran/ddif.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ddif.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/ddpow.f b/modules/elementary_functions/src/fortran/ddpow.f new file mode 100755 index 000000000..e1bf7d8d3 --- /dev/null +++ b/modules/elementary_functions/src/fortran/ddpow.f @@ -0,0 +1,78 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) 1989 - INRIA - Serge STEER +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine ddpow(n,vr,vi,iv,dpow,ierr,iscmpl) +c!but +c eleve a une puissance reelle les elements d'un vecteur de flottants +c double precision +c!liste d'appel +c subroutine ddpow(n,v,iv,dpow,ierr) +c integer n,iv,ierr +c double precision v(n*iv),dpow +c +c n : nombre d'element du vecteur +c vr : tableau contenant en entree les elements du vecteur et en +c sortie les parties reelles du resultat +c vi : tableau contenant en sortie les parties imaginaire (eventuelles) +c du resultat +c iv : increment entre deux element consecutif du vecteur dans le +c tableau v +c dpow : puissance a la quelle doivent etre eleves les elements du +c vecteur +c ierr : indicateur d'erreur +c ierr=0 si ok +c ierr=1 si 0**0 +c ierr=2 si 0**k avec k<0 +c iscmpl : +c iscmpl=0 resultat reel +c iscmpl=1 resultat complexe +c!origine +c Serge Steer INRIA 1989 +c + integer n,iv,ierr + double precision vr(*),vi(*),dpow,sr,si +c + ierr=0 + iscmpl=0 +c + if(dble(int(dpow)).ne.dpow) goto 01 +c puissance entiere + call dipow(n,vr,iv,int(dpow),ierr) + return +c + 01 continue + ii=1 + do 20 i=1,n + if(vr(ii).gt.0.0d+0) then + vr(ii)=vr(ii)**dpow + vi(ii)=0.0d0 + elseif(vr(ii).lt.0.0d+0) then + call wlog(vr(ii),0.0d0,sr,si) + sr=exp(sr*dpow) + si=si*dpow + vr(ii)=sr*cos(si) + vi(ii)=sr*sin(si) + iscmpl=1 + else + if(dpow.lt.0.0d+0) then + ierr=2 + return + elseif(dpow.eq.0.0d+0) then + ierr=1 + return + else + vr(ii)=0.0d0 + vi(ii)=0.0d0 + endif + endif + ii=ii+iv + 20 continue +c + return + end diff --git a/modules/elementary_functions/src/fortran/ddpow.lo b/modules/elementary_functions/src/fortran/ddpow.lo new file mode 100755 index 000000000..71766a9db --- /dev/null +++ b/modules/elementary_functions/src/fortran/ddpow.lo @@ -0,0 +1,12 @@ +# src/fortran/ddpow.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ddpow.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/ddpow1.f b/modules/elementary_functions/src/fortran/ddpow1.f new file mode 100755 index 000000000..803543baa --- /dev/null +++ b/modules/elementary_functions/src/fortran/ddpow1.f @@ -0,0 +1,59 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) 1996 - INRIA - Serge STEER +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine ddpow1(n,v,iv,p,ip,rr,ri,ir,ierr,iscmpl) +c!purpose +c computes V^P with V and P real vectors +c!calling sequence +c subroutine ddpow1(n,v,iv,p,ip,rr,ri,ir,ierr,iscmpl) +c integer n,iv,ip,ir,ierr,iscmpl +c double precision v(*),p(*),rr(*),ri(*) +c +c n : number of elements of V and P vectors +c v : array containing V elements V(i)=v(1+(i-1)*iv) +c iv : increment between two V elements in v (may be 0) +c p : array containing P elements P(i)=p(1+(i-1)*ip) +c ip : increment between two P elements in p (may be 0) +c rr : array containing real part of the results vector R: +c real(R(i))=rr(1+(i-1)*ir) +c ri : array containing imaginary part of the results vector R: +c imag(R(i))=ri(1+(i-1)*ir) +c ir : increment between two R elements in rr and ri +c ierr : error flag +c ierr=0 if ok +c ierr=1 if 0**0 +c ierr=2 if 0**k with k<0 +c iscmpl : +c iscmpl=0 if result is real +c iscmpl=1 if result is complex +c!origin +c Serge Steer INRIA 1996 +c + integer n,iv,ierr,ierr1 + double precision v(*),p(*),rr(*),ri(*) +c + ierr=0 + iscmpl=0 +c + + ii=1 + iip=1 + iir=1 + do 20 i=1,n + call ddpowe(v(ii),p(iip),rr(iir),ri(iir),ierr1,isc) + ierr=max(ierr,ierr1) +c if(ierr.ne.0) return + iscmpl=max(iscmpl,isc) + ii=ii+iv + iip=iip+ip + iir=iir+ir + 20 continue +c + return + end diff --git a/modules/elementary_functions/src/fortran/ddpow1.lo b/modules/elementary_functions/src/fortran/ddpow1.lo new file mode 100755 index 000000000..321b13ecc --- /dev/null +++ b/modules/elementary_functions/src/fortran/ddpow1.lo @@ -0,0 +1,12 @@ +# src/fortran/ddpow1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ddpow1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/ddpowe.f b/modules/elementary_functions/src/fortran/ddpowe.f new file mode 100755 index 000000000..b3d38075c --- /dev/null +++ b/modules/elementary_functions/src/fortran/ddpowe.f @@ -0,0 +1,75 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) 1996 - INRIA - Serge STEER +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine ddpowe(v,p,rr,ri,ierr,iscmpl) +c!purpose +c computes v^p with p and v double precision +c!calling sequence +c subroutine ddpowe(v,p,rr,ri,ierr,iscmpl) +c integer ierr +c double precision v,p,rr,ri +c +c rr : result's real part +c ri : result's imaginary part +c ierr : error flag +c ierr=0 if ok +c ierr=1 if 0**0 +c ierr=2 if 0**k with k<0 +c iscmpl : +c iscmpl=0 if result is real +c iscmpl=1 if result is complex +c!origin +c Serge Steer INRIA 1996 +c + integer ierr + double precision v,p,sr,si,rr,ri,infinity +c + ierr=0 + iscmpl=0 +c + if(dble(int(p)).eq.p) then + call dipowe(v,int(p),rr,ierr) + ri=0.0d0 + else + if(v.gt.0.0d+0) then + rr=v**p + ri=0.0d0 + elseif(v.lt.0.0d+0) then + call wlog(v,0.0d0,sr,si) + sr=exp(sr*p) + si=si*p + rr=sr*cos(si) + ri=sr*sin(si) + iscmpl=1 + elseif(v.eq.0.d0) then + if(p.lt.0.0d+0) then + ri=0.0d0 + rr=infinity(ri) + ierr=2 + elseif(p.eq.0.0d+0) then +c ierr=1 + rr=1.0d0 + ri=0.0d0 + elseif(p.gt.0.d0) then + rr=0.0d0 + ri=0.0d0 + else +c p is nan + rr = p + ri = 0.d0 + endif + else +c v is nan + rr = v + ri = 0.d0 + endif + endif +c + return + end diff --git a/modules/elementary_functions/src/fortran/ddpowe.lo b/modules/elementary_functions/src/fortran/ddpowe.lo new file mode 100755 index 000000000..2a40f3e43 --- /dev/null +++ b/modules/elementary_functions/src/fortran/ddpowe.lo @@ -0,0 +1,12 @@ +# src/fortran/ddpowe.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ddpowe.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/ddrdiv.f b/modules/elementary_functions/src/fortran/ddrdiv.f new file mode 100755 index 000000000..fa1d6ed22 --- /dev/null +++ b/modules/elementary_functions/src/fortran/ddrdiv.f @@ -0,0 +1,62 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine ddrdiv(a,ia,b,ib,r,ir,n,ierr) +c! purpose +c computes r=a./b with a and b real +c +c ia,ib,ir : increment between two consecutive element of vectors a +c b and r +c a : array containing vector a elements +c b : array containing vector b elements +c r : array containing vector r elements +c n : vectors length +c ierr : returned error flag: +c o : ok +c <>0 : b(ierr)=0 +c + double precision a(*),b(*),r(*) + integer ia,ib,ir,n + jr=1 + jb=1 + ja=1 + ierr=0 + if (ia.eq.0) then + do 10 k=1,n + if(b(jb).eq.0.0d0) then + ierr=k +c return + endif + r(jr)=a(ja)/b(jb) + jr=jr+ir + jb=jb+ib + 10 continue + elseif(ib.eq.0) then + if(b(jb).eq.0.0d0) then + ierr=1 +c return + endif + do 11 k=1,n + r(jr)=a(ja)/b(jb) + jr=jr+ir + ja=ja+ia + 11 continue + else + do 12 k=1,n + if(b(jb).eq.0.0d0) then + ierr=k +c return + endif + r(jr)=a(ja)/b(jb) + jr=jr+ir + jb=jb+ib + ja=ja+ia + 12 continue + endif + end diff --git a/modules/elementary_functions/src/fortran/ddrdiv.lo b/modules/elementary_functions/src/fortran/ddrdiv.lo new file mode 100755 index 000000000..3eab5a604 --- /dev/null +++ b/modules/elementary_functions/src/fortran/ddrdiv.lo @@ -0,0 +1,12 @@ +# src/fortran/ddrdiv.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ddrdiv.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/dexpm1.f b/modules/elementary_functions/src/fortran/dexpm1.f new file mode 100755 index 000000000..5458266c8 --- /dev/null +++ b/modules/elementary_functions/src/fortran/dexpm1.f @@ -0,0 +1,163 @@ + subroutine dexpm1(ia,n,a,ea,iea,w,iw,ierr) +c +c!purpose +c compute the exponential of a matrix a by the pade's +c approximants(subroutine pade).a block diagonalization +c is performed prior call pade. +c!calling sequence +c subroutine dexpm1(ia,n,a,ea,iea,w,iw,ierr) +c +c integer ia,n,iw,ierr +c double precision a,ea,w +c dimension a(ia,n),ea(iea,n),w(*),iw(*) +c +c ia: the leading dimension of array a. +c n: the order of the matrices a,ea,x,xi . +c a: the real double precision array that contains the n*n matrix a +c ea: the array that contains the n*n exponential of a. +c iea : the leading dimension of array ea +c w : work space array of size: n*(2*ia+2*n+5) +c iw : integer work space array of size 2*n +c ierr: =0 if the prosessus is normal. +c =-1 if n>ia. +c =-2 if the block diagonalization is not possible. +c =-4 if the subroutine dpade can not computes exp(a) +c +c!auxiliary routines +c exp abs sqrt dble real (fortran) +c bdiag (eispack.extension) +c balanc balinv (eispack) +c dmmul (blas.extension) +c pade +c! originator +c j roche laboratoire d'automatique de grenoble +c! + integer ia,n,iw,ierr + double precision a,ea,w + dimension a(ia,*),ea(iea,*),w(*),iw(*) +c internal variables +c + integer i,j,k,ni,nii,ndng + double precision anorm,alpha,bvec,bbvec,rn,zero,c(41) + logical fail +c +cDEC$ IF DEFINED (FORDLL) +cDEC$ ATTRIBUTES DLLIMPORT:: /dcoeff/ +cDEC$ ENDIF + common /dcoeff/ c,ndng + data zero /0.0d+0/ + ndng=-1 +c + ierr=0 + kscal=1 + kx=kscal+n + kxi=kx+n*ia + ker=kxi+n*ia + kei=ker+n + kw=kei+n +c + kbs=1 + kiw=kbs+n +c + if (n.gt.ia) go to 110 +c +c balance the matrix a +c +c +c compute the norm one of a. +c + anorm = 0.0d+0 + do 20 j=1,n + alpha = zero + do 10 i=1,n + alpha = alpha + abs(a(i,j)) + 10 continue + if (alpha.gt.anorm) anorm = alpha + 20 continue + if (anorm.eq.0.0d0) then +c null matrix special case (Serge Steer 96) + do 21 j=1,n + call dset(n,0.0d+0,ea(j,1),iea) + ea(j,j)=1.0d0 + 21 continue + return + endif + anorm=max(anorm,1.0d0) +c +c call bdiag whith rmax equal to the norm one of matrix a. +c + call bdiag(ia,n,a,0.0d+0,anorm,w(ker),w(kei), + * iw(kbs),w(kx),w(kxi),w(kscal),1,fail) + if (fail) go to 120 + do 25 j=1,n + call dset(n,0.0d+0,ea(j,1),iea) + 25 continue +c +c compute the pade's approximants of the block. +c block origin is shifted before calling pade. +c + ni = 1 + k = 0 +c +c loop on the block. +c + 30 k = k + ni + if (k.gt.n) go to 100 + ni = iw(kbs-1+k) + if (ni.eq.1) go to 90 + nii = k + ni - 1 + bvec = zero + do 40 i=k,nii + bvec = bvec + w(ker-1+i) + 40 continue + bvec = bvec/dble(real(ni)) + do 50 i=k,nii + w(ker-1+i) = w(ker-1+i) - bvec + a(i,i) = a(i,i) - bvec + 50 continue + alpha = zero + do 60 i=k,nii + rn = w(ker-1+i)**2 + w(kei-1+i)**2 + rn = sqrt(rn) + if (rn.gt.alpha) alpha = rn + 60 continue +c +c call pade subroutine. +c + call pade(a(k,k),ia,ni,ea(k,k),iea,alpha,w(kw),iw(kiw), + 1 ierr) + if (ierr.lt.0) go to 130 +c +c remove the effect of origin shift on the block. +c + bbvec = exp(bvec) + do 80 i=k,nii + do 70 j=k,nii + ea(i,j) = ea(i,j)*bbvec + 70 continue + 80 continue + go to 30 + 90 ea(k,k) = exp(a(k,k)) + go to 30 +c +c end of loop. +c + 100 continue +c +c remove the effect of block diagonalization. +c + call dmmul(w(kx),ia,ea,iea,w(kw),n,n,n,n) + call dmmul(w(kw),n,w(kxi),ia,ea,iea,n,n,n) +c +c remove the effects of balance +c +c +c error output +c + go to 130 + 110 ierr = -1 + go to 130 + 120 ierr = -2 + 130 continue + return + end diff --git a/modules/elementary_functions/src/fortran/dexpm1.lo b/modules/elementary_functions/src/fortran/dexpm1.lo new file mode 100755 index 000000000..ab0d2223b --- /dev/null +++ b/modules/elementary_functions/src/fortran/dexpm1.lo @@ -0,0 +1,12 @@ +# src/fortran/dexpm1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dexpm1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/dipow.f b/modules/elementary_functions/src/fortran/dipow.f new file mode 100755 index 000000000..3b71ec431 --- /dev/null +++ b/modules/elementary_functions/src/fortran/dipow.f @@ -0,0 +1,72 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) 1989 - INRIA - Serge STEER +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine dipow(n,v,iv,ipow,ierr) +c!but +c eleve a une puissance entiere les elements d'un vecteur de flottants +c double precision +c!liste d'appel +c subroutine dipow(n,v,iv,ipow,ierr) +c integer n,iv,ipow ,ierr +c double precision v(n*iv) +c +c n : nombre d'element du vecteur +c v : tableau contenant les elements du vecteur +c iv : increment entre deux element consecutif du vecteur dans le +c tableau v +c ipow : puissance a la quelle doivent etre eleves les elements du +c vecteur +c ierr : indicateur d'erreur +c ierr=0 si ok +c ierr=1 si 0**0 +c ierr=2 si 0**k avec k<0 +c!origine +c Serge Steer INRIA 1989 +c + integer n,iv,ipow ,ierr + double precision v(*) +c + ierr=0 +c + if(ipow.eq.1) return + if(ipow.eq.0) then +c puissance 0 + ii=1 + do 10 i=1,n + if(v(ii).ne.0.0d+0) then + v(ii)=1.0d+0 + ii=ii+iv + else + ierr=1 + return + endif + 10 continue + else if(ipow.lt.0) then +c puissance negative + ii=1 + do 20 i=1,n + if(v(ii).ne.0.0d+0) then + v(ii)=v(ii)**ipow + ii=ii+iv + else + ierr=2 + return + endif + 20 continue + else +c puissance positive + ii=1 + do 30 i=1,n + v(ii)=v(ii)**ipow + ii=ii+iv + 30 continue + endif +c + return + end diff --git a/modules/elementary_functions/src/fortran/dipow.lo b/modules/elementary_functions/src/fortran/dipow.lo new file mode 100755 index 000000000..99f66a6ec --- /dev/null +++ b/modules/elementary_functions/src/fortran/dipow.lo @@ -0,0 +1,12 @@ +# src/fortran/dipow.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dipow.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/dipowe.f b/modules/elementary_functions/src/fortran/dipowe.f new file mode 100755 index 000000000..998ca3790 --- /dev/null +++ b/modules/elementary_functions/src/fortran/dipowe.f @@ -0,0 +1,51 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) 1996 - INRIA - Serge STEER +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine dipowe(v,p,r,ierr) +c!purpose +c computes r=v^p where v double precision and p integer +c!calling sequence +c subroutine dipowe(v,p,r,ierr) +c integer p ,ierr +c double precision v,r +c +c ierr : error flag +c ierr=0 if ok +c ierr=1 if 0**0 +c ierr=2 if 0**k with k<0 +c + integer p ,ierr + double precision v,r,infinity +c + ierr=0 +c + if(p.eq.1) then + r=v + elseif(p.eq.0) then +c . v^0 +c if(v.ne.0.0d+0) then + r=1.0d+0 +c else + +c ierr=1 +c endif + else if(p.lt.0) then + if(v.ne.0.0d+0) then + r=v**p + else + r=0.0d0 + r=infinity(r) + ierr=2 + endif + else + r=v**p + endif +c + return + end diff --git a/modules/elementary_functions/src/fortran/dipowe.lo b/modules/elementary_functions/src/fortran/dipowe.lo new file mode 100755 index 000000000..b2a033fe3 --- /dev/null +++ b/modules/elementary_functions/src/fortran/dipowe.lo @@ -0,0 +1,12 @@ +# src/fortran/dipowe.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dipowe.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/dlblks.f b/modules/elementary_functions/src/fortran/dlblks.f new file mode 100755 index 000000000..63fddf6e9 --- /dev/null +++ b/modules/elementary_functions/src/fortran/dlblks.f @@ -0,0 +1,45 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + SUBROUTINE DLBLKS( NAME, NBC) +C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +C +C ENLEVER LES BLANCS EN DEBUT D'UNE CHAINE DE CARACTERES +C +C +C ENTREE : NAME LA CHAINE DE CARACTERES +C +C SORTIE : NAME LA CHAINE SANS LES BLANCS +C NBC NOMBRE DE CARACTERES DE LA CHAINE +C +C FORTRAN INDEX, LEN +C .................................................................... +c + CHARACTER*(*) NAME + INTEGER NBC + INTEGER I,K,J,LL +C + LL = LEN ( NAME ) + I = 0 + 1 I = I + 1 + K = INDEX ( NAME(I:LL) , ' ' ) + IF ( K .EQ. 0 ) K = LL - I + 2 + IF ( K .EQ. 1 .AND. I .LT. LL ) GO TO 1 +C + NBC = K - 1 + I = I - 1 + DO 3 J = 1,NBC + NAME(J:J) = NAME(J+I:J+I) + 3 CONTINUE + DO 5 J = NBC+1,LL + NAME(J:J) = ' ' + 5 CONTINUE +C +C + END diff --git a/modules/elementary_functions/src/fortran/dlblks.lo b/modules/elementary_functions/src/fortran/dlblks.lo new file mode 100755 index 000000000..6c9f75359 --- /dev/null +++ b/modules/elementary_functions/src/fortran/dlblks.lo @@ -0,0 +1,12 @@ +# src/fortran/dlblks.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dlblks.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/dlgama.f b/modules/elementary_functions/src/fortran/dlgama.f new file mode 100755 index 000000000..b157eae19 --- /dev/null +++ b/modules/elementary_functions/src/fortran/dlgama.f @@ -0,0 +1,301 @@ +CS REAL FUNCTION ALGAMA(X) + DOUBLE PRECISION FUNCTION DLGAMA(X) +C---------------------------------------------------------------------- +C +C This routine calculates the LOG(GAMMA) function for a positive real +C argument X. Computation is based on an algorithm outlined in +C references 1 and 2. The program uses rational functions that +C theoretically approximate LOG(GAMMA) to at least 18 significant +C decimal digits. The approximation for X > 12 is from reference +C 3, while approximations for X < 12.0 are similar to those in +C reference 1, but are unpublished. The accuracy achieved depends +C on the arithmetic system, the compiler, the intrinsic functions, +C and proper selection of the machine-dependent constants. +C +C +C********************************************************************* +C********************************************************************* +C +C Explanation of machine-dependent constants +C +C beta - radix for the floating-point representation +C maxexp - the smallest positive power of beta that overflows +C XBIG - largest argument for which LN(GAMMA(X)) is representable +C in the machine, i.e., the solution to the equation +C LN(GAMMA(XBIG)) = beta**maxexp +C XINF - largest machine representable floating-point number; +C approximately beta**maxexp. +C EPS - The smallest positive floating-point number such that +C 1.0+EPS .GT. 1.0 +C FRTBIG - Rough estimate of the fourth root of XBIG +C +C +C Approximate values for some important machines are: +C +C beta maxexp XBIG +C +C CRAY-1 (S.P.) 2 8191 9.62E+2461 +C Cyber 180/855 +C under NOS (S.P.) 2 1070 1.72E+319 +C IEEE (IBM/XT, +C SUN, etc.) (S.P.) 2 128 4.08E+36 +C IEEE (IBM/XT, +C SUN, etc.) (D.P.) 2 1024 2.55D+305 +C IBM 3033 (D.P.) 16 63 4.29D+73 +C VAX D-Format (D.P.) 2 127 2.05D+36 +C VAX G-Format (D.P.) 2 1023 1.28D+305 +C +C +C XINF EPS FRTBIG +C +C CRAY-1 (S.P.) 5.45E+2465 7.11E-15 3.13E+615 +C Cyber 180/855 +C under NOS (S.P.) 1.26E+322 3.55E-15 6.44E+79 +C IEEE (IBM/XT, +C SUN, etc.) (S.P.) 3.40E+38 1.19E-7 1.42E+9 +C IEEE (IBM/XT, +C SUN, etc.) (D.P.) 1.79D+308 2.22D-16 2.25D+76 +C IBM 3033 (D.P.) 7.23D+75 2.22D-16 2.56D+18 +C VAX D-Format (D.P.) 1.70D+38 1.39D-17 1.20D+9 +C VAX G-Format (D.P.) 8.98D+307 1.11D-16 1.89D+76 +C +C************************************************************** +C************************************************************** +C +C Error returns +C +C The program returns the value XINF for X .LE. 0.0 or when +C overflow would occur. The computation is believed to +C be free of underflow and overflow. +C +C +C Intrinsic functions required are: +C +C LOG +C +C +C References: +C +C 1) W. J. Cody and K. E. Hillstrom, 'Chebyshev Approximations for +C the Natural Logarithm of the Gamma Function,' Math. Comp. 21, +C 1967, pp. 198-203. +C +C 2) K. E. Hillstrom, ANL/AMD Program ANLC366S, DGAMMA/DLGAMA, May, +C 1969. +C +C 3) Hart, Et. Al., Computer Approximations, Wiley and sons, New +C York, 1968. +C +C +C Authors: W. J. Cody and L. Stoltz +C Argonne National Laboratory +C +C Latest modification: June 16, 1988 +C +C---------------------------------------------------------------------- +* +* Some modifs from Bruno (25 Feb 2005): +* - return Nan (in place of XINF) if x <= 0 +* - return Inf (in place of XINF) if x > XBIG +* +* In fact an error indicator should be returned in these cases to prevent +* the user... +* + INTEGER I +CS REAL + DOUBLE PRECISION + 1 C,CORR,D1,D2,D4,EPS,FRTBIG,FOUR,HALF,ONE,PNT68,P1,P2,P4, + 2 Q1,Q2,Q4,RES,SQRTPI,THRHAL,TWELVE,TWO,X,XBIG,XDEN,XINF, + 3 XM1,XM2,XM4,XNUM,Y,YSQ,ZERO + DIMENSION C(7),P1(8),P2(8),P4(8),Q1(8),Q2(8),Q4(8) +C---------------------------------------------------------------------- +C Mathematical constants +C---------------------------------------------------------------------- +CS DATA ONE,HALF,TWELVE,ZERO/1.0E0,0.5E0,12.0E0,0.0E0/, +CS 1 FOUR,THRHAL,TWO,PNT68/4.0E0,1.5E0,2.0E0,0.6796875E0/, +CS 2 SQRTPI/0.9189385332046727417803297E0/ + DATA ONE,HALF,TWELVE,ZERO/1.0D0,0.5D0,12.0D0,0.0D0/, + 1 FOUR,THRHAL,TWO,PNT68/4.0D0,1.5D0,2.0D0,0.6796875D0/, + 2 SQRTPI/0.9189385332046727417803297D0/ +C---------------------------------------------------------------------- +C Machine dependent parameters +C---------------------------------------------------------------------- +CS DATA XBIG,XINF,EPS,FRTBIG/4.08E36,3.401E38,1.19E-7,1.42E9/ + DATA XBIG,XINF,EPS,FRTBIG/2.55D305,1.79D308,2.22D-16,2.25D76/ +C---------------------------------------------------------------------- +C Numerator and denominator coefficients for rational minimax +C approximation over (0.5,1.5). +C---------------------------------------------------------------------- +CS DATA D1/-5.772156649015328605195174E-1/ +CS DATA P1/4.945235359296727046734888E0,2.018112620856775083915565E2, +CS 1 2.290838373831346393026739E3,1.131967205903380828685045E4, +CS 2 2.855724635671635335736389E4,3.848496228443793359990269E4, +CS 3 2.637748787624195437963534E4,7.225813979700288197698961E3/ +CS DATA Q1/6.748212550303777196073036E1,1.113332393857199323513008E3, +CS 1 7.738757056935398733233834E3,2.763987074403340708898585E4, +CS 2 5.499310206226157329794414E4,6.161122180066002127833352E4, +CS 3 3.635127591501940507276287E4,8.785536302431013170870835E3/ + DATA D1/-5.772156649015328605195174D-1/ + DATA P1/4.945235359296727046734888D0,2.018112620856775083915565D2, + 1 2.290838373831346393026739D3,1.131967205903380828685045D4, + 2 2.855724635671635335736389D4,3.848496228443793359990269D4, + 3 2.637748787624195437963534D4,7.225813979700288197698961D3/ + DATA Q1/6.748212550303777196073036D1,1.113332393857199323513008D3, + 1 7.738757056935398733233834D3,2.763987074403340708898585D4, + 2 5.499310206226157329794414D4,6.161122180066002127833352D4, + 3 3.635127591501940507276287D4,8.785536302431013170870835D3/ +C---------------------------------------------------------------------- +C Numerator and denominator coefficients for rational minimax +C Approximation over (1.5,4.0). +C---------------------------------------------------------------------- +CS DATA D2/4.227843350984671393993777E-1/ +CS DATA P2/4.974607845568932035012064E0,5.424138599891070494101986E2, +CS 1 1.550693864978364947665077E4,1.847932904445632425417223E5, +CS 2 1.088204769468828767498470E6,3.338152967987029735917223E6, +CS 3 5.106661678927352456275255E6,3.074109054850539556250927E6/ +CS DATA Q2/1.830328399370592604055942E2,7.765049321445005871323047E3, +CS 1 1.331903827966074194402448E5,1.136705821321969608938755E6, +CS 2 5.267964117437946917577538E6,1.346701454311101692290052E7, +CS 3 1.782736530353274213975932E7,9.533095591844353613395747E6/ + DATA D2/4.227843350984671393993777D-1/ + DATA P2/4.974607845568932035012064D0,5.424138599891070494101986D2, + 1 1.550693864978364947665077D4,1.847932904445632425417223D5, + 2 1.088204769468828767498470D6,3.338152967987029735917223D6, + 3 5.106661678927352456275255D6,3.074109054850539556250927D6/ + DATA Q2/1.830328399370592604055942D2,7.765049321445005871323047D3, + 1 1.331903827966074194402448D5,1.136705821321969608938755D6, + 2 5.267964117437946917577538D6,1.346701454311101692290052D7, + 3 1.782736530353274213975932D7,9.533095591844353613395747D6/ +C---------------------------------------------------------------------- +C Numerator and denominator coefficients for rational minimax +C Approximation over (4.0,12.0). +C---------------------------------------------------------------------- +CS DATA D4/1.791759469228055000094023E0/ +CS DATA P4/1.474502166059939948905062E4,2.426813369486704502836312E6, +CS 1 1.214755574045093227939592E8,2.663432449630976949898078E9, +CS 2 2.940378956634553899906876E10,1.702665737765398868392998E11, +CS 3 4.926125793377430887588120E11,5.606251856223951465078242E11/ +CS DATA Q4/2.690530175870899333379843E3,6.393885654300092398984238E5, +CS 2 4.135599930241388052042842E7,1.120872109616147941376570E9, +CS 3 1.488613728678813811542398E10,1.016803586272438228077304E11, +CS 4 3.417476345507377132798597E11,4.463158187419713286462081E11/ + DATA D4/1.791759469228055000094023D0/ + DATA P4/1.474502166059939948905062D4,2.426813369486704502836312D6, + 1 1.214755574045093227939592D8,2.663432449630976949898078D9, + 2 2.940378956634553899906876D10,1.702665737765398868392998D11, + 3 4.926125793377430887588120D11,5.606251856223951465078242D11/ + DATA Q4/2.690530175870899333379843D3,6.393885654300092398984238D5, + 2 4.135599930241388052042842D7,1.120872109616147941376570D9, + 3 1.488613728678813811542398D10,1.016803586272438228077304D11, + 4 3.417476345507377132798597D11,4.463158187419713286462081D11/ +C---------------------------------------------------------------------- +C Coefficients for minimax approximation over (12, INF). +C---------------------------------------------------------------------- +CS DATA C/-1.910444077728E-03,8.4171387781295E-04, +CS 1 -5.952379913043012E-04,7.93650793500350248E-04, +CS 2 -2.777777777777681622553E-03,8.333333333333333331554247E-02, +CS 3 5.7083835261E-03/ + DATA C/-1.910444077728D-03,8.4171387781295D-04, + 1 -5.952379913043012D-04,7.93650793500350248D-04, + 2 -2.777777777777681622553D-03,8.333333333333333331554247D-02, + 3 5.7083835261D-03/ +C---------------------------------------------------------------------- + Y = X + IF ((Y .GT. ZERO) .AND. (Y .LE. XBIG)) THEN + IF (Y .LE. EPS) THEN + RES = -LOG(Y) + ELSE IF (Y .LE. THRHAL) THEN +C---------------------------------------------------------------------- +C EPS .LT. X .LE. 1.5 +C---------------------------------------------------------------------- + IF (Y .LT. PNT68) THEN + CORR = -LOG(Y) + XM1 = Y + ELSE + CORR = ZERO + XM1 = (Y - HALF) - HALF + END IF + IF ((Y .LE. HALF) .OR. (Y .GE. PNT68)) THEN + XDEN = ONE + XNUM = ZERO + DO 140 I = 1, 8 + XNUM = XNUM*XM1 + P1(I) + XDEN = XDEN*XM1 + Q1(I) + 140 CONTINUE + RES = CORR + (XM1 * (D1 + XM1*(XNUM/XDEN))) + ELSE + XM2 = (Y - HALF) - HALF + XDEN = ONE + XNUM = ZERO + DO 220 I = 1, 8 + XNUM = XNUM*XM2 + P2(I) + XDEN = XDEN*XM2 + Q2(I) + 220 CONTINUE + RES = CORR + XM2 * (D2 + XM2*(XNUM/XDEN)) + END IF + ELSE IF (Y .LE. FOUR) THEN +C---------------------------------------------------------------------- +C 1.5 .LT. X .LE. 4.0 +C---------------------------------------------------------------------- + XM2 = Y - TWO + XDEN = ONE + XNUM = ZERO + DO 240 I = 1, 8 + XNUM = XNUM*XM2 + P2(I) + XDEN = XDEN*XM2 + Q2(I) + 240 CONTINUE + RES = XM2 * (D2 + XM2*(XNUM/XDEN)) + ELSE IF (Y .LE. TWELVE) THEN +C---------------------------------------------------------------------- +C 4.0 .LT. X .LE. 12.0 +C---------------------------------------------------------------------- + XM4 = Y - FOUR + XDEN = -ONE + XNUM = ZERO + DO 340 I = 1, 8 + XNUM = XNUM*XM4 + P4(I) + XDEN = XDEN*XM4 + Q4(I) + 340 CONTINUE + RES = D4 + XM4*(XNUM/XDEN) + ELSE +C---------------------------------------------------------------------- +C Evaluate for argument .GE. 12.0, +C---------------------------------------------------------------------- + RES = ZERO + IF (Y .LE. FRTBIG) THEN + RES = C(7) + YSQ = Y * Y + DO 450 I = 1, 6 + RES = RES / YSQ + C(I) + 450 CONTINUE + END IF + RES = RES/Y + CORR = LOG(Y) + RES = RES + SQRTPI - HALF*CORR + RES = RES + Y*(CORR-ONE) + END IF + ELSE +C---------------------------------------------------------------------- +C Return for bad arguments +C---------------------------------------------------------------------- +* modif from Bruno (see comment at the beginning) +* RES = XINF + if (X .le. 0.d0) then + CALL returnananfortran(RES) + else +C this means that X > XBIG and so that log(gamma) overflows +C bad trick to get Inf + RES = 2*XINF + endif +* end modif + END IF +C---------------------------------------------------------------------- +C Final adjustments and return +C---------------------------------------------------------------------- +CS ALGAMA = RES + DLGAMA = RES + RETURN +C ---------- Last line of DLGAMA ---------- + END + + diff --git a/modules/elementary_functions/src/fortran/dlgama.lo b/modules/elementary_functions/src/fortran/dlgama.lo new file mode 100755 index 000000000..5b3af2439 --- /dev/null +++ b/modules/elementary_functions/src/fortran/dlgama.lo @@ -0,0 +1,12 @@ +# src/fortran/dlgama.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dlgama.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/dmcopy.f b/modules/elementary_functions/src/fortran/dmcopy.f new file mode 100755 index 000000000..77f40c2d5 --- /dev/null +++ b/modules/elementary_functions/src/fortran/dmcopy.f @@ -0,0 +1,51 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine dmcopy(a,na,b,nb,m,n) +c!but +c ce sous programme effectue:b=a +c avec a matrice m lignes et n colonnes +c mcopy utilise un code particulier si les matrices sont +c compactes +c!liste d'appel +c +c subroutine dmcopy(a,na,b,nb,m,n) +c double precision a(na,n),b(nb,m) +c integer na,nb,m,n +c +c a tableau contenant la matrice a +c na nombre de lignes du tableau a dans le prog appelant +c b,nb definition similaires a :a,na +c m nombre de lignes des matrices a et b +c n nombre de colonnes des matrices a et b +c!sous programmes utilises +c neant +c + double precision a(*),b(*) + integer na,nb,m,n + integer ia,ib,i,j,mn +c + if(na.eq.m .and. nb.eq.m) goto 20 + ia=-na + ib=-nb + do 10 j=1,n + ia=ia+na + ib=ib+nb + do 10 i=1,m + b(ib+i)=a(ia+i) + 10 continue + return + 20 continue +c code pour des matrices compactes + mn=m*n + do 30 i=1,mn + b(i)=a(i) + 30 continue + return + end diff --git a/modules/elementary_functions/src/fortran/dmcopy.lo b/modules/elementary_functions/src/fortran/dmcopy.lo new file mode 100755 index 000000000..3de781433 --- /dev/null +++ b/modules/elementary_functions/src/fortran/dmcopy.lo @@ -0,0 +1,12 @@ +# src/fortran/dmcopy.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dmcopy.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/dmmul.f b/modules/elementary_functions/src/fortran/dmmul.f new file mode 100755 index 000000000..f75fa93b9 --- /dev/null +++ b/modules/elementary_functions/src/fortran/dmmul.f @@ -0,0 +1,42 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + subroutine dmmul(A , na, B, nb, C, nc, l, m, n) +* +* PURPOSE +* computes the matrix product C = A * B +* C = A * B +* (l,n) (l,m) * (m,n) +* +* PARAMETERS +* input +* ----- +* A : (double) array (l, m) with leading dim na +* +* B : (double) array (m, n) with leading dim nb +* +* na, nb, nc, l, m, n : integers +* +* output +* ------ +* C : (double) array (l, n) with leading dim nc +* +* NOTE +* (original version substituted by a call to the blas dgemm) + + implicit none + + integer na, nb, nc, l, m, n + double precision A(na,m), B(nb,n), C(nc,n) + + call dgemm('n','n', l, n, m, 1.d0, A, na, B, nb, 0.d0, C, nc) + + end + + diff --git a/modules/elementary_functions/src/fortran/dmmul.lo b/modules/elementary_functions/src/fortran/dmmul.lo new file mode 100755 index 000000000..afe8a710c --- /dev/null +++ b/modules/elementary_functions/src/fortran/dmmul.lo @@ -0,0 +1,12 @@ +# src/fortran/dmmul.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dmmul.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/dmmul1.f b/modules/elementary_functions/src/fortran/dmmul1.f new file mode 100755 index 000000000..23d248984 --- /dev/null +++ b/modules/elementary_functions/src/fortran/dmmul1.f @@ -0,0 +1,43 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine dmmul1(a,na,b,nb,c,nc,l,m,n) +c!but +c ce sous programme effectue le produit matriciel: +c c=c+a*b . +c!liste d'appel +c +c subroutine dmmul1(a,na,b,nb,c,nc,l,m,n) +c double precision a(na,m),b(nb,n),c(nc,n) +c integer na,nb,nc,l,m,n +c +c a tableau de taille na*m contenant la matrice a +c na nombre de lignes du tableau a dans le programme appel +c b,nb,c,nc definitions similaires a celles de a,na +c l nombre de ligne des matrices a et c +c m nombre de colonnes de a et de lignes de b +c n nombre de colonnes de b et c +c!sous programmes utilises +c neant +c + double precision a(*),b(*),c(*) + double precision ddot + integer na,nb,nc,l,m,n + integer i,j,ib,ic +c + ib=1 + ic=0 + do 30 j=1,n + do 20 i=1,l + 20 c(ic+i)=c(ic+i)+ddot(m,a(i),na,b(ib),1) + ic=ic+nc + ib=ib+nb + 30 continue + return + end diff --git a/modules/elementary_functions/src/fortran/dmmul1.lo b/modules/elementary_functions/src/fortran/dmmul1.lo new file mode 100755 index 000000000..a98f41aff --- /dev/null +++ b/modules/elementary_functions/src/fortran/dmmul1.lo @@ -0,0 +1,12 @@ +# src/fortran/dmmul1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dmmul1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/dmprod.f b/modules/elementary_functions/src/fortran/dmprod.f new file mode 100755 index 000000000..f3dcc3ee7 --- /dev/null +++ b/modules/elementary_functions/src/fortran/dmprod.f @@ -0,0 +1,66 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine dmprod(flag,a,na,m,n,v,nv) +c!purpose +c computes the product of the entries of a matrix according to flag +c!calling sequence +c subroutine dmprod(flag,a,na,m,n,v,nv) +c double precision a(na,n),v(*) +c integer na,n,m,nv +c integer flag +c!parameters +c flag : indicates operation to perform +c 0 : returns in v(1) the product of all entries of a +c 1 : returns in v(j) the product of jth column of a +c 2 : returns in v(i) the product of ith row of a +c a : array containing the a matrix +c na : a matrix leading dimension +c m : a matrix row dimension +c n : a matrix column dimension +c v : array containing the result, may be confused with a row or +c a column of the a matrix +c if flag==0 size(v)>=1 +c if flag==1 size(v)>=n*nv +c if flag==1 size(v)>=m*nv +c nv : increment between to consecutive entries ov v +c + double precision a(na,n),v(nv) + integer na,n,m,nv + integer flag +c + double precision t + integer iv +c + iv=1 + if(flag.eq.0) then +c product of all the entries + t=1.0d0 +c do 10 j=1,n +c call dvmul(m,a(1,j),1,t,0) +c 10 continue + call dvmul(m*n,a(1,1),1,t,0) + v(1)=t + elseif(flag.eq.1) then + do 20 j=1,n + t=1.0d0 + call dvmul(m,a(1,j),1,t,0) + v(iv)=t + iv=iv+nv + 20 continue + elseif(flag.eq.2) then + do 30 i=1,m + t=1.0d0 + call dvmul(n,a(i,1),m,t,0) + v(iv)=t + iv=iv+nv + 30 continue + endif + return + end diff --git a/modules/elementary_functions/src/fortran/dmprod.lo b/modules/elementary_functions/src/fortran/dmprod.lo new file mode 100755 index 000000000..a9f721333 --- /dev/null +++ b/modules/elementary_functions/src/fortran/dmprod.lo @@ -0,0 +1,12 @@ +# src/fortran/dmprod.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dmprod.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/dmsum.f b/modules/elementary_functions/src/fortran/dmsum.f new file mode 100755 index 000000000..95aec8665 --- /dev/null +++ b/modules/elementary_functions/src/fortran/dmsum.f @@ -0,0 +1,64 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine dmsum(flag,a,na,m,n,v,nv) +c!purpose +c computes the sum of the entries of a matrix according to flag +c!calling sequence +c subroutine dmsum(flag,a,na,m,n,v,nv) +c double precision a(na,n),v(*) +c integer na,n,m,nv +c integer flag +c!parameters +c flag : indicates operation to perform +c 0 : returns in v(1) the sum of all entries of a +c 1 : returns in v(j) the sum of jth column of a +c 2 : returns in v(i) the sum of ith row of a +c a : array containing the a matrix +c na : a matrix leading dimension +c m : a matrix row dimension +c n : a matrix column dimension +c v : array containing the result, may be confused with a row or +c a column of the a matrix +c if flag==0 size(v)>=1 +c if flag==1 size(v)>=n*nv +c if flag==1 size(v)>=m*nv +c nv : increment between to consecutive entries ov v +c + double precision a(na,n),v(nv) + integer na,n,m,nv + integer flag +c + double precision t,dsum + integer iv +c + iv=1 + if(flag.eq.0) then + v(1) = dsum(m*n,a(1,1),1) +c sum of all the entries +c t=0.0d0 +c do 10 j=1,n +c t=t+dsum(m,a(1,j),1) +c 10 continue +c v(1)=t + elseif(flag.eq.1) then + do 20 j=1,n + t=dsum(m,a(1,j),1) + v(iv)=t + iv=iv+nv + 20 continue + elseif(flag.eq.2) then + do 30 i=1,m + t=dsum(n,a(i,1),m) + v(iv)=t + iv=iv+nv + 30 continue + endif + return + end diff --git a/modules/elementary_functions/src/fortran/dmsum.lo b/modules/elementary_functions/src/fortran/dmsum.lo new file mode 100755 index 000000000..d901bf7f6 --- /dev/null +++ b/modules/elementary_functions/src/fortran/dmsum.lo @@ -0,0 +1,12 @@ +# src/fortran/dmsum.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dmsum.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/drdiv.f b/modules/elementary_functions/src/fortran/drdiv.f new file mode 100755 index 000000000..435749858 --- /dev/null +++ b/modules/elementary_functions/src/fortran/drdiv.f @@ -0,0 +1,60 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine drdiv(a,ia,b,ib,r,ir,n,ierr) +c! purpose +c computes r=a./b with a and b real +c +c ia,ib,ir : increment between two consecutive element of vectors a +c b and r +c n : vectors length +c ierr : returned error flag: +c o : ok +c <>0 : b(ierr)=0 +c + double precision a(*),b(*),r(*) + integer ia,ib,ir,n + jr=1 + jb=1 + ja=1 + k=0 + ierr=0 + if (ia.eq.0) then + do 10 k=1,n + if(b(jb).eq.0.0d0) then + ierr=k + return + endif + r(jr)=a(ja)/b(jb) + jr=jr+ir + jb=jb+ib + 10 continue + elseif(ib.eq.0) then + if(b(jb).eq.0.0d0) then + ierr=1 + return + endif + do 11 k=1,n + r(jr)=a(ja)/b(jb) + jr=jr+ir + ja=ja+ia + 11 continue + else + do 12 k=1,n + if(b(jb).eq.0.0d0) then + ierr=k + return + endif + r(jr)=a(ja)/b(jb) + jr=jr+ir + jb=jb+ib + ja=ja+ia + 12 continue + endif + end diff --git a/modules/elementary_functions/src/fortran/drdiv.lo b/modules/elementary_functions/src/fortran/drdiv.lo new file mode 100755 index 000000000..51abcb3e5 --- /dev/null +++ b/modules/elementary_functions/src/fortran/drdiv.lo @@ -0,0 +1,12 @@ +# src/fortran/drdiv.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/drdiv.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/dsearch.f b/modules/elementary_functions/src/fortran/dsearch.f new file mode 100755 index 000000000..d66678e97 --- /dev/null +++ b/modules/elementary_functions/src/fortran/dsearch.f @@ -0,0 +1,155 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) Bruno Pincon +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + subroutine dsearchc(X, m, val, n, indX, occ, info) +* +* +* PURPOSE +* val(0..n) being an array (with strict increasing order and n >=1) +* representing intervals, this routine, by the mean of a +* dichotomic search, computes : +* +* a/ for each X(i) its interval number indX(i) : +* indX(i) = j if X(i) in (val(j-1), val(j)] +* = 1 if X(i) = val(0) +* = 0 if X(i) is not in [val(0),val(n)] +* +* b/ the number of points falling in the interval j : +* +* occ(j) = # { X(i) such that X(i) in (val(j-1), val(j)] } for j>1 +* and occ(1) = # { X(i) such that X(i) in [val(0), val(1)] } +* +* PARAMETERS +* inputs : +* m integer +* X(1..m) double float array +* n integer +* val(0..n) double float array (val(0) < val(1) < ....) +* outputs +* indX(1..m) integer array +* occ(1..n) integer array +* info integer (number of X(i) not in [val(0), val(n)]) +* +* AUTHOR +* Bruno Pincon +* + implicit none + integer m, n, info + double precision X(m), val(0:n) + integer occ(n), indX(m) + + integer i, j1, j2, j + + do j = 1, n + occ(j) = 0 + enddo + + info = 0 + + do i = 1, m + if ( val(0) .le. X(i) .and. X(i) .le. val(n) ) then +* X(i) is in [val(0),val(n)] : +* find j such that val(j-1) <= X(i) <= val(j) by a dicho search + j1 = 0 + j2 = n + do while ( j2 - j1 .gt. 1 ) + j = (j1 + j2)/2 + if ( X(i) .le. val(j) ) then + j2 = j + else + j1 = j + endif + enddo +* we have val(j1) < X(i) <= val(j2) if j2 > 1 (j1=j2-1) +* or val(j1) <= X(i) <= val(j2) if j2 = 1 (j1=j2-1) +* so that j2 is the good interval number in all cases + occ(j2) = occ(j2) + 1 + indX(i) = j2 + else ! X(i) is not in [val(0), val(n)] + info = info + 1 + indX(i) = 0 + endif + enddo + + end +* +************************************************************************** +* + subroutine dsearchd(X, m, val, n, indX, occ, info) +* +* PURPOSE +* val(1..n) being a strictly increasing array, this +* routines by the mean of a dichotomic search computes : +* +* a/ the number of occurences (occ(j)) of each value val(j) +* in the array X : +* +* occ(j) = #{ X(i) such that X(i) = val(j) } +* +* b/ the array indX : if X(i) = val(j) then indX(i) = j +* (if X(i) is not in val then indX(i) = 0) +* +* PARAMETERS +* inputs : +* m integer +* X(1..m) double float array +* n integer +* val(1..n) double float array (must be in a strict increasing order) +* outputs : +* occ(1..n) integer array +* indX(1..m) integer array +* info integer (number of X(i) which are not in val(1..n)) +* +* AUTHOR +* Bruno Pincon +* + implicit none + integer m, n, info + double precision X(m), val(n) + integer occ(n), indX(m) + + integer i, j1, j2, j + + do j = 1, n + occ(j) = 0 + enddo + + info = 0 + + do i = 1, m + if ( val(1) .le. X(i) .and. X(i) .le. val(n) ) then +* find j such that X(i) = val(j) by a dicho search + j1 = 1 + j2 = n + do while ( j2 - j1 .gt. 1 ) + j = (j1 + j2)/2 + if ( X(i) .lt. val(j) ) then + j2 = j + else + j1 = j + endif + enddo +* here we know that val(j1) <= X(i) <= val(j2) with j2 = j1 + 1 +* (in fact we have exactly val(j1) <= X(i) < val(j2) if j2 < n) + if (X(i) .eq. val(j1)) then + occ(j1) = occ(j1) + 1 + indX(i) = j1 + else if (X(i) .eq. val(j2)) then ! (note: this case may happen only for j2=n) + occ(j2) = occ(j2) + 1 + indX(i) = j2 + else ! X(i) is not in {val(1), val(2),..., val(n)} + info = info + 1 + indX(i) = 0 + endif + else ! X(i) is not in {val(1), val(2),..., val(n)} + info = info + 1 + indX(i) = 0 + endif + enddo + + end diff --git a/modules/elementary_functions/src/fortran/dsearch.lo b/modules/elementary_functions/src/fortran/dsearch.lo new file mode 100755 index 000000000..fdd6b7fa9 --- /dev/null +++ b/modules/elementary_functions/src/fortran/dsearch.lo @@ -0,0 +1,12 @@ +# src/fortran/dsearch.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dsearch.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/dset.f b/modules/elementary_functions/src/fortran/dset.f new file mode 100755 index 000000000..555435781 --- /dev/null +++ b/modules/elementary_functions/src/fortran/dset.f @@ -0,0 +1,34 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine dset(n,dx,dy,incy) +c!but +c dset affecte un scalaire a tous les elements d'un vecteur +c!liste d'appel +c subroutine dset(n,dx,dy,incy) +c double precision dx,dy(n*incy) +c integer n,incy +c +c n : nombre d'elements du vecteur dy +c dx : scalaire a affecter +c dy : tableau contenant le vecteur +c incy : increment entre deux elements consecutifs du vecteur y +c dans le tableau dy +c + double precision dx,dy(*) +c + if (n.le.0) return + iy = 1 + if (incy.lt.0) iy = (-n+1)*incy + 1 + do 10 i = 1,n + dy(iy) = dx + iy = iy + incy + 10 continue + return + end diff --git a/modules/elementary_functions/src/fortran/dset.lo b/modules/elementary_functions/src/fortran/dset.lo new file mode 100755 index 000000000..bbf603d7b --- /dev/null +++ b/modules/elementary_functions/src/fortran/dset.lo @@ -0,0 +1,12 @@ +# src/fortran/dset.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dset.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/dsort.f b/modules/elementary_functions/src/fortran/dsort.f new file mode 100755 index 000000000..a1a81673f --- /dev/null +++ b/modules/elementary_functions/src/fortran/dsort.f @@ -0,0 +1,141 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c +C/MEMBR ADD NAME=DSORT,SSI=0 +c + subroutine dsort(count,n,index) +c +c!purpose +c dsort sort double precision array,maintaining an index array +c +c!calling sequence +c subroutine dsort(count,n,index) +c integer n,index(n) +c double precision count(n) +c +c count : array to be sorted +c n :size of count and index +c index : array containing on return index of sorted array +c +c!method +c quick sort metjod is used +c!restriction +c n must be less than 2**(50/2) ! due to lengh of work space mark +c! + dimension mark(50),index(n) + double precision count(n),av,x +c set index array to original order . + do 10 i=1,n + index(i)=i + 10 continue +c check that a trivial case has not been entered . + if(n.eq.1)goto 200 + if(n.ge.1)go to 30 + goto 200 +c 'm' is the length of segment which is short enough to enter +c the final sorting routine. it may be easily changed. + 30 m=12 +c set up initial values. + la=2 + is=1 + if=n + do 190 mloop=1,n +c if segment is short enough sort with final sorting routine . + ifka=if-is + if((ifka+1).gt.m)goto 70 +c********* final sorting *** +c ( a simple bubble sort ) + is1=is+1 + do 60 j=is1,if + i=j + 40 if(count(i-1).gt.count(i))goto 60 + if(count(i-1).lt.count(i))goto 50 + if(index(i-1).lt.index(i))goto 60 + 50 av=count(i-1) + count(i-1)=count(i) + count(i)=av + int=index(i-1) + index(i-1)=index(i) + index(i)=int + i=i-1 + if(i.gt.is)goto 40 + 60 continue + la=la-2 + goto 170 +c ******* quicksort ******** +c select the number in the central position in the segment as +c the test number.replace it with the number from the segment's +c highest address. + 70 iy=(is+if)/2 + x=count(iy) + intest=index(iy) + count(iy)=count(if) + index(iy)=index(if) +c the markers 'i' and 'ifk' are used for the beginning and end +c of the section not so far tested against the present value +c of x . + k=1 + ifk=if +c we alternate between the outer loop that increases i and the +c inner loop that reduces ifk, moving numbers and indices as +c necessary, until they meet . + do 110 i=is,if + if(x.lt.count(i))goto 110 + if(x.gt.count(i))goto 80 + if(intest.gt.index(i))goto 110 + 80 if(i.ge.ifk)goto 120 + count(ifk)=count(i) + index(ifk)=index(i) + k1=k + do 100 k=k1,ifka + ifk=if-k + if(count(ifk).lt.x)goto 100 + if(count(ifk).gt.x)goto 90 + if(intest.le.index(ifk))goto 100 + 90 if(i.ge.ifk)goto 130 + count(i)=count(ifk) + index(i)=index(ifk) + go to 110 + 100 continue + goto 120 + 110 continue +c return the test number to the position marked by the marker +c which did not move last. it divides the initial segment into +c 2 parts. any element in the first part is less than or equal +c to any element in the second part, and they may now be sorted +c independently . + 120 count(ifk)=x + index(ifk)=intest + ip=ifk + goto 140 + 130 count(i)=x + index(i)=intest + ip=i +c store the longer subdivision in workspace. + 140 if((ip-is).gt.(if-ip))goto 150 + mark(la)=if + mark(la-1)=ip+1 + if=ip-1 + goto 160 + 150 mark(la)=ip-1 + mark(la-1)=is + is=ip+1 +c find the length of the shorter subdivision. + 160 lngth=if-is + if(lngth.le.0)goto 180 +c if it contains more than one element supply it with workspace . + la=la+2 + goto 190 + 170 if(la.le.0)goto 200 +c obtain the address of the shortest segment awaiting quicksort + 180 if=mark(la) + is=mark(la-1) + 190 continue + 200 return + end diff --git a/modules/elementary_functions/src/fortran/dsort.lo b/modules/elementary_functions/src/fortran/dsort.lo new file mode 100755 index 000000000..6fbff6b00 --- /dev/null +++ b/modules/elementary_functions/src/fortran/dsort.lo @@ -0,0 +1,12 @@ +# src/fortran/dsort.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dsort.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/dsum.f b/modules/elementary_functions/src/fortran/dsum.f new file mode 100755 index 000000000..7057a9698 --- /dev/null +++ b/modules/elementary_functions/src/fortran/dsum.f @@ -0,0 +1,58 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) 1986 - INRIA - Serge STEER +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c +C/MEMBR ADD NAME=DSUM,SSI=0 +c + double precision function dsum(n,dx,incx) +c +c!but +c +c cette fonction donne la somme des n composantes d'un vecteur dx. +c +c!liste d'appel +c +c double precision function dsum(n,dx,incx) +c +c n: entier, taille du vecteur dx. +c +c dx: double precision, vecteur dont on veut la somme +c +c incx: increment entre deux composantes consecutives de dx. +c +c!auteur +c +c serge Steer ,inria 86 +c! +c + double precision dx(*),dtemp + integer i,incx,n,nincx +c + dsum = 0.0d+0 + dtemp = 0.0d+0 + if(n.le.0)return + if(incx.eq.1)go to 20 +c +c code for increment not equal to 1 +c + nincx = n*incx + do 10 i = 1,nincx,incx + dtemp = dtemp + dx(i) + 10 continue + dsum = dtemp + return +c +c code for increment equal to 1 +c + 20 continue + do 30 i = 1,n + dtemp = dtemp + dx(i) + 30 continue + dsum = dtemp +c + end diff --git a/modules/elementary_functions/src/fortran/dsum.lo b/modules/elementary_functions/src/fortran/dsum.lo new file mode 100755 index 000000000..094f7b5d7 --- /dev/null +++ b/modules/elementary_functions/src/fortran/dsum.lo @@ -0,0 +1,12 @@ +# src/fortran/dsum.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dsum.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/dtild.f b/modules/elementary_functions/src/fortran/dtild.f new file mode 100755 index 000000000..976cec4a4 --- /dev/null +++ b/modules/elementary_functions/src/fortran/dtild.f @@ -0,0 +1,48 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) 1986 - INRIA - Serge STEER +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c +C/MEMBR ADD NAME=DTILD,SSI=0 +c + subroutine dtild(n,x,incx) +c!but +c +c cette subroutine inverse l'ordre des elements d'un +c vecteur x +c +c!liste d'appel +c +c subroutine dtild(n,x,incx) +c +c n: taille du vecteur dx +c +c x: double precision, vecteur +c +c incx: increment entre les composantes du vecteur. +c +c!auteur +c +c serge Steer Inria 1986 +c +c! +c + double precision x(*),xx + integer i,incx,i1,i2,n +c + if(n.le.1)return + i1=1 + i2=n*incx + do 10 i=1,n/2 + xx=x(i1) + x(i1)=x(i2) + x(i2)=xx + i1=i1+incx + i2=i2-incx + 10 continue + return + end diff --git a/modules/elementary_functions/src/fortran/dtild.lo b/modules/elementary_functions/src/fortran/dtild.lo new file mode 100755 index 000000000..804205b64 --- /dev/null +++ b/modules/elementary_functions/src/fortran/dtild.lo @@ -0,0 +1,12 @@ +# src/fortran/dtild.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dtild.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/dvmul.f b/modules/elementary_functions/src/fortran/dvmul.f new file mode 100755 index 000000000..235b0048f --- /dev/null +++ b/modules/elementary_functions/src/fortran/dvmul.f @@ -0,0 +1,60 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA - Serge STEER +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine dvmul(n,dx,incx,dy,incy) +c!but +c +c etant donne un vecteur dx et un vecteur dy, +c cette subroutine fait: +c dy = dy * dx +c quand les deux increments sont egaux a un, cette +c subroutine emploie des boucles "epanouis". dans le cas ou +c les increments sont negatifs, cette subroutine prend +c les composantes en ordre inverse. +c +c!liste d'appel +c +c subroutine dvmul(n,dx,incx,dy,incy) +c +c dy, dx: vecteurs double precision. +c +c incx, incy: increments entre deux composantes succesives +c des vecteurs. +c +c!auteur +c +c serge steer inria +c + double precision dx(*),dy(*) + integer i,incx,incy,ix,iy,n +c + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments not equal to 1 +c + 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) * dx(ix) + ix = ix + incx + iy = iy + incy + 10 continue + return +c +c code for both increments equal to 1 +c + 20 continue + do 30 i = 1,n + dy(i) = dy(i) * dx(i) + 30 continue +c + end diff --git a/modules/elementary_functions/src/fortran/dvmul.lo b/modules/elementary_functions/src/fortran/dvmul.lo new file mode 100755 index 000000000..0d9ee503e --- /dev/null +++ b/modules/elementary_functions/src/fortran/dvmul.lo @@ -0,0 +1,12 @@ +# src/fortran/dvmul.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dvmul.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/dwdiv.f b/modules/elementary_functions/src/fortran/dwdiv.f new file mode 100755 index 000000000..5947ee142 --- /dev/null +++ b/modules/elementary_functions/src/fortran/dwdiv.f @@ -0,0 +1,57 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA - Serge STEER +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine dwdiv(ar,br,bi,cr,ci,ierr) +c!but +c +c This subroutine dwdiv computes c=a/b where a is a real number and +c b a complex number +c +c!Calling sequence +c +c subroutine dwdiv(ar,br,bi,cr,ci,ierr) +c +c ar : double precision. +c +c br, bi: double precision, b real and complex parts. +c +c cr, ci: double precision, c real and complex parts. +c +c!author +c +c Serge Steer INRIA +c + double precision ar,br,bi,cr,ci +c c = a/b + double precision s,d,ars,brs,bis +c + ierr=0 + if(bi.eq.0.0d0) then + cr=ar/br + ci=0.0d0 + elseif(br.eq.0.0d0) then + ci=-ar/bi + cr=0.0d0 + else + s = abs(br) + abs(bi) + if (s .eq. 0.0d+0) then + ierr=1 + cr=ar/s + ci=0.0d0 + return + endif + ars = ar/s + brs = br/s + bis = bi/s + d = brs**2 + bis**2 + cr = (ars*brs)/d + ci = (-ars*bis)/d + endif + return + end diff --git a/modules/elementary_functions/src/fortran/dwdiv.lo b/modules/elementary_functions/src/fortran/dwdiv.lo new file mode 100755 index 000000000..2c9a3dcbd --- /dev/null +++ b/modules/elementary_functions/src/fortran/dwdiv.lo @@ -0,0 +1,12 @@ +# src/fortran/dwdiv.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dwdiv.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/dwpow.f b/modules/elementary_functions/src/fortran/dwpow.f new file mode 100755 index 000000000..b395d6cb3 --- /dev/null +++ b/modules/elementary_functions/src/fortran/dwpow.f @@ -0,0 +1,67 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) 1989 - INRIA - Serge STEER +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine dwpow(n,vr,vi,iv,powr,powi,ierr) +c!but +c eleve les elements d'un vecteur reel a une puissance complexe +c!liste d'appel +c subroutine dwpow(n,vr,vi,iv,powr,powi,ierr) +c integer n,iv,ierr +c double precision vr(n*iv),vi(n*iv),powr,powi +c +c n : nombre d'elements du vecteur +c vr : tableau contenant les elements du vecteur +c vi : tableau contenant en retour les parties imaginaires du resultat +c iv : increment entre deux element consecutif du vecteur dans le +c tableau v +c powr : partie reelle de la puissance a la quelle doivent etre +c eleves les elements du vecteur +c powi : partie imaginaire de la puissance a la quelle doivent etre +c eleves les elements du vecteur +c ierr : indicateur d'erreur +c ierr=0 si ok +c ierr=1 si 0**0 +c ierr=2 si 0**k avec k<0 +c!origine +c Serge Steer INRIA 1989 +c + integer n,iv,ierr + double precision vr(*),vi(*),powr,powi,sr,si +c + ierr=0 +c + if(powi.ne.0.0d+0) goto 01 +c puissance reelle + call ddpow(n,vr,vi,iv,powr,ierr,iscmpl) + return +c + 01 continue +c puissance complexes + ii=1 + do 20 i=1,n + if(vr(ii).ne.0.0d+0) then + sr=vr(ii)**powr + si=log(vr(ii))*powi + vr(ii)=sr*cos(si) + vi(ii)=sr*sin(si) + ii=ii+iv + else + if(powr.gt.0.0d+0) then + vr(ii)=0.0d+0 + vi(ii)=0.0d+0 + ii=ii+iv + else + ierr=2 + return + endif + endif + 20 continue +c + return + end diff --git a/modules/elementary_functions/src/fortran/dwpow.lo b/modules/elementary_functions/src/fortran/dwpow.lo new file mode 100755 index 000000000..fa3c0279d --- /dev/null +++ b/modules/elementary_functions/src/fortran/dwpow.lo @@ -0,0 +1,12 @@ +# src/fortran/dwpow.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dwpow.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/dwpow1.f b/modules/elementary_functions/src/fortran/dwpow1.f new file mode 100755 index 000000000..206d94f3d --- /dev/null +++ b/modules/elementary_functions/src/fortran/dwpow1.f @@ -0,0 +1,59 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) 1996 - INRIA - Serge STEER +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine dwpow1(n,v,iv,pr,pi,ip,rr,ri,ir,ierr) +c!purpose +c computes V^P with V real vector and P complex vector +c!calling sequence +c subroutine dwpow1(n,v,iv,pr,pi,ip,rr,ri,ir,ierr) +c integer n,iv,ip,ir,ierr +c double precision v(*),pr(*),pi(*),rr(*),ri(*) +c +c n : number of elements of V and P vectors +c v : array containing V elements +c V(i)=v(1+(i-1)*iv) +c iv : increment between two V elements in v (may be 0) +c pr : array containing real part of P elements +c real(P(i))=pr(1+(i-1)*iv) +c pi : array containing imaginary part of P elements +c imag(P(i))=pi(1+(i-1)*iv) +c ip : increment between two P elements in p (may be 0) +c rr : array containing real part of the results vector R: +c real(R(i))=rr(1+(i-1)*ir) +c ri : array containing imaginary part of the results vector R: +c imag(R(i))=ri(1+(i-1)*ir) +c ir : increment between two R elements in rr and ri +c ierr : error flag +c ierr=0 if ok +c ierr=1 if 0**0 +c ierr=2 if 0**k with k<0 +c!origin +c Serge Steer INRIA 1996 +c + integer n,iv,ierr,ierr1 + double precision v(*),pr(*),pi(*),rr(*),ri(*) +c + ierr=0 + iscmpl=0 +c + + ii=1 + iip=1 + iir=1 + do 20 i=1,n + call dwpowe(v(ii),pr(iip),pi(iip),rr(iir),ri(iir),ierr1) +c if(ierr.ne.0) return + ierr=max(ierr,ierr1) + ii=ii+iv + iip=iip+ip + iir=iir+ir + 20 continue +c + return + end diff --git a/modules/elementary_functions/src/fortran/dwpow1.lo b/modules/elementary_functions/src/fortran/dwpow1.lo new file mode 100755 index 000000000..005137d02 --- /dev/null +++ b/modules/elementary_functions/src/fortran/dwpow1.lo @@ -0,0 +1,12 @@ +# src/fortran/dwpow1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dwpow1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/dwpowe.f b/modules/elementary_functions/src/fortran/dwpowe.f new file mode 100755 index 000000000..349245670 --- /dev/null +++ b/modules/elementary_functions/src/fortran/dwpowe.f @@ -0,0 +1,60 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) 1996 - INRIA - Serge STEER +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine dwpowe(v,pr,pi,rr,ri,ierr) +c!purose +c computes v^p with v double precision and p complex +c!calling sequence +c subroutine dwpowe(v,pr,pi,rr,ri,ierr) +c integer ierr +c double precision v,pr,pi,rr,ri +c +c pr : exponent real part +c pi : exponent imaginary part +c rr : result's real part +c ri : result's imaginary part +c ierr : error flag +c ierr=0 if ok +c ierr=1 if 0**0 +c ierr=2 if 0**k with k<0 +c!origin +c Serge Steer INRIA 1996 +c + integer ierr + double precision v,pr,pi,sr,si,rr,ri,infinity +c + ierr=0 +c + if(pi.eq.0.0d+0) then +c p real + call ddpowe(v,pr,rr,ri,ierr,iscmpl) + else + if(v.ne.0.0d+0) then + call wlog(v,0.0d0,sr,si) + call wmul(sr,si,pr,pi,sr,si) + sr=exp(sr) + rr=sr*cos(si) + ri=sr*sin(si) + else + if(pr.gt.0.0d+0) then + rr=0.0d+0 + ri=0.0d+0 + elseif(pr.lt.0.0d+0) then + ri=0.0d+0 + rr=infinity(ri) + ierr=2 + else + rr=1.0d+0 + ri=0.0d+0 + endif + endif + endif +c + return + end diff --git a/modules/elementary_functions/src/fortran/dwpowe.lo b/modules/elementary_functions/src/fortran/dwpowe.lo new file mode 100755 index 000000000..25a56d531 --- /dev/null +++ b/modules/elementary_functions/src/fortran/dwpowe.lo @@ -0,0 +1,12 @@ +# src/fortran/dwpowe.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dwpowe.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/dwrdiv.f b/modules/elementary_functions/src/fortran/dwrdiv.f new file mode 100755 index 000000000..9a88c736c --- /dev/null +++ b/modules/elementary_functions/src/fortran/dwrdiv.f @@ -0,0 +1,70 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine dwrdiv(ar,ia,br,bi,ib,rr,ri,ir,n,ierr) +c! purpose +c computes r=a./b with a complex vector and b real vector +c +c ia,ib,ir : increment between two consecutive element of vectors a +c b and r +c ar : array containing a +c br,bi : arrays containing b real and imaginary parts +c rr,ri : arrays containing r real and imaginary parts +c n : vectors length +c ierr : returned error flag: +c o : ok +c <>0 : b(ierr)=0 +c + double precision ar(*),br(*),bi(*),rr(*),ri(*) +c wr, wi used because rr, ri may share same mem as ar,ai or br,bi + double precision wr,wi + integer ia,ib,ir,n + jr=1 + jb=1 + ja=1 + ierr=0 + if (ia.eq.0) then + do 10 k=1,n + call dwdiv(ar(ja),br(jb),bi(jb),wr,wi,ierr1) + rr(jr)=wr + ri(jr)=wi + if(ierr1.ne.0) then + ierr=k +c return + endif + jr=jr+ir + jb=jb+ib + 10 continue + elseif(ib.eq.0) then + if(abs(br(jb))+abs(bi(jb)).eq.0.0d0) then + ierr=1 +c return + endif + do 11 k=1,n + call dwdiv(ar(ja),br(jb),bi(jb),wr,wi,ierr1) + rr(jr)=wr + ri(jr)=wi + jr=jr+ir + ja=ja+ia + 11 continue + else + do 12 k=1,n + call dwdiv(ar(ja),br(jb),bi(jb),wr,wi,ierr1) + rr(jr)=wr + ri(jr)=wi + if(ierr1.ne.0) then + ierr=k +c return + endif + jr=jr+ir + jb=jb+ib + ja=ja+ia + 12 continue + endif + end diff --git a/modules/elementary_functions/src/fortran/dwrdiv.lo b/modules/elementary_functions/src/fortran/dwrdiv.lo new file mode 100755 index 000000000..1c1d1b2e1 --- /dev/null +++ b/modules/elementary_functions/src/fortran/dwrdiv.lo @@ -0,0 +1,12 @@ +# src/fortran/dwrdiv.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dwrdiv.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/eispack/.deps/.dirstamp b/modules/elementary_functions/src/fortran/eispack/.deps/.dirstamp new file mode 100755 index 000000000..e69de29bb --- /dev/null +++ b/modules/elementary_functions/src/fortran/eispack/.deps/.dirstamp diff --git a/modules/elementary_functions/src/fortran/eispack/.dirstamp b/modules/elementary_functions/src/fortran/eispack/.dirstamp new file mode 100755 index 000000000..e69de29bb --- /dev/null +++ b/modules/elementary_functions/src/fortran/eispack/.dirstamp diff --git a/modules/elementary_functions/src/fortran/eispack/.libs/balbak.o b/modules/elementary_functions/src/fortran/eispack/.libs/balbak.o Binary files differnew file mode 100755 index 000000000..1af005cef --- /dev/null +++ b/modules/elementary_functions/src/fortran/eispack/.libs/balbak.o diff --git a/modules/elementary_functions/src/fortran/eispack/.libs/hqror2.o b/modules/elementary_functions/src/fortran/eispack/.libs/hqror2.o Binary files differnew file mode 100755 index 000000000..0045d5733 --- /dev/null +++ b/modules/elementary_functions/src/fortran/eispack/.libs/hqror2.o diff --git a/modules/elementary_functions/src/fortran/eispack/balbak.f b/modules/elementary_functions/src/fortran/eispack/balbak.f new file mode 100755 index 000000000..e65c7146c --- /dev/null +++ b/modules/elementary_functions/src/fortran/eispack/balbak.f @@ -0,0 +1,80 @@ + subroutine balbak(nm,n,low,igh,scale,m,z) +c + integer i,j,k,m,n,ii,nm,igh,low + double precision scale(n),z(nm,m) + double precision s +c! purpose +c +c this subroutine forms the eigenvectors of a real general +c matrix by back transforming those of the corresponding +c balanced matrix determined by balanc. +c +c! calling sequence +c +c subroutine balbak(nm,n,low,igh,scale,m,z) +c +c on input: +c +c nm must be set to the row dimension of two-dimensional +c array parameters as declared in the calling program +c dimension statement; +c +c n is the order of the matrix; +c +c low and igh are integers determined by balanc; +c +c scale contains information determining the permutations +c and scaling factors used by balanc; +c +c m is the number of columns of z to be back transformed; +c +c z contains the real and imaginary parts of the eigen- +c vectors to be back transformed in its first m columns. +c +c on output: +c +c z contains the real and imaginary parts of the +c transformed eigenvectors in its first m columns. +c +c! originator +c +c this subroutine is a translation of the algol procedure balbak, +c num. math. 13, 293-304(1969) by parlett and reinsch. +c handbook for auto. comp., vol.ii-linear algebra, 315-326(1971). +c! +c questions and comments should be directed to b. s. garbow, +c applied mathematics division, argonne national laboratory +c +c ------------------------------------------------------------------ +c + if (m .eq. 0) go to 200 + if (igh .eq. low) go to 120 +c + do 110 i = low, igh + s = scale(i) +c :::::::::: left hand eigenvectors are back transformed +c if the foregoing statement is replaced by +c s=1.0d+0/scale(i). :::::::::: + do 100 j = 1, m + 100 z(i,j) = z(i,j) * s +c + 110 continue +c ::::::::: for i=low-1 step -1 until 1, +c igh+1 step 1 until n do -- :::::::::: + 120 do 140 ii = 1, n + i = ii + if (i .ge. low .and. i .le. igh) go to 140 + if (i .lt. low) i = low - ii + k = scale(i) + if (k .eq. i) go to 140 +c + do 130 j = 1, m + s = z(i,j) + z(i,j) = z(k,j) + z(k,j) = s + 130 continue +c + 140 continue +c + 200 return + end diff --git a/modules/elementary_functions/src/fortran/eispack/balbak.lo b/modules/elementary_functions/src/fortran/eispack/balbak.lo new file mode 100755 index 000000000..a96328404 --- /dev/null +++ b/modules/elementary_functions/src/fortran/eispack/balbak.lo @@ -0,0 +1,12 @@ +# src/fortran/eispack/balbak.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/balbak.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/eispack/eispack_f.rc b/modules/elementary_functions/src/fortran/eispack/eispack_f.rc new file mode 100755 index 000000000..f2a323c42 --- /dev/null +++ b/modules/elementary_functions/src/fortran/eispack/eispack_f.rc @@ -0,0 +1,96 @@ +// Microsoft Visual C++ generated resource script. +// + + +#define APSTUDIO_READONLY_SYMBOLS +///////////////////////////////////////////////////////////////////////////// +// +// Generated from the TEXTINCLUDE 2 resource. +// +//#include "afxres.h" +#define APSTUDIO_HIDDEN_SYMBOLS +#include "windows.h" +///////////////////////////////////////////////////////////////////////////// +#undef APSTUDIO_READONLY_SYMBOLS + +///////////////////////////////////////////////////////////////////////////// +// French (France) resources + +#if !defined(AFX_RESOURCE_DLL) || defined(AFX_TARG_FRA) +#ifdef _WIN32 +LANGUAGE LANG_FRENCH, SUBLANG_FRENCH +#pragma code_page(1252) +#endif //_WIN32 + +#ifdef APSTUDIO_INVOKED +///////////////////////////////////////////////////////////////////////////// +// +// TEXTINCLUDE +// + +1 TEXTINCLUDE +BEGIN + "resource.h\0" +END + +3 TEXTINCLUDE +BEGIN + "\r\n" + "\0" +END + +#endif // APSTUDIO_INVOKED + + +///////////////////////////////////////////////////////////////////////////// +// +// Version +// + +VS_VERSION_INFO VERSIONINFO + FILEVERSION 5,5,2,0 + PRODUCTVERSION 5,5,2,0 + FILEFLAGSMASK 0x17L +#ifdef _DEBUG + FILEFLAGS 0x1L +#else + FILEFLAGS 0x0L +#endif + FILEOS 0x4L + FILETYPE 0x2L + FILESUBTYPE 0x0L +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "040c04b0" + BEGIN + VALUE "FileDescription", "eispack library" + VALUE "FileVersion", "5, 5, 2, 0" + VALUE "InternalName", "eispack library for scilab 5.x" + VALUE "LegalCopyright", "Copyright (C) 2017" + VALUE "OriginalFilename", "eispack.dll" + VALUE "ProductName", "eispack library for scilab 5.x" + VALUE "ProductVersion", "5, 5, 2, 0" + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x40c, 1200 + END +END + +#endif // French (France) resources +///////////////////////////////////////////////////////////////////////////// + + + +#ifndef APSTUDIO_INVOKED +///////////////////////////////////////////////////////////////////////////// +// +// Generated from the TEXTINCLUDE 3 resource. +// + + +///////////////////////////////////////////////////////////////////////////// +#endif // not APSTUDIO_INVOKED + diff --git a/modules/elementary_functions/src/fortran/eispack/eispack_f.vfproj b/modules/elementary_functions/src/fortran/eispack/eispack_f.vfproj new file mode 100755 index 000000000..bcdf5fc6a --- /dev/null +++ b/modules/elementary_functions/src/fortran/eispack/eispack_f.vfproj @@ -0,0 +1,83 @@ +<?xml version="1.0" encoding="UTF-8"?> +<VisualStudioProject ProjectType="typeDynamicLibrary" ProjectCreator="Intel Fortran" Keyword="Dll" Version="11.0" ProjectIdGuid="{96248E56-C84A-4803-9F50-25E2089AB6B8}"> + <Platforms> + <Platform Name="Win32"/> + <Platform Name="x64"/></Platforms> + <Configurations> + <Configuration Name="Debug|Win32" OutputDirectory="$(SolutionDir)bin\" IntermediateDirectory="$(ProjectDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary"> + <Tool Name="VFFortranCompilerTool" SuppressStartupBanner="true" DebugInformationFormat="debugEnabled" Optimization="optimizeDisabled" AdditionalIncludeDirectories="../../../../core/includes" PreprocessorDefinitions="WIN32;FORDLL" AlternateParameterSyntax="false" F77RuntimeCompatibility="true" FPS4Libs="false" CallingConvention="callConventionCRef" ExternalNameUnderscore="true" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" RuntimeLibrary="rtMultiThreadedDebugDLL"/> + <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin\$(ProjectName).dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" ModuleDefinitionFile="eispack_f.def" GenerateDebugInformation="true" SubSystem="subSystemWindows" ImportLibrary="$(SolutionDir)bin\$(ProjectName).lib" LinkDLL="true" AdditionalDependencies="../../../../../bin/lapack.lib"/> + <Tool Name="VFResourceCompilerTool"/> + <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/> + <Tool Name="VFCustomBuildTool"/> + <Tool Name="VFPreLinkEventTool" CommandLine="setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .." Description="Build $(ProjectName).def"/> + <Tool Name="VFPreBuildEventTool"/> + <Tool Name="VFPostBuildEventTool"/> + <Tool Name="VFManifestTool" SuppressStartupBanner="true"/></Configuration> + <Configuration Name="Release|Win32" OutputDirectory="$(SolutionDir)bin\" IntermediateDirectory="$(ProjectDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary"> + <Tool Name="VFFortranCompilerTool" SuppressStartupBanner="true" AdditionalIncludeDirectories="../../../../core/includes" PreprocessorDefinitions="WIN32;FORDLL" AlternateParameterSyntax="false" F77RuntimeCompatibility="true" FPS4Libs="false" CallingConvention="callConventionCRef" ExternalNameUnderscore="true" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" RuntimeLibrary="rtMultiThreadedDLL"/> + <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin\$(ProjectName).dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" ModuleDefinitionFile="eispack_f.def" SubSystem="subSystemWindows" ImportLibrary="$(SolutionDir)bin\$(ProjectName).lib" LinkDLL="true" AdditionalDependencies="../../../../../bin/lapack.lib"/> + <Tool Name="VFResourceCompilerTool"/> + <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/> + <Tool Name="VFCustomBuildTool"/> + <Tool Name="VFPreLinkEventTool" CommandLine="setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .." Description="Build $(ProjectName).def"/> + <Tool Name="VFPreBuildEventTool"/> + <Tool Name="VFPostBuildEventTool"/> + <Tool Name="VFManifestTool" SuppressStartupBanner="true"/></Configuration> + <Configuration Name="Debug|x64" OutputDirectory="$(SolutionDir)bin\" IntermediateDirectory="$(ProjectDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary"> + <Tool Name="VFFortranCompilerTool" SuppressStartupBanner="true" DebugInformationFormat="debugEnabled" Optimization="optimizeDisabled" AdditionalIncludeDirectories="../../../../core/includes" PreprocessorDefinitions="WIN32;FORDLL" AlternateParameterSyntax="false" F77RuntimeCompatibility="true" FPS4Libs="false" CallingConvention="callConventionCRef" ExternalNameUnderscore="true" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" RuntimeLibrary="rtMultiThreadedDebugDLL"/> + <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin\$(ProjectName).dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" ModuleDefinitionFile="eispack_f.def" GenerateDebugInformation="true" SubSystem="subSystemWindows" ImportLibrary="$(SolutionDir)bin\$(ProjectName).lib" LinkDLL="true" AdditionalDependencies="../../../../../bin/lapack.lib"/> + <Tool Name="VFResourceCompilerTool"/> + <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/> + <Tool Name="VFCustomBuildTool"/> + <Tool Name="VFPreLinkEventTool" CommandLine="setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .." Description="Build $(ProjectName).def"/> + <Tool Name="VFPreBuildEventTool"/> + <Tool Name="VFPostBuildEventTool"/> + <Tool Name="VFManifestTool" SuppressStartupBanner="true"/></Configuration> + <Configuration Name="Release|x64" OutputDirectory="$(SolutionDir)bin\" IntermediateDirectory="$(ProjectDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary"> + <Tool Name="VFFortranCompilerTool" SuppressStartupBanner="true" AdditionalIncludeDirectories="../../../../core/includes" PreprocessorDefinitions="WIN32;FORDLL" AlternateParameterSyntax="false" F77RuntimeCompatibility="true" FPS4Libs="false" CallingConvention="callConventionCRef" ExternalNameUnderscore="true" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" RuntimeLibrary="rtMultiThreadedDLL"/> + <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin\$(ProjectName).dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" ModuleDefinitionFile="eispack_f.def" SubSystem="subSystemWindows" ImportLibrary="$(SolutionDir)bin\$(ProjectName).lib" LinkDLL="true" AdditionalDependencies="../../../../../bin/lapack.lib"/> + <Tool Name="VFResourceCompilerTool"/> + <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/> + <Tool Name="VFCustomBuildTool"/> + <Tool Name="VFPreLinkEventTool" CommandLine="setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .." Description="Build $(ProjectName).def"/> + <Tool Name="VFPreBuildEventTool"/> + <Tool Name="VFPostBuildEventTool"/> + <Tool Name="VFManifestTool" SuppressStartupBanner="true"/></Configuration></Configurations> + <Files> + <Filter Name="Header Files" Filter="fi;fd"/> + <Filter Name="Library dependencies"/> + <Filter Name="Resource Files" Filter="rc;ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe"> + <File RelativePath=".\eispack_f.rc"/></Filter> + <Filter Name="Source Files" Filter="f90;for;f;fpp;ftn;def;odl;idl"> + <File RelativePath=".\balbak.f"/> + <File RelativePath=".\hqror2.f"/></Filter></Files> + <Globals/></VisualStudioProject> diff --git a/modules/elementary_functions/src/fortran/eispack/eispack_f2c.vcxproj b/modules/elementary_functions/src/fortran/eispack/eispack_f2c.vcxproj new file mode 100755 index 000000000..3c0609376 --- /dev/null +++ b/modules/elementary_functions/src/fortran/eispack/eispack_f2c.vcxproj @@ -0,0 +1,268 @@ +<?xml version="1.0" encoding="utf-8"?> +<Project DefaultTargets="Build" ToolsVersion="4.0" xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <ItemGroup Label="ProjectConfigurations"> + <ProjectConfiguration Include="Debug|Win32"> + <Configuration>Debug</Configuration> + <Platform>Win32</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Debug|x64"> + <Configuration>Debug</Configuration> + <Platform>x64</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Release|Win32"> + <Configuration>Release</Configuration> + <Platform>Win32</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Release|x64"> + <Configuration>Release</Configuration> + <Platform>x64</Platform> + </ProjectConfiguration> + </ItemGroup> + <PropertyGroup Label="Globals"> + <ProjectName>eispack_f</ProjectName> + <ProjectGuid>{96248E56-C84A-4803-9F50-25E2089AB6B8}</ProjectGuid> + <RootNamespace>eispack_f2c</RootNamespace> + <Keyword>Win32Proj</Keyword> + </PropertyGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.Default.props" /> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>Unicode</CharacterSet> + <WholeProgramOptimization>true</WholeProgramOptimization> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>Unicode</CharacterSet> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>Unicode</CharacterSet> + <WholeProgramOptimization>true</WholeProgramOptimization> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>Unicode</CharacterSet> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.props" /> + <ImportGroup Label="ExtensionSettings"> + <Import Project="..\..\..\..\..\Visual-Studio-settings\f2c.props" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <PropertyGroup Label="UserMacros" /> + <PropertyGroup> + <_ProjectFileVersion>10.0.30319.1</_ProjectFileVersion> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">true</LinkIncremental> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">true</LinkIncremental> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">false</LinkIncremental> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Release|x64'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Release|x64'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Release|x64'">false</LinkIncremental> + </PropertyGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'"> + <PreBuildEvent> + <Message> + </Message> + <Command> + </Command> + </PreBuildEvent> + <ClCompile> + <Optimization>Disabled</Optimization> + <AdditionalIncludeDirectories>../../../../../libs/f2c;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>WIN32;_DEBUG;_WINDOWS;_USRDLL;EISPACK_F2C_EXPORTS;FORDLL;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDebugDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + </ClCompile> + <PreLinkEvent> + <Message>Build $(ProjectName).def</Message> + <Command>setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .. +</Command> + </PreLinkEvent> + <Link> + <AdditionalDependencies>../../../../../bin/libf2c.lib;../../../../../bin/lapack.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <ModuleDefinitionFile>eispack_f.def</ModuleDefinitionFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX86</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + <LinkTimeCodeGeneration>Default</LinkTimeCodeGeneration> + </Link> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'"> + <PreBuildEvent> + <Message> + </Message> + <Command> + </Command> + </PreBuildEvent> + <Midl> + <TargetEnvironment>X64</TargetEnvironment> + </Midl> + <ClCompile> + <Optimization>Disabled</Optimization> + <AdditionalIncludeDirectories>../../../../../libs/f2c;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>WIN32;_DEBUG;_WINDOWS;_USRDLL;EISPACK_F2C_EXPORTS;FORDLL;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDebugDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + </ClCompile> + <PreLinkEvent> + <Message>Build $(ProjectName).def</Message> + <Command>setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .. +</Command> + </PreLinkEvent> + <Link> + <AdditionalDependencies>../../../../../bin/libf2c.lib;../../../../../bin/lapack.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <ModuleDefinitionFile>eispack_f.def</ModuleDefinitionFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX64</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + <LinkTimeCodeGeneration>Default</LinkTimeCodeGeneration> + </Link> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'"> + <PreBuildEvent> + <Message> + </Message> + <Command> + </Command> + </PreBuildEvent> + <ClCompile> + <WholeProgramOptimization>false</WholeProgramOptimization> + <AdditionalIncludeDirectories>../../../../../libs/f2c;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>WIN32;NDEBUG;_WINDOWS;_USRDLL;EISPACK_F2C_EXPORTS;FORDLL;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + <MultiProcessorCompilation>true</MultiProcessorCompilation> + </ClCompile> + <PreLinkEvent> + <Message>Build $(ProjectName).def</Message> + <Command>setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .. +</Command> + </PreLinkEvent> + <Link> + <AdditionalDependencies>../../../../../bin/libf2c.lib;../../../../../bin/lapack.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <ModuleDefinitionFile>eispack_f.def</ModuleDefinitionFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <OptimizeReferences>true</OptimizeReferences> + <EnableCOMDATFolding>true</EnableCOMDATFolding> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX86</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + <LinkTimeCodeGeneration>Default</LinkTimeCodeGeneration> + </Link> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'"> + <PreBuildEvent> + <Message> + </Message> + <Command> + </Command> + </PreBuildEvent> + <Midl> + <TargetEnvironment>X64</TargetEnvironment> + </Midl> + <ClCompile> + <WholeProgramOptimization>false</WholeProgramOptimization> + <AdditionalIncludeDirectories>../../../../../libs/f2c;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>WIN32;NDEBUG;_WINDOWS;_USRDLL;EISPACK_F2C_EXPORTS;FORDLL;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + <MultiProcessorCompilation>true</MultiProcessorCompilation> + </ClCompile> + <PreLinkEvent> + <Message>Build $(ProjectName).def</Message> + <Command>setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .. +</Command> + </PreLinkEvent> + <Link> + <AdditionalDependencies>../../../../../bin/libf2c.lib;../../../../../bin/lapack.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <ModuleDefinitionFile>eispack_f.def</ModuleDefinitionFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <OptimizeReferences>true</OptimizeReferences> + <EnableCOMDATFolding>true</EnableCOMDATFolding> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX64</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + <LinkTimeCodeGeneration>Default</LinkTimeCodeGeneration> + </Link> + </ItemDefinitionGroup> + <ItemGroup> + <ClCompile Include="balbak.c" /> + <ClCompile Include="hqror2.c" /> + </ItemGroup> + <ItemGroup> + <f2c_rule Include="balbak.f" /> + <f2c_rule Include="hqror2.f" /> + </ItemGroup> + <ItemGroup> + <ProjectReference Include="..\..\..\..\..\tools\Dumpexts\Dumpexts.vcxproj"> + <Project>{3170e4c2-1173-4264-a222-7ee8ccb3ddf7}</Project> + <ReferenceOutputAssembly>false</ReferenceOutputAssembly> + </ProjectReference> + </ItemGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.targets" /> + <ImportGroup Label="ExtensionTargets"> + <Import Project="..\..\..\..\..\Visual-Studio-settings\f2c.targets" /> + </ImportGroup> +</Project>
\ No newline at end of file diff --git a/modules/elementary_functions/src/fortran/eispack/eispack_f2c.vcxproj.filters b/modules/elementary_functions/src/fortran/eispack/eispack_f2c.vcxproj.filters new file mode 100755 index 000000000..2da6bdddd --- /dev/null +++ b/modules/elementary_functions/src/fortran/eispack/eispack_f2c.vcxproj.filters @@ -0,0 +1,39 @@ +<?xml version="1.0" encoding="utf-8"?> +<Project ToolsVersion="4.0" xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <ItemGroup> + <Filter Include="Source Files"> + <UniqueIdentifier>{4FC737F1-C7A5-4376-A066-2A32D752A2FF}</UniqueIdentifier> + <Extensions>cpp;c;cc;cxx;def;odl;idl;hpj;bat;asm;asmx</Extensions> + </Filter> + <Filter Include="Header Files"> + <UniqueIdentifier>{93995380-89BD-4b04-88EB-625FBE52EBFB}</UniqueIdentifier> + <Extensions>h;hpp;hxx;hm;inl;inc;xsd</Extensions> + </Filter> + <Filter Include="Resource Files"> + <UniqueIdentifier>{67DA6AB6-F800-4c08-8B7A-83BB121AAD01}</UniqueIdentifier> + <Extensions>rc;ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe;resx;tiff;tif;png;wav</Extensions> + </Filter> + <Filter Include="Fortran Files"> + <UniqueIdentifier>{c77d7188-05f8-4f96-8960-70e791094670}</UniqueIdentifier> + </Filter> + <Filter Include="Libraries Dependencies"> + <UniqueIdentifier>{ae47bd4c-a08a-4040-9548-238932d156f0}</UniqueIdentifier> + </Filter> + </ItemGroup> + <ItemGroup> + <ClCompile Include="balbak.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="hqror2.c"> + <Filter>Source Files</Filter> + </ClCompile> + </ItemGroup> + <ItemGroup> + <f2c_rule Include="balbak.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="hqror2.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + </ItemGroup> +</Project>
\ No newline at end of file diff --git a/modules/elementary_functions/src/fortran/eispack/hqror2.f b/modules/elementary_functions/src/fortran/eispack/hqror2.f new file mode 100755 index 000000000..e39f5f376 --- /dev/null +++ b/modules/elementary_functions/src/fortran/eispack/hqror2.f @@ -0,0 +1,503 @@ + subroutine hqror2(nm,n,low,igh,h,wr,wi,z,ierr,job) +c + integer i,j,k,l,m,n,en,ll,mm,na,nm, + x igh,itn,its,low,mp2,enm2,ierr,job + double precision h(nm,n),wr(n),wi(n),z(nm,n) + double precision p,q,r,s,t,w,x,y,zz,norm,tst1,tst2,machep,dlamch + logical notlas +c +c this subroutine is a translation of the algol procedure hqr2, +c num. math. 16, 181-204(1970) by peters and wilkinson. +c handbook for auto. comp., vol.ii-linear algebra, 372-395(1971). +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c +c MODIFICATIONS WRT EISPACK VERSION +c --------------------------------- +c 1. 1x1 and 2x2 diagonal blocks are clearly isolated by +c forcing subdiagonal entries to zero +c 2. Merging of hqr/hqr2 driven by a job parameter +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c +c This subroutine finds the eigenvalues of a real upper +c hessenberg matrix by the qr method. In addition, the +c orthogonal transformation leading to the Schur form is +c accumulated +c +c on input +c +c nm must be set to the row dimension of two-dimensional +c array parameters as declared in the calling program +c dimension statement. +c +c n is the order of the matrix. +c +c low and igh are integers determined by the balancing +c subroutine balanc. if balanc has not been used, +c set low=1, igh=n. +c +c h contains the upper hessenberg matrix. +c +c z contains the transformation matrix produced by eltran +c after the reduction by elmhes, or by ortran after the +c reduction by orthes, if performed. if the eigenvectors +c of the hessenberg matrix are desired, z must contain the +c identity matrix. +c +c job has the decimal decomposition xy; +c if x=0 hqror2 compute eigen-decomposition of h +c if x=1 hqror2 computes schur decomposition of h +c if x=2 eigenvalues are computed via schur decomposition +c if y=0 coordinate transformation is not accumulated +c if y=1 coordinate transformation is accumulated +c +c +c on output +c +c h contains the Schur form +c +c wr and wi contain the real and imaginary parts, +c respectively, of the eigenvalues. the eigenvalues +c are unordered except that complex conjugate pairs +c of values appear consecutively with the eigenvalue +c having the positive imaginary part first. if an +c error exit is made, the eigenvalues should be correct +c for indices ierr+1,...,n. +c +c z contains the orthogonal transformation to the real schur +c form. If an error exit is made, z may be incorrect. +c +c ierr is set to +c zero for normal return, +c j if the limit of 30*n iterations is exhausted +c while the j-th eigenvalue is being sought. +c +c calls cdiv for complex division. +c +c questions and comments should be directed to burton s. garbow, +c mathematics and computer science div, argonne national laboratory +c +c this version dated august 1983. +c +c ------------------------------------------------------------------ +c + jx=job/10 + jy=job-10*jx +c + machep=dlamch('p') +c + ierr = 0 + norm = 0.0d0 + k = 1 +c .......... store roots isolated by balanc +c and compute matrix norm .......... + do 50 i = 1, n +c + do 40 j = k, n + 40 norm = norm + dabs(h(i,j)) +c + k = i + if(jx .eq. 1) goto 50 + if (i .ge. low .and. i .le. igh) go to 50 + wr(i) = h(i,i) + wi(i) = 0.0d0 + 50 continue +c + en = igh + t = 0.0d0 + itn = 30*n +c .......... search for next eigenvalues .......... + 60 if (en .lt. low) go to 340 + its = 0 + na = en - 1 + enm2 = na - 1 +c .......... look for single small sub-diagonal element +c for l=en step -1 until low do -- .......... + 70 do 80 ll = low, en + l = en + low - ll + if (l .eq. low) go to 100 + s = dabs(h(l-1,l-1)) + dabs(h(l,l)) + if (s .eq. 0.0d0) s = norm + tst1 = s + tst2 = tst1 + dabs(h(l,l-1)) + if (tst2 .eq. tst1) go to 100 + 80 continue +c .......... form shift .......... + 100 x = h(en,en) + if (l .eq. en) go to 270 + y = h(na,na) + w = h(en,na) * h(na,en) + if (l .eq. na) go to 280 + if (itn .eq. 0) go to 1000 + if (its .ne. 10 .and. its .ne. 20) go to 130 +c .......... form exceptional shift .......... + t = t + x +c + do 120 i = low, en + 120 h(i,i) = h(i,i) - x +c + s = dabs(h(en,na)) + dabs(h(na,enm2)) + x = 0.75d0 * s + y = x + w = -0.4375d0 * s * s + 130 its = its + 1 + itn = itn - 1 +c .......... look for two consecutive small +c sub-diagonal elements. +c for m=en-2 step -1 until l do -- .......... + do 140 mm = l, enm2 + m = enm2 + l - mm + zz = h(m,m) + r = x - zz + s = y - zz + p = (r * s - w) / h(m+1,m) + h(m,m+1) + q = h(m+1,m+1) - zz - r - s + r = h(m+2,m+1) + s = dabs(p) + dabs(q) + dabs(r) + p = p / s + q = q / s + r = r / s + if (m .eq. l) go to 150 + tst1 = dabs(p)*(dabs(h(m-1,m-1)) + dabs(zz) + dabs(h(m+1,m+1))) + tst2 = tst1 + dabs(h(m,m-1))*(dabs(q) + dabs(r)) + if (tst2 .eq. tst1) go to 150 + 140 continue +c + 150 mp2 = m + 2 +c + do 160 i = mp2, en + h(i,i-2) = 0.0d0 + if (i .eq. mp2) go to 160 + h(i,i-3) = 0.0d0 + 160 continue +c .......... double qr step involving rows l to en and +c columns m to en .......... + do 260 k = m, na + notlas = k .ne. na + if (k .eq. m) go to 170 + p = h(k,k-1) + q = h(k+1,k-1) + r = 0.0d0 + if (notlas) r = h(k+2,k-1) + x = dabs(p) + dabs(q) + dabs(r) + if (x .eq. 0.0d0) go to 260 + p = p / x + q = q / x + r = r / x + 170 s = dsign(dsqrt(p*p+q*q+r*r),p) + if (k .eq. m) go to 180 + h(k,k-1) = -s * x + go to 190 + 180 if (l .ne. m) h(k,k-1) = -h(k,k-1) + 190 p = p + s + x = p / s + y = q / s + zz = r / s + q = q / p + r = r / p + if (notlas) go to 225 +c .......... row modification .......... + do 200 j = k, n + p = h(k,j) + q * h(k+1,j) + h(k,j) = h(k,j) - p * x + h(k+1,j) = h(k+1,j) - p * y + 200 continue +c + j = min0(en,k+3) +c .......... column modification .......... + do 210 i = 1, j + p = x * h(i,k) + y * h(i,k+1) + h(i,k) = h(i,k) - p + h(i,k+1) = h(i,k+1) - p * q + 210 continue + if(jy .eq. 1) then +c .......... accumulate transformations .......... + do 220 i = low, igh + p = x * z(i,k) + y * z(i,k+1) + z(i,k) = z(i,k) - p + z(i,k+1) = z(i,k+1) - p * q + 220 continue + endif + go to 255 + 225 continue +c .......... row modification .......... + do 230 j = k, n + p = h(k,j) + q * h(k+1,j) + r * h(k+2,j) + h(k,j) = h(k,j) - p * x + h(k+1,j) = h(k+1,j) - p * y + h(k+2,j) = h(k+2,j) - p * zz + 230 continue +c + j = min0(en,k+3) +c .......... column modification .......... + do 240 i = 1, j + p = x * h(i,k) + y * h(i,k+1) + zz * h(i,k+2) + h(i,k) = h(i,k) - p + h(i,k+1) = h(i,k+1) - p * q + h(i,k+2) = h(i,k+2) - p * r + 240 continue + if(jy .eq. 1) then +c .......... accumulate transformations .......... + do 250 i = low, igh + p = x * z(i,k) + y * z(i,k+1) + zz * z(i,k+2) + z(i,k) = z(i,k) - p + z(i,k+1) = z(i,k+1) - p * q + z(i,k+2) = z(i,k+2) - p * r + 250 continue + endif + 255 continue +c + 260 continue +c + go to 70 +c .......... one root found .......... + 270 h(en,en) = x + t + +ccccc ADDED TO MARK BLOCK SEPARATION BY HARD ZEROS + if(en+1.le.n) h(en+1,en)=0.0d0 +cccccccccccccccccccccccccccccccccccccccccccccccccc + if (jx.ne.1) then + wr(en) = h(en,en) + wi(en) = 0.0d0 + endif + en = na + go to 60 +c .......... two roots found .......... + 280 p = (y - x) / 2.0d0 + q = p * p + w + zz = dsqrt(dabs(q)) + h(en,en) = x + t + x = h(en,en) + h(na,na) = y + t + if (q .lt. 0.0d0) go to 320 +c .......... real pair .......... + zz = p + dsign(zz,p) + if (jx.ne.1) then + wr(na) = x + zz + wr(en) = wr(na) + if (zz .ne. 0.0d0) wr(en) = x - w / zz + wi(na) = 0.0d0 + wi(en) = 0.0d0 + endif + x = h(en,na) + s = dabs(x) + dabs(zz) + p = x / s + q = zz / s + r = dsqrt(p*p+q*q) + p = p / r + q = q / r +c .......... row modification .......... + do 290 j = na, n + zz = h(na,j) + h(na,j) = q * zz + p * h(en,j) + h(en,j) = q * h(en,j) - p * zz + 290 continue +c .......... column modification .......... + do 300 i = 1, en + zz = h(i,na) + h(i,na) = q * zz + p * h(i,en) + h(i,en) = q * h(i,en) - p * zz + 300 continue + if(jy .eq. 1) then +c .......... accumulate transformations .......... + do 310 i = low, igh + zz = z(i,na) + z(i,na) = q * zz + p * z(i,en) + z(i,en) = q * z(i,en) - p * zz + 310 continue + endif + +ccccc ADDED TO MARK BLOCK SEPARATION BY HARD ZEROS + h(en,na)=0.0d0 + if(en+1.le.n) h(en+1,en)=0.0d0 +cccccccccccccccccccccccccccccccccccccccccccccccccc + +c + go to 330 +c .......... complex pair .......... + 320 if (jx.ne.1) then + wr(na) = x + p + wr(en) = x + p + wi(na) = zz + wi(en) = -zz + endif + +ccccc ADDED TO MARK BLOCK SEPARATION BY HARD ZEROS + if(en+1.le.n) h(en+1,en)=0.0d0 +cccccccccccccccccccccccccccccccccccccccccccccccccc + + 330 en = enm2 + go to 60 + + 340 if(jx.ne.0) goto 1001 + if (norm .eq. 0.0d+0) go to 1001 +c :::::::::: for en=n step -1 until 1 do -- :::::::::: + do 800 nn = 1, n + en = n + 1 - nn + p = wr(en) + q = wi(en) + na = en - 1 + q=q+1.0d+0 + CRES=(q-1.0d+0) + if (CRES .lt. 0) then + goto 710 + elseif (CRES .eq. 0) then + goto 600 + else + goto 800 + endif +c :::::::::: real vector :::::::::: + 600 m = en + h(en,en) = 1.0d+0 + if (na .eq. 0) go to 800 +c :::::::::: for i=en-1 step -1 until 1 do -- :::::::::: + do 700 ii = 1, na + i = en - ii + w = h(i,i) - p + r = h(i,en) + if (m .gt. na) go to 620 +c + do 610 j = m, na + 610 r = r + h(i,j) * h(j,en) +c + 620 if (wi(i) .ge. 0.0d+0) go to 630 + zz = w + s = r + go to 700 + 630 m = i + if (wi(i) .ne. 0.0d+0) go to 640 + t = w + if (w .eq. 0.0d+0) t = machep * norm + h(i,en) = -r / t + go to 700 +c :::::::::: solve real equations :::::::::: + 640 x = h(i,i+1) + y = h(i+1,i) + q = (wr(i) - p) * (wr(i) - p) + wi(i) * wi(i) + t = (x * s - zz * r) / q + h(i,en) = t + if (abs(x) .le. abs(zz)) go to 650 + h(i+1,en) = (-r - w * t) / x + go to 700 + 650 h(i+1,en) = (-s - y * t) / zz + 700 continue +c :::::::::: end real vector :::::::::: + go to 800 +c :::::::::: complex vector :::::::::: + 710 m = na +c :::::::::: last vector component chosen imaginary so that +c eigenvector matrix is triangular :::::::::: + if (abs(h(en,na)) .le. abs(h(na,en))) go to 720 + h(na,na) = q / h(en,na) + h(na,en) = -(h(en,en) - p) / h(en,na) + go to 730 + 720 z3r=h(na,na)-p + z3=z3r*z3r+q*q + h(na,na)=-h(na,en)*q/z3 + h(na,en)=-h(na,en)*z3r/z3 + 730 h(en,na) = 0.0d+0 + h(en,en) = 1.0d+0 + enm2 = na - 1 + if (enm2 .eq. 0) go to 800 +c :::::::::: for i=en-2 step -1 until 1 do -- :::::::::: + do 790 ii = 1, enm2 + i = na - ii + w = h(i,i) - p + ra = 0.0d+0 + sa = h(i,en) +c + do 760 j = m, na + ra = ra + h(i,j) * h(j,na) + sa = sa + h(i,j) * h(j,en) + 760 continue +c + if (wi(i) .ge. 0.0d+0) go to 770 + zz = w + r = ra + s = sa + go to 790 + 770 m = i + if (wi(i) .ne. 0.0d+0) go to 780 + z3=w*w+q*q + z3r=-ra*w-sa*q + z3i=ra*q-sa*w + h(i,na)=z3r/z3 + h(i,en)=z3i/z3 + go to 790 +c :::::::::: solve complex equations :::::::::: + 780 x = h(i,i+1) + y = h(i+1,i) + vr = (wr(i) - p) * (wr(i) - p) + wi(i) * wi(i) - q * q + vi = (wr(i) - p) * 2.0d+0 * q + if (vr .eq. 0.0d+0 .and. vi .eq. 0.0d+0) vr = machep * norm + x * (abs(w) + abs(q) + abs(x) + abs(y) + abs(zz)) + z3r=x*r-zz*ra+q*sa + z3i=x*s-zz*sa-q*ra + z3=vr*vr+vi*vi + h(i,na)=(z3r*vr+z3i*vi)/z3 + h(i,en)=(-z3r*vi+z3i*vr)/z3 + if (abs(x) .le. abs(zz) + abs(q)) go to 785 + h(i+1,na) = (-ra - w * h(i,na) + q * h(i,en)) / x + h(i+1,en) = (-sa - w * h(i,en) - q * h(i,na)) / x + go to 790 + 785 z3r=-r-y*h(i,na) + z3i=-s-y*h(i,en) + z3=zz*zz+q*q + h(i+1,na)=(z3r*zz+z3i*q)/z3 + h(i+1,en)=(-z3r*q+z3i*zz)/z3 + 790 continue +c :::::::::: end complex vector :::::::::: + 800 continue +c :::::::::: end back substitution. + if(jy.eq.0) goto 1001 +c vectors of isolated roots :::::::::: + do 840 i = 1, n + if (i .ge. low .and. i .le. igh) go to 840 +c + do 820 j = i, n + 820 z(i,j) = h(i,j) +c + 840 continue +c :::::::::: multiply by transformation matrix to give +c vectors of original full matrix. +c for j=n step -1 until low do -- :::::::::: + do 880 jj = low, n + j = n + low - jj + m = min(j,igh) +c + do 880 i = low, igh + zz = 0.0d+0 +c + do 860 k = low, m + 860 zz = zz + z(i,k) * h(k,j) +c + z(i,j) = zz + 880 continue +c + go to 1001 +c .......... set error -- all eigenvalues have not +c converged after 30*n iterations .......... + 1000 ierr = en + 1001 return + end + + + + subroutine cdiv(ar,ai,br,bi,cr,ci) + double precision ar,ai,br,bi,cr,ci +c +c complex division, (cr,ci) = (ar,ai)/(br,bi) +c + double precision s,ars,ais,brs,bis + s = dabs(br) + dabs(bi) + ars = ar/s + ais = ai/s + brs = br/s + bis = bi/s + s = brs**2 + bis**2 + cr = (ars*brs + ais*bis)/s + ci = (ais*brs - ars*bis)/s + return + end + diff --git a/modules/elementary_functions/src/fortran/eispack/hqror2.lo b/modules/elementary_functions/src/fortran/eispack/hqror2.lo new file mode 100755 index 000000000..b302c367c --- /dev/null +++ b/modules/elementary_functions/src/fortran/eispack/hqror2.lo @@ -0,0 +1,12 @@ +# src/fortran/eispack/hqror2.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/hqror2.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/eispack_f_Import.def b/modules/elementary_functions/src/fortran/eispack_f_Import.def new file mode 100755 index 000000000..aac9206d4 --- /dev/null +++ b/modules/elementary_functions/src/fortran/eispack_f_Import.def @@ -0,0 +1,7 @@ +LIBRARY eispack_f.dll + + +EXPORTS +balbak_ +cdiv_ +hqror2_ diff --git a/modules/elementary_functions/src/fortran/elementary_functions_Import.def b/modules/elementary_functions/src/fortran/elementary_functions_Import.def new file mode 100755 index 000000000..15d2a9146 --- /dev/null +++ b/modules/elementary_functions/src/fortran/elementary_functions_Import.def @@ -0,0 +1,12 @@ +LIBRARY elementary_functions.dll + + +EXPORTS +vceil_ +unsfdcopy_ +int2db_ +vfloor_ +vfrexp_ +idmax_ +idmin_ +dcoeff_ diff --git a/modules/elementary_functions/src/fortran/elementary_functions_f.rc b/modules/elementary_functions/src/fortran/elementary_functions_f.rc new file mode 100755 index 000000000..fc25f7647 --- /dev/null +++ b/modules/elementary_functions/src/fortran/elementary_functions_f.rc @@ -0,0 +1,95 @@ +// Microsoft Visual C++ generated resource script. +// + + +#define APSTUDIO_READONLY_SYMBOLS +///////////////////////////////////////////////////////////////////////////// +// +// Generated from the TEXTINCLUDE 2 resource. +// +#define APSTUDIO_HIDDEN_SYMBOLS +#include "windows.h" +///////////////////////////////////////////////////////////////////////////// +#undef APSTUDIO_READONLY_SYMBOLS + +///////////////////////////////////////////////////////////////////////////// +// French (France) resources + +#if !defined(AFX_RESOURCE_DLL) || defined(AFX_TARG_FRA) +#ifdef _WIN32 +LANGUAGE LANG_FRENCH, SUBLANG_FRENCH +#pragma code_page(1252) +#endif //_WIN32 + +#ifdef APSTUDIO_INVOKED +///////////////////////////////////////////////////////////////////////////// +// +// TEXTINCLUDE +// + +1 TEXTINCLUDE +BEGIN + "resource.h\0" +END + +3 TEXTINCLUDE +BEGIN + "\r\n" + "\0" +END + +#endif // APSTUDIO_INVOKED + + +///////////////////////////////////////////////////////////////////////////// +// +// Version +// + +VS_VERSION_INFO VERSIONINFO + FILEVERSION 5,5,2,0 + PRODUCTVERSION 5,5,2,0 + FILEFLAGSMASK 0x17L +#ifdef _DEBUG + FILEFLAGS 0x1L +#else + FILEFLAGS 0x0L +#endif + FILEOS 0x4L + FILETYPE 0x2L + FILESUBTYPE 0x0L +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "040c04b0" + BEGIN + VALUE "FileDescription", "elementary_functions_f module" + VALUE "FileVersion", "5, 5, 2, 0" + VALUE "InternalName", "elementary_functions_f module" + VALUE "LegalCopyright", "Copyright (C) 2017" + VALUE "OriginalFilename", "elementary_functions_f.dll" + VALUE "ProductName", "elementary_functions_f module" + VALUE "ProductVersion", "5, 5, 2, 0" + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x40c, 1200 + END +END + +#endif // French (France) resources +///////////////////////////////////////////////////////////////////////////// + + + +#ifndef APSTUDIO_INVOKED +///////////////////////////////////////////////////////////////////////////// +// +// Generated from the TEXTINCLUDE 3 resource. +// + + +///////////////////////////////////////////////////////////////////////////// +#endif // not APSTUDIO_INVOKED + diff --git a/modules/elementary_functions/src/fortran/elementary_functions_f.vfproj b/modules/elementary_functions/src/fortran/elementary_functions_f.vfproj new file mode 100755 index 000000000..5d6272145 --- /dev/null +++ b/modules/elementary_functions/src/fortran/elementary_functions_f.vfproj @@ -0,0 +1,232 @@ +<?xml version="1.0" encoding="UTF-8"?> +<VisualStudioProject ProjectType="typeDynamicLibrary" ProjectCreator="Intel Fortran" Keyword="Dll" Version="11.0" ProjectIdGuid="{DBC45B0D-6E0A-4107-B284-5A3B0C5BB50D}"> + <Platforms> + <Platform Name="Win32"/> + <Platform Name="x64"/></Platforms> + <Configurations> + <Configuration Name="Debug|Win32" OutputDirectory="$(SolutionDir)bin\" IntermediateDirectory="$(ProjectDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary"> + <Tool Name="VFFortranCompilerTool" SuppressStartupBanner="true" DebugInformationFormat="debugEnabled" Optimization="optimizeDisabled" AdditionalIncludeDirectories="../../../core/includes" PreprocessorDefinitions="WIN32;FORDLL" AlternateParameterSyntax="false" F77RuntimeCompatibility="true" FPS4Libs="false" CallingConvention="callConventionCRef" ExternalNameUnderscore="true" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" RuntimeLibrary="rtMultiThreadedDebugDLL"/> + <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin\$(ProjectName).dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" ModuleDefinitionFile="elementary_functions_f.def" GenerateDebugInformation="true" SubSystem="subSystemWindows" ImportLibrary="$(SolutionDir)bin\$(ProjectName).lib" LinkDLL="true" AdditionalDependencies="core_f.lib cacsd_f.lib eispack_f.lib elementary_functions.lib integer.lib core.lib linpack_f.lib output_stream.lib polynomials_f.lib slatec_f.lib sparse_f.lib string.lib ../../../../bin/blasplus.lib ../../../../bin/lapack.lib"/> + <Tool Name="VFResourceCompilerTool"/> + <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/> + <Tool Name="VFCustomBuildTool"/> + <Tool Name="VFPreLinkEventTool" CommandLine="setlocal EnableDelayedExpansion
cd $(ConfigurationName)
set LIST_OBJ=
for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f
"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ%
copy $(ProjectName).def ..\$(ProjectName).def >nul
del *.def >nul
cd .." Description="Build $(ProjectName).def"/> + <Tool Name="VFPreBuildEventTool" CommandLine="lib /DEF:"$(InputDir)core_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)core_f.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)core.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)elementary_functions.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)string_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)string.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)output_stream.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)integer_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)integer.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)cacsd_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)cacsd_f.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)polynomials_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)polynomials_f.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)sparse_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)sparse_f.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)eispack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)eispack_f.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)linpack_f.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)slatec_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)slatec_f.lib" 1>NUL 2>NUL" Description="Build Dependencies"/> + <Tool Name="VFPostBuildEventTool"/> + <Tool Name="VFManifestTool" SuppressStartupBanner="true"/></Configuration> + <Configuration Name="Release|Win32" OutputDirectory="$(SolutionDir)bin\" IntermediateDirectory="$(ProjectDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary"> + <Tool Name="VFFortranCompilerTool" SuppressStartupBanner="true" AdditionalIncludeDirectories="../../../core/includes" PreprocessorDefinitions="WIN32;FORDLL" AlternateParameterSyntax="false" F77RuntimeCompatibility="true" FPS4Libs="false" CallingConvention="callConventionCRef" ExternalNameUnderscore="true" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" RuntimeLibrary="rtMultiThreadedDLL"/> + <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin\$(ProjectName).dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" ModuleDefinitionFile="elementary_functions_f.def" SubSystem="subSystemWindows" ImportLibrary="$(SolutionDir)bin\$(ProjectName).lib" LinkDLL="true" AdditionalDependencies="core_f.lib cacsd_f.lib eispack_f.lib elementary_functions.lib integer.lib core.lib linpack_f.lib output_stream.lib polynomials_f.lib slatec_f.lib sparse_f.lib string.lib ../../../../bin/blasplus.lib ../../../../bin/lapack.lib"/> + <Tool Name="VFResourceCompilerTool"/> + <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/> + <Tool Name="VFCustomBuildTool"/> + <Tool Name="VFPreLinkEventTool" CommandLine="setlocal EnableDelayedExpansion
cd $(ConfigurationName)
set LIST_OBJ=
for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f
"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ%
copy $(ProjectName).def ..\$(ProjectName).def >nul
del *.def >nul
cd .." Description="Build $(ProjectName).def"/> + <Tool Name="VFPreBuildEventTool" CommandLine="lib /DEF:"$(InputDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)core.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)elementary_functions.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)string_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)string.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)output_stream.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)integer_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)integer.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)cacsd_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)cacsd_f.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)polynomials_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)polynomials_f.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)sparse_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)sparse_f.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)eispack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)eispack_f.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)linpack_f.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)slatec_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)slatec_f.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)core_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)core_f.lib" 1>NUL 2>NUL" Description="Build Dependencies"/> + <Tool Name="VFPostBuildEventTool"/> + <Tool Name="VFManifestTool" SuppressStartupBanner="true"/></Configuration> + <Configuration Name="Debug|x64" OutputDirectory="$(SolutionDir)bin\" IntermediateDirectory="$(ProjectDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary"> + <Tool Name="VFFortranCompilerTool" SuppressStartupBanner="true" DebugInformationFormat="debugEnabled" Optimization="optimizeDisabled" AdditionalIncludeDirectories="../../../core/includes" PreprocessorDefinitions="WIN32;FORDLL" AlternateParameterSyntax="false" F77RuntimeCompatibility="true" FPS4Libs="false" CallingConvention="callConventionCRef" ExternalNameUnderscore="true" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" RuntimeLibrary="rtMultiThreadedDebugDLL"/> + <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin\$(ProjectName).dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" ModuleDefinitionFile="elementary_functions_f.def" GenerateDebugInformation="true" SubSystem="subSystemWindows" ImportLibrary="$(SolutionDir)bin\$(ProjectName).lib" LinkDLL="true" AdditionalDependencies="core_f.lib cacsd_f.lib eispack_f.lib elementary_functions.lib integer.lib core.lib linpack_f.lib output_stream.lib polynomials_f.lib slatec_f.lib sparse_f.lib string.lib ../../../../bin/blasplus.lib ../../../../bin/lapack.lib"/> + <Tool Name="VFResourceCompilerTool"/> + <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/> + <Tool Name="VFCustomBuildTool"/> + <Tool Name="VFPreLinkEventTool" CommandLine="setlocal EnableDelayedExpansion
cd $(ConfigurationName)
set LIST_OBJ=
for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f
"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ%
copy $(ProjectName).def ..\$(ProjectName).def >nul
del *.def >nul
cd .." Description="Build $(ProjectName).def"/> + <Tool Name="VFPreBuildEventTool" CommandLine="lib /DEF:"$(InputDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)core.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)elementary_functions.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)string_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)string.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)output_stream.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)integer_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)integer.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)cacsd_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)cacsd_f.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)polynomials_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)polynomials_f.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)sparse_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)sparse_f.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)eispack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)eispack_f.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)linpack_f.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)slatec_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)slatec_f.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)core_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)core_f.lib" 1>NUL 2>NUL" Description="Build Dependencies"/> + <Tool Name="VFPostBuildEventTool"/> + <Tool Name="VFManifestTool" SuppressStartupBanner="true"/></Configuration> + <Configuration Name="Release|x64" OutputDirectory="$(SolutionDir)bin\" IntermediateDirectory="$(ProjectDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary"> + <Tool Name="VFFortranCompilerTool" SuppressStartupBanner="true" AdditionalIncludeDirectories="../../../core/includes" PreprocessorDefinitions="WIN32;FORDLL" AlternateParameterSyntax="false" F77RuntimeCompatibility="true" FPS4Libs="false" CallingConvention="callConventionCRef" ExternalNameUnderscore="true" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" RuntimeLibrary="rtMultiThreadedDLL"/> + <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin\$(ProjectName).dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" ModuleDefinitionFile="elementary_functions_f.def" SubSystem="subSystemWindows" ImportLibrary="$(SolutionDir)bin\$(ProjectName).lib" LinkDLL="true" AdditionalDependencies="core_f.lib cacsd_f.lib eispack_f.lib elementary_functions.lib integer.lib core.lib linpack_f.lib output_stream.lib polynomials_f.lib slatec_f.lib sparse_f.lib string.lib ../../../../bin/blasplus.lib ../../../../bin/lapack.lib"/> + <Tool Name="VFResourceCompilerTool"/> + <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/> + <Tool Name="VFCustomBuildTool"/> + <Tool Name="VFPreLinkEventTool" CommandLine="setlocal EnableDelayedExpansion
cd $(ConfigurationName)
set LIST_OBJ=
for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f
"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ%
copy $(ProjectName).def ..\$(ProjectName).def >nul
del *.def >nul
cd .." Description="Build $(ProjectName).def"/> + <Tool Name="VFPreBuildEventTool" CommandLine="lib /DEF:"$(InputDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)core.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)elementary_functions.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)string_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)string.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)output_stream.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)integer_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)integer.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)cacsd_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)cacsd_f.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)polynomials_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)polynomials_f.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)sparse_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)sparse_f.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)eispack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)eispack_f.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)linpack_f.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)slatec_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)slatec_f.lib" 1>NUL 2>NUL
lib /DEF:"$(InputDir)core_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)core_f.lib" 1>NUL 2>NUL" Description="Build Dependencies"/> + <Tool Name="VFPostBuildEventTool"/> + <Tool Name="VFManifestTool" SuppressStartupBanner="true"/></Configuration></Configurations> + <Files> + <Filter Name="Header Files" Filter="fi;fd"/> + <Filter Name="Library Dependencies"> + <File RelativePath=".\cacsd_f_Import.def"/> + <File RelativePath=".\Core_f_Import.def"/> + <File RelativePath=".\core_import.def"/> + <File RelativePath=".\eispack_f_Import.def"/> + <File RelativePath=".\elementary_functions_Import.def"/> + <File RelativePath=".\Integer_Import.def"/> + <File RelativePath=".\linpack_f_Import.def"/> + <File RelativePath=".\Output_stream_Import.def"/> + <File RelativePath=".\polynomials_f_Import.def"/> + <File RelativePath=".\slatec_f_Import.def"/> + <File RelativePath=".\sparse_f_Import.def"/> + <File RelativePath=".\String_Import.def"/></Filter> + <Filter Name="Resource Files" Filter="rc;ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe"> + <File RelativePath=".\elementary_functions_f.rc"/></Filter> + <Filter Name="Source Files" Filter="f90;for;f;fpp;ftn;def;odl;idl"> + <File RelativePath=".\arcosh.f"/> + <File RelativePath=".\bdiag.f"/> + <File RelativePath=".\cbal.f"/> + <File RelativePath=".\cerr.f"/> + <File RelativePath=".\coef.f"/> + <File RelativePath=".\comqr3.f"/> + <File RelativePath=".\corth.f"/> + <File RelativePath=".\cortr.f"/> + <File RelativePath=".\coshin.f"/> + <File RelativePath=".\cupro.f"/> + <File RelativePath=".\cuproi.f"/> + <File RelativePath=".\cusum.f"/> + <File RelativePath=".\d1mach.f"/> + <File RelativePath=".\dad.f"/> + <File RelativePath=".\dadd.f"/> + <File RelativePath=".\dclmat.f"/> + <File RelativePath=".\ddif.f"/> + <File RelativePath=".\ddpow.f"/> + <File RelativePath=".\ddpow1.f"/> + <File RelativePath=".\ddpowe.f"/> + <File RelativePath=".\ddrdiv.f"/> + <File RelativePath=".\dexpm1.f"/> + <File RelativePath=".\dipow.f"/> + <File RelativePath=".\dipowe.f"/> + <File RelativePath=".\dlblks.f"/> + <File RelativePath=".\dlgama.f"/> + <File RelativePath=".\dmcopy.f"/> + <File RelativePath=".\dmmul.f"/> + <File RelativePath=".\dmmul1.f"/> + <File RelativePath=".\dmprod.f"/> + <File RelativePath=".\dmsum.f"/> + <File RelativePath=".\drdiv.f"/> + <File RelativePath=".\dsearch.f"/> + <File RelativePath=".\dset.f"/> + <File RelativePath=".\dsort.f"/> + <File RelativePath=".\dsum.f"/> + <File RelativePath=".\dtild.f"/> + <File RelativePath=".\dvmul.f"/> + <File RelativePath=".\dwdiv.f"/> + <File RelativePath=".\dwpow.f"/> + <File RelativePath=".\dwpow1.f"/> + <File RelativePath=".\dwpowe.f"/> + <File RelativePath=".\dwrdiv.f"/> + <File RelativePath=".\entier.f"/> + <File RelativePath=".\exch.f"/> + <File RelativePath=".\find.f"/> + <File RelativePath=".\franck.f"/> + <File RelativePath=".\gdcp2i.f"/> + <File RelativePath=".\getdimfromvar.f"/> + <File RelativePath=".\getorient.f"/> + <File RelativePath=".\hilber.f"/> + <File RelativePath=".\i1mach.f"/> + <File RelativePath=".\imcopy.f"/> + <File RelativePath=".\infinity.f"/> + <File RelativePath=".\intp.f"/> + <File RelativePath=".\iset.f"/> + <File RelativePath=".\isort.f"/> + <File RelativePath=".\isova0.f"/> + <File RelativePath=".\isoval.f"/> + <File RelativePath=".\israt.f"/> + <File RelativePath=".\ivimp.f"/> + <File RelativePath=".\iwamax.f"/> + <File RelativePath=".\kronc.f"/> + <File RelativePath=".\kronr.f"/> + <File RelativePath=".\lnblnk.f"/> + <File RelativePath=".\magic.f"/> + <File RelativePath=".\mtran.f"/> + <File RelativePath=".\nearfloat.f"/> + <File RelativePath=".\orthes.f"/> + <File RelativePath=".\ortran.f"/> + <File RelativePath=".\pythag.f"/> + <File RelativePath=".\rat.f"/> + <File RelativePath=".\rcopy.f"/> + <File RelativePath=".\rcsort.f"/> + <File RelativePath=".\round.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_abs.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_acos.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_asin.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_atan.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_ceil.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_chinesehat.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_clean.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_conj.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_cos.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_cumprod.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_cumsum.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_diag.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_dsearch.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_exp.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_expm.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_eye.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_find.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_floor.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_frexp.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_imag.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_imult.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_int.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_isequal.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_isreal.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_kron.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_log.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_log1p.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_matrix.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_maxi.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_nearfloat.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_number_properties.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_ones.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_prod.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_rand.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_rat.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_real.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_round.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_sign.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_sin.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_size.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_spones.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_sqrt.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_sum.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_tan.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_testmatrix.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_tril.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_triu.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_zeros.f"/> + <File RelativePath=".\simple.f"/> + <File RelativePath=".\split.f"/> + <File RelativePath=".\urand.f"/> + <File RelativePath=".\vpythag.f"/> + <File RelativePath=".\wacos.f"/> + <File RelativePath=".\wasin.f"/> + <File RelativePath=".\wasum.f"/> + <File RelativePath=".\watan.f"/> + <File RelativePath=".\waxpy.f"/> + <File RelativePath=".\wbdiag.f"/> + <File RelativePath=".\wcerr.f"/> + <File RelativePath=".\wclmat.f"/> + <File RelativePath=".\wddiv.f"/> + <File RelativePath=".\wdiv.f"/> + <File RelativePath=".\wdotci.f"/> + <File RelativePath=".\wdotcr.f"/> + <File RelativePath=".\wdpow.f"/> + <File RelativePath=".\wdpow1.f"/> + <File RelativePath=".\wdpowe.f"/> + <File RelativePath=".\wdrdiv.f"/> + <File RelativePath=".\wexchn.f"/> + <File RelativePath=".\wexpm1.f"/> + <File RelativePath=".\wipow.f"/> + <File RelativePath=".\wipowe.f"/> + <File RelativePath=".\wlog.f"/> + <File RelativePath=".\wmmul.f"/> + <File RelativePath=".\wmprod.f"/> + <File RelativePath=".\wmsum.f"/> + <File RelativePath=".\wmul.f"/> + <File RelativePath=".\wrscal.f"/> + <File RelativePath=".\wscal.f"/> + <File RelativePath=".\wshrsl.f"/> + <File RelativePath=".\wsign.f"/> + <File RelativePath=".\wsqrt.f"/> + <File RelativePath=".\wswap.f"/> + <File RelativePath=".\wtan.f"/> + <File RelativePath=".\wvmul.f"/> + <File RelativePath=".\wwdiv.f"/> + <File RelativePath=".\wwpow.f"/> + <File RelativePath=".\wwpow1.f"/> + <File RelativePath=".\wwpowe.f"/> + <File RelativePath=".\wwrdiv.f"/></Filter> + <File RelativePath="..\..\sci_gateway\elementary_functions_gateway.xml"/> + <File RelativePath="..\..\Makefile.am"/></Files> + <Globals/></VisualStudioProject> diff --git a/modules/elementary_functions/src/fortran/elementary_functions_f2c.vcxproj b/modules/elementary_functions/src/fortran/elementary_functions_f2c.vcxproj new file mode 100755 index 000000000..9bfb0f3d5 --- /dev/null +++ b/modules/elementary_functions/src/fortran/elementary_functions_f2c.vcxproj @@ -0,0 +1,650 @@ +<?xml version="1.0" encoding="utf-8"?> +<Project DefaultTargets="Build" ToolsVersion="4.0" xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <ItemGroup Label="ProjectConfigurations"> + <ProjectConfiguration Include="Debug|Win32"> + <Configuration>Debug</Configuration> + <Platform>Win32</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Debug|x64"> + <Configuration>Debug</Configuration> + <Platform>x64</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Release|Win32"> + <Configuration>Release</Configuration> + <Platform>Win32</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Release|x64"> + <Configuration>Release</Configuration> + <Platform>x64</Platform> + </ProjectConfiguration> + </ItemGroup> + <PropertyGroup Label="Globals"> + <ProjectName>elementary_functions_f</ProjectName> + <ProjectGuid>{DBC45B0D-6E0A-4107-B284-5A3B0C5BB50D}</ProjectGuid> + <RootNamespace>elementary_functions_f2c</RootNamespace> + <Keyword>Win32Proj</Keyword> + </PropertyGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.Default.props" /> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>Unicode</CharacterSet> + <WholeProgramOptimization>true</WholeProgramOptimization> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>Unicode</CharacterSet> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>Unicode</CharacterSet> + <WholeProgramOptimization>true</WholeProgramOptimization> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>Unicode</CharacterSet> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.props" /> + <ImportGroup Label="ExtensionSettings"> + <Import Project="..\..\..\..\Visual-Studio-settings\f2c.props" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <PropertyGroup Label="UserMacros" /> + <PropertyGroup> + <_ProjectFileVersion>10.0.30319.1</_ProjectFileVersion> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">true</LinkIncremental> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">true</LinkIncremental> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">false</LinkIncremental> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Release|x64'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Release|x64'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Release|x64'">false</LinkIncremental> + </PropertyGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'"> + <PreBuildEvent> + <Message>Build Dependencies</Message> + <Command>lib /DEF:"$(ProjectDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)elementary_functions.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)string_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)string.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)output_stream.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)integer_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)integer.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)cacsd_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)cacsd_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)sparse_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)sparse_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)linpack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)slatec_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)slatec_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)polynomials_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)polynomials_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)eispack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)eispack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)core_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core_f.lib" 1>NUL 2>NUL</Command> + </PreBuildEvent> + <ClCompile> + <Optimization>Disabled</Optimization> + <AdditionalIncludeDirectories>../../../../libs/f2c;../../../core/includes;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>WIN32;_DEBUG;_WINDOWS;_USRDLL;ELEMENTARY_FUNCTIONS_F2C_EXPORTS;FORDLL;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDebugDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + </ClCompile> + <PreLinkEvent> + <Message>Build $(ProjectName).def</Message> + <Command>setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .. +</Command> + </PreLinkEvent> + <Link> + <AdditionalOptions>/ignore:4049 %(AdditionalOptions)</AdditionalOptions> + <AdditionalDependencies>core.lib;elementary_functions.lib;string.lib;integer.lib;output_stream.lib;cacsd_f.lib;polynomials_f.lib;sparse_f.lib;eispack_f.lib;linpack_f.lib;slatec_f.lib;core_f.lib;../../../../bin/blasplus.lib;../../../../bin/lapack.lib;../../../../bin/libf2c.lib</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <ModuleDefinitionFile>elementary_functions_f.def</ModuleDefinitionFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX86</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + <LinkTimeCodeGeneration>Default</LinkTimeCodeGeneration> + </Link> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'"> + <PreBuildEvent> + <Message>Build Dependencies</Message> + <Command>lib /DEF:"$(ProjectDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)elementary_functions.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)string_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)string.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)output_stream.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)integer_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)integer.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)cacsd_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)cacsd_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)sparse_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)sparse_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)linpack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)slatec_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)slatec_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)polynomials_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)polynomials_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)eispack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)eispack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)core_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core_f.lib" 1>NUL 2>NUL</Command> + </PreBuildEvent> + <Midl> + <TargetEnvironment>X64</TargetEnvironment> + </Midl> + <ClCompile> + <Optimization>Disabled</Optimization> + <AdditionalIncludeDirectories>../../../../libs/f2c;../../../core/includes;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>WIN32;_DEBUG;_WINDOWS;_USRDLL;ELEMENTARY_FUNCTIONS_F2C_EXPORTS;FORDLL;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDebugDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + </ClCompile> + <PreLinkEvent> + <Message>Build $(ProjectName).def</Message> + <Command>setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .. +</Command> + </PreLinkEvent> + <Link> + <AdditionalOptions>/ignore:4049 %(AdditionalOptions)</AdditionalOptions> + <AdditionalDependencies>core.lib;elementary_functions.lib;string.lib;integer.lib;output_stream.lib;cacsd_f.lib;polynomials_f.lib;sparse_f.lib;eispack_f.lib;linpack_f.lib;slatec_f.lib;core_f.lib;../../../../bin/blasplus.lib;../../../../bin/lapack.lib;../../../../bin/libf2c.lib</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <ModuleDefinitionFile>elementary_functions_f.def</ModuleDefinitionFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX64</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + <LinkTimeCodeGeneration>Default</LinkTimeCodeGeneration> + </Link> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'"> + <PreBuildEvent> + <Message>Build Dependencies</Message> + <Command>lib /DEF:"$(ProjectDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)elementary_functions.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)string_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)string.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)output_stream.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)integer_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)integer.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)cacsd_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)cacsd_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)sparse_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)sparse_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)linpack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)slatec_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)slatec_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)polynomials_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)polynomials_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)eispack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)eispack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)core_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core_f.lib" 1>NUL 2>NUL</Command> + </PreBuildEvent> + <ClCompile> + <WholeProgramOptimization>false</WholeProgramOptimization> + <AdditionalIncludeDirectories>../../../../libs/f2c;../../../core/includes;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>WIN32;NDEBUG;_WINDOWS;_USRDLL;ELEMENTARY_FUNCTIONS_F2C_EXPORTS;FORDLL;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + <MultiProcessorCompilation>true</MultiProcessorCompilation> + </ClCompile> + <PreLinkEvent> + <Message>Build $(ProjectName).def</Message> + <Command>setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .. +</Command> + </PreLinkEvent> + <Link> + <AdditionalOptions>/ignore:4049 %(AdditionalOptions)</AdditionalOptions> + <AdditionalDependencies>core.lib;elementary_functions.lib;string.lib;integer.lib;output_stream.lib;cacsd_f.lib;polynomials_f.lib;sparse_f.lib;eispack_f.lib;linpack_f.lib;slatec_f.lib;core_f.lib;../../../../bin/blasplus.lib;../../../../bin/lapack.lib;../../../../bin/libf2c.lib</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <ModuleDefinitionFile>elementary_functions_f.def</ModuleDefinitionFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <OptimizeReferences>true</OptimizeReferences> + <EnableCOMDATFolding>true</EnableCOMDATFolding> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX86</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + <LinkTimeCodeGeneration>Default</LinkTimeCodeGeneration> + </Link> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'"> + <PreBuildEvent> + <Message>Build Dependencies</Message> + <Command>lib /DEF:"$(ProjectDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)elementary_functions.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)string_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)string.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)output_stream.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)integer_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)integer.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)cacsd_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)cacsd_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)sparse_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)sparse_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)linpack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)slatec_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)slatec_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)polynomials_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)polynomials_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)eispack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)eispack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)core_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core_f.lib" 1>NUL 2>NUL</Command> + </PreBuildEvent> + <Midl> + <TargetEnvironment>X64</TargetEnvironment> + </Midl> + <ClCompile> + <WholeProgramOptimization>false</WholeProgramOptimization> + <AdditionalIncludeDirectories>../../../../libs/f2c;../../../core/includes;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>WIN32;NDEBUG;_WINDOWS;_USRDLL;ELEMENTARY_FUNCTIONS_F2C_EXPORTS;FORDLL;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + <MultiProcessorCompilation>true</MultiProcessorCompilation> + </ClCompile> + <PreLinkEvent> + <Message>Build $(ProjectName).def</Message> + <Command>setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .. +</Command> + </PreLinkEvent> + <Link> + <AdditionalOptions>/ignore:4049 %(AdditionalOptions)</AdditionalOptions> + <AdditionalDependencies>core.lib;elementary_functions.lib;string.lib;integer.lib;output_stream.lib;cacsd_f.lib;polynomials_f.lib;sparse_f.lib;eispack_f.lib;linpack_f.lib;slatec_f.lib;core_f.lib;../../../../bin/blasplus.lib;../../../../bin/lapack.lib;../../../../bin/libf2c.lib</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <ModuleDefinitionFile>elementary_functions_f.def</ModuleDefinitionFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <OptimizeReferences>true</OptimizeReferences> + <EnableCOMDATFolding>true</EnableCOMDATFolding> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX64</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + <LinkTimeCodeGeneration>Default</LinkTimeCodeGeneration> + </Link> + </ItemDefinitionGroup> + <ItemGroup> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_find.c" /> + <ClCompile Include="arcosh.c" /> + <ClCompile Include="bdiag.c" /> + <ClCompile Include="cbal.c" /> + <ClCompile Include="cerr.c" /> + <ClCompile Include="coef.c" /> + <ClCompile Include="comqr3.c" /> + <ClCompile Include="corth.c" /> + <ClCompile Include="cortr.c" /> + <ClCompile Include="coshin.c" /> + <ClCompile Include="cupro.c" /> + <ClCompile Include="cuproi.c" /> + <ClCompile Include="cusum.c" /> + <ClCompile Include="d1mach.c" /> + <ClCompile Include="dad.c" /> + <ClCompile Include="dadd.c" /> + <ClCompile Include="dclmat.c" /> + <ClCompile Include="ddif.c" /> + <ClCompile Include="ddpow.c" /> + <ClCompile Include="ddpow1.c" /> + <ClCompile Include="ddpowe.c" /> + <ClCompile Include="ddrdiv.c" /> + <ClCompile Include="dexpm1.c" /> + <ClCompile Include="dipow.c" /> + <ClCompile Include="dipowe.c" /> + <ClCompile Include="dlblks.c" /> + <ClCompile Include="dlgama.c" /> + <ClCompile Include="dmcopy.c" /> + <ClCompile Include="dmmul.c" /> + <ClCompile Include="dmmul1.c" /> + <ClCompile Include="dmprod.c" /> + <ClCompile Include="dmsum.c" /> + <ClCompile Include="drdiv.c" /> + <ClCompile Include="dsearch.c" /> + <ClCompile Include="dset.c" /> + <ClCompile Include="dsort.c" /> + <ClCompile Include="dsum.c" /> + <ClCompile Include="dtild.c" /> + <ClCompile Include="dvmul.c" /> + <ClCompile Include="dwdiv.c" /> + <ClCompile Include="dwpow.c" /> + <ClCompile Include="dwpow1.c" /> + <ClCompile Include="dwpowe.c" /> + <ClCompile Include="dwrdiv.c" /> + <ClCompile Include="entier.c" /> + <ClCompile Include="exch.c" /> + <ClCompile Include="find.c" /> + <ClCompile Include="franck.c" /> + <ClCompile Include="gdcp2i.c" /> + <ClCompile Include="getdimfromvar.c" /> + <ClCompile Include="getorient.c" /> + <ClCompile Include="hilber.c" /> + <ClCompile Include="i1mach.c" /> + <ClCompile Include="imcopy.c" /> + <ClCompile Include="infinity.c" /> + <ClCompile Include="intp.c" /> + <ClCompile Include="iset.c" /> + <ClCompile Include="isort.c" /> + <ClCompile Include="isova0.c" /> + <ClCompile Include="isoval.c" /> + <ClCompile Include="israt.c" /> + <ClCompile Include="ivimp.c" /> + <ClCompile Include="iwamax.c" /> + <ClCompile Include="kronc.c" /> + <ClCompile Include="kronr.c" /> + <ClCompile Include="lnblnk.c" /> + <ClCompile Include="magic.c" /> + <ClCompile Include="mtran.c" /> + <ClCompile Include="nearfloat.c" /> + <ClCompile Include="orthes.c" /> + <ClCompile Include="ortran.c" /> + <ClCompile Include="pythag.c" /> + <ClCompile Include="rat.c" /> + <ClCompile Include="rcopy.c" /> + <ClCompile Include="rcsort.c" /> + <ClCompile Include="round.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_abs.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_acos.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_asin.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_atan.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_ceil.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_chinesehat.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_clean.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_conj.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_cos.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_cumprod.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_cumsum.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_diag.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_dsearch.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_exp.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_expm.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_eye.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_floor.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_frexp.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_imag.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_imult.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_int.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_isequal.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_isreal.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_kron.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_log.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_log1p.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_matrix.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_maxi.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_nearfloat.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_number_properties.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_ones.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_prod.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_rand.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_rat.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_real.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_round.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_sign.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_sin.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_size.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_spones.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_sqrt.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_sum.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_tan.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_testmatrix.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_tril.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_triu.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_zeros.c" /> + <ClCompile Include="simple.c" /> + <ClCompile Include="split.c" /> + <ClCompile Include="urand.c" /> + <ClCompile Include="vpythag.c" /> + <ClCompile Include="wacos.c" /> + <ClCompile Include="wasin.c" /> + <ClCompile Include="wasum.c" /> + <ClCompile Include="watan.c" /> + <ClCompile Include="waxpy.c" /> + <ClCompile Include="wbdiag.c" /> + <ClCompile Include="wcerr.c" /> + <ClCompile Include="wclmat.c" /> + <ClCompile Include="wddiv.c" /> + <ClCompile Include="wdiv.c" /> + <ClCompile Include="wdotci.c" /> + <ClCompile Include="wdotcr.c" /> + <ClCompile Include="wdpow.c" /> + <ClCompile Include="wdpow1.c" /> + <ClCompile Include="wdpowe.c" /> + <ClCompile Include="wdrdiv.c" /> + <ClCompile Include="wexchn.c" /> + <ClCompile Include="wexpm1.c" /> + <ClCompile Include="wipow.c" /> + <ClCompile Include="wipowe.c" /> + <ClCompile Include="wlog.c" /> + <ClCompile Include="wmmul.c" /> + <ClCompile Include="wmprod.c" /> + <ClCompile Include="wmsum.c" /> + <ClCompile Include="wmul.c" /> + <ClCompile Include="wrscal.c" /> + <ClCompile Include="wscal.c" /> + <ClCompile Include="wshrsl.c" /> + <ClCompile Include="wsign.c" /> + <ClCompile Include="wsqrt.c" /> + <ClCompile Include="wswap.c" /> + <ClCompile Include="wtan.c" /> + <ClCompile Include="wvmul.c" /> + <ClCompile Include="wwdiv.c" /> + <ClCompile Include="wwpow.c" /> + <ClCompile Include="wwpow1.c" /> + <ClCompile Include="wwpowe.c" /> + <ClCompile Include="wwrdiv.c" /> + </ItemGroup> + <ItemGroup> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_find.f" /> + <f2c_rule Include="arcosh.f" /> + <f2c_rule Include="bdiag.f" /> + <f2c_rule Include="cbal.f" /> + <f2c_rule Include="cerr.f" /> + <f2c_rule Include="coef.f" /> + <f2c_rule Include="comqr3.f" /> + <f2c_rule Include="corth.f" /> + <f2c_rule Include="cortr.f" /> + <f2c_rule Include="coshin.f" /> + <f2c_rule Include="cupro.f" /> + <f2c_rule Include="cuproi.f" /> + <f2c_rule Include="cusum.f" /> + <f2c_rule Include="d1mach.f" /> + <f2c_rule Include="dad.f" /> + <f2c_rule Include="dadd.f" /> + <f2c_rule Include="dclmat.f" /> + <f2c_rule Include="ddif.f" /> + <f2c_rule Include="ddpow.f" /> + <f2c_rule Include="ddpow1.f" /> + <f2c_rule Include="ddpowe.f" /> + <f2c_rule Include="ddrdiv.f" /> + <f2c_rule Include="dexpm1.f" /> + <f2c_rule Include="dipow.f" /> + <f2c_rule Include="dipowe.f" /> + <f2c_rule Include="dlblks.f" /> + <f2c_rule Include="dlgama.f" /> + <f2c_rule Include="dmcopy.f" /> + <f2c_rule Include="dmmul.f" /> + <f2c_rule Include="dmmul1.f" /> + <f2c_rule Include="dmprod.f" /> + <f2c_rule Include="dmsum.f" /> + <f2c_rule Include="drdiv.f" /> + <f2c_rule Include="dsearch.f" /> + <f2c_rule Include="dset.f" /> + <f2c_rule Include="dsort.f" /> + <f2c_rule Include="dsum.f" /> + <f2c_rule Include="dtild.f" /> + <f2c_rule Include="dvmul.f" /> + <f2c_rule Include="dwdiv.f" /> + <f2c_rule Include="dwpow.f" /> + <f2c_rule Include="dwpow1.f" /> + <f2c_rule Include="dwpowe.f" /> + <f2c_rule Include="dwrdiv.f" /> + <f2c_rule Include="entier.f" /> + <f2c_rule Include="exch.f" /> + <f2c_rule Include="find.f" /> + <f2c_rule Include="franck.f" /> + <f2c_rule Include="gdcp2i.f" /> + <f2c_rule Include="getdimfromvar.f" /> + <f2c_rule Include="getorient.f" /> + <f2c_rule Include="hilber.f" /> + <f2c_rule Include="i1mach.f" /> + <f2c_rule Include="imcopy.f" /> + <f2c_rule Include="infinity.f" /> + <f2c_rule Include="intp.f" /> + <f2c_rule Include="iset.f" /> + <f2c_rule Include="isort.f" /> + <f2c_rule Include="isova0.f" /> + <f2c_rule Include="isoval.f" /> + <f2c_rule Include="israt.f" /> + <f2c_rule Include="ivimp.f" /> + <f2c_rule Include="iwamax.f" /> + <f2c_rule Include="kronc.f" /> + <f2c_rule Include="kronr.f" /> + <f2c_rule Include="lnblnk.f" /> + <f2c_rule Include="magic.f" /> + <f2c_rule Include="mtran.f" /> + <f2c_rule Include="nearfloat.f" /> + <f2c_rule Include="orthes.f" /> + <f2c_rule Include="ortran.f" /> + <f2c_rule Include="pythag.f" /> + <f2c_rule Include="rat.f" /> + <f2c_rule Include="rcopy.f" /> + <f2c_rule Include="rcsort.f" /> + <f2c_rule Include="round.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_abs.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_acos.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_asin.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_atan.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_ceil.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_chinesehat.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_clean.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_conj.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_cos.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_cumprod.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_cumsum.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_diag.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_dsearch.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_exp.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_expm.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_eye.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_floor.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_frexp.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_imag.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_imult.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_int.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_isequal.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_isreal.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_kron.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_log.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_log1p.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_matrix.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_maxi.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_nearfloat.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_number_properties.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_ones.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_prod.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_rand.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_rat.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_real.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_round.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_sign.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_sin.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_size.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_spones.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_sqrt.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_sum.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_tan.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_testmatrix.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_tril.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_triu.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_zeros.f" /> + <f2c_rule Include="simple.f" /> + <f2c_rule Include="split.f" /> + <f2c_rule Include="urand.f" /> + <f2c_rule Include="vpythag.f" /> + <f2c_rule Include="wacos.f" /> + <f2c_rule Include="wasin.f" /> + <f2c_rule Include="wasum.f" /> + <f2c_rule Include="watan.f" /> + <f2c_rule Include="waxpy.f" /> + <f2c_rule Include="wbdiag.f" /> + <f2c_rule Include="wcerr.f" /> + <f2c_rule Include="wclmat.f" /> + <f2c_rule Include="wddiv.f" /> + <f2c_rule Include="wdiv.f" /> + <f2c_rule Include="wdotci.f" /> + <f2c_rule Include="wdotcr.f" /> + <f2c_rule Include="wdpow.f" /> + <f2c_rule Include="wdpow1.f" /> + <f2c_rule Include="wdpowe.f" /> + <f2c_rule Include="wdrdiv.f" /> + <f2c_rule Include="wexchn.f" /> + <f2c_rule Include="wexpm1.f" /> + <f2c_rule Include="wipow.f" /> + <f2c_rule Include="wipowe.f" /> + <f2c_rule Include="wlog.f" /> + <f2c_rule Include="wmmul.f" /> + <f2c_rule Include="wmprod.f" /> + <f2c_rule Include="wmsum.f" /> + <f2c_rule Include="wmul.f" /> + <f2c_rule Include="wrscal.f" /> + <f2c_rule Include="wscal.f" /> + <f2c_rule Include="wshrsl.f" /> + <f2c_rule Include="wsign.f" /> + <f2c_rule Include="wsqrt.f" /> + <f2c_rule Include="wswap.f" /> + <f2c_rule Include="wtan.f" /> + <f2c_rule Include="wvmul.f" /> + <f2c_rule Include="wwdiv.f" /> + <f2c_rule Include="wwpow.f" /> + <f2c_rule Include="wwpow1.f" /> + <f2c_rule Include="wwpowe.f" /> + <f2c_rule Include="wwrdiv.f" /> + </ItemGroup> + <ItemGroup> + <None Include="cacsd_f_Import.def" /> + <None Include="Core_f_Import.def" /> + <None Include="eispack_f_Import.def" /> + <None Include="elementary_functions_Import.def" /> + <None Include="Integer_Import.def" /> + <None Include="core_import.def" /> + <None Include="linpack_f_Import.def" /> + <None Include="Output_stream_Import.def" /> + <None Include="polynomials_f_Import.def" /> + <None Include="slatec_f_Import.def" /> + <None Include="sparse_f_Import.def" /> + <None Include="String_Import.def" /> + <None Include="..\..\sci_gateway\elementary_functions_gateway.xml" /> + <None Include="..\..\Makefile.am" /> + </ItemGroup> + <ItemGroup> + <ProjectReference Include="..\..\..\..\tools\Dumpexts\Dumpexts.vcxproj"> + <Project>{3170e4c2-1173-4264-a222-7ee8ccb3ddf7}</Project> + <ReferenceOutputAssembly>false</ReferenceOutputAssembly> + </ProjectReference> + </ItemGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.targets" /> + <ImportGroup Label="ExtensionTargets"> + <Import Project="..\..\..\..\Visual-Studio-settings\f2c.targets" /> + </ImportGroup> +</Project>
\ No newline at end of file diff --git a/modules/elementary_functions/src/fortran/elementary_functions_f2c.vcxproj.filters b/modules/elementary_functions/src/fortran/elementary_functions_f2c.vcxproj.filters new file mode 100755 index 000000000..cf5cc517a --- /dev/null +++ b/modules/elementary_functions/src/fortran/elementary_functions_f2c.vcxproj.filters @@ -0,0 +1,1057 @@ +<?xml version="1.0" encoding="utf-8"?> +<Project ToolsVersion="4.0" xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <ItemGroup> + <Filter Include="Source Files"> + <UniqueIdentifier>{4FC737F1-C7A5-4376-A066-2A32D752A2FF}</UniqueIdentifier> + <Extensions>cpp;c;cc;cxx;def;odl;idl;hpj;bat;asm;asmx</Extensions> + </Filter> + <Filter Include="Header Files"> + <UniqueIdentifier>{93995380-89BD-4b04-88EB-625FBE52EBFB}</UniqueIdentifier> + <Extensions>h;hpp;hxx;hm;inl;inc;xsd</Extensions> + </Filter> + <Filter Include="Resource Files"> + <UniqueIdentifier>{67DA6AB6-F800-4c08-8B7A-83BB121AAD01}</UniqueIdentifier> + <Extensions>rc;ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe;resx;tiff;tif;png;wav</Extensions> + </Filter> + <Filter Include="Fortran files"> + <UniqueIdentifier>{58a4030c-7726-4646-8226-080a545510da}</UniqueIdentifier> + </Filter> + <Filter Include="Libraries Dependencies"> + <UniqueIdentifier>{0faebb5a-9de6-409f-80a5-cb4f3de9dc4e}</UniqueIdentifier> + </Filter> + </ItemGroup> + <ItemGroup> + <ClCompile Include="arcosh.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="bdiag.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="cbal.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="cerr.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="coef.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="comqr3.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="corth.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="cortr.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="coshin.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="cupro.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="cuproi.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="cusum.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="d1mach.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dad.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dadd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dclmat.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="ddif.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="ddpow.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="ddpow1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="ddpowe.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="ddrdiv.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dexpm1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dipow.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dipowe.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dlblks.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dlgama.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dmcopy.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dmmul.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dmmul1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dmprod.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dmsum.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="drdiv.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dsearch.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dset.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dsort.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dsum.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dtild.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dvmul.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dwdiv.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dwpow.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dwpow1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dwpowe.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dwrdiv.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="entier.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="exch.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="franck.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="gdcp2i.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="getdimfromvar.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="getorient.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="hilber.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="i1mach.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="imcopy.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="infinity.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="intp.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="iset.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="isort.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="isova0.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="isoval.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="israt.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="ivimp.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="iwamax.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="kronc.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="kronr.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="lnblnk.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="magic.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="mtran.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="nearfloat.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="orthes.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="ortran.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="pythag.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="rat.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="rcopy.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="rcsort.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="round.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_abs.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_acos.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_asin.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_atan.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_ceil.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_chinesehat.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_clean.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_conj.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_cos.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_cumprod.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_cumsum.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_diag.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_dsearch.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_exp.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_expm.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_eye.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_floor.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_frexp.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_imag.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_imult.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_int.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_isequal.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_isreal.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_kron.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_log.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_log1p.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_matrix.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_maxi.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_nearfloat.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_number_properties.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_ones.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_prod.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_rand.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_rat.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_real.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_round.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_sign.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_sin.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_size.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_spones.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_sqrt.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_sum.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_tan.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_testmatrix.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_tril.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_triu.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_zeros.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="simple.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="split.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="urand.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="vpythag.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wacos.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wasin.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wasum.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="watan.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="waxpy.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wbdiag.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wcerr.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wclmat.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wddiv.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wdiv.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wdotci.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wdotcr.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wdpow.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wdpow1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wdpowe.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wdrdiv.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wexchn.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wexpm1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wipow.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wipowe.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wlog.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wmmul.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wmprod.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wmsum.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wmul.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wrscal.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wscal.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wshrsl.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wsign.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wsqrt.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wswap.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wtan.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wvmul.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wwdiv.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wwpow.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wwpow1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wwpowe.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wwrdiv.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_find.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="find.c"> + <Filter>Source Files</Filter> + </ClCompile> + </ItemGroup> + <ItemGroup> + <f2c_rule Include="arcosh.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="bdiag.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="cbal.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="cerr.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="coef.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="comqr3.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="corth.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="cortr.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="coshin.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="cupro.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="cuproi.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="cusum.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="d1mach.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="dad.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="dadd.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="dclmat.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="ddif.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="ddpow.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="ddpow1.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="ddpowe.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="ddrdiv.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="dexpm1.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="dipow.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="dipowe.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="dlblks.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="dlgama.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="dmcopy.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="dmmul.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="dmmul1.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="dmprod.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="dmsum.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="drdiv.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="dsearch.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="dset.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="dsort.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="dsum.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="dtild.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="dvmul.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="dwdiv.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="dwpow.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="dwpow1.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="dwpowe.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="dwrdiv.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="entier.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="exch.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="franck.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="gdcp2i.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="getdimfromvar.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="getorient.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="hilber.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="i1mach.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="imcopy.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="infinity.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="intp.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="iset.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="isort.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="isova0.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="isoval.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="israt.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="ivimp.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="iwamax.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="kronc.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="kronr.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="lnblnk.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="magic.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="mtran.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="nearfloat.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="orthes.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="ortran.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="pythag.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="rat.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="rcopy.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="rcsort.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="round.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_abs.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_acos.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_asin.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_atan.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_ceil.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_chinesehat.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_clean.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_conj.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_cos.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_cumprod.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_cumsum.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_diag.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_dsearch.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_exp.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_expm.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_eye.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_floor.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_frexp.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_imag.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_imult.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_int.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_isequal.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_isreal.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_kron.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_log.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_log1p.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_matrix.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_maxi.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_nearfloat.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_number_properties.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_ones.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_prod.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_rand.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_rat.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_real.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_round.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_sign.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_sin.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_size.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_spones.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_sqrt.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_sum.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_tan.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_testmatrix.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_tril.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_triu.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_zeros.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="simple.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="split.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="urand.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="vpythag.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wacos.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wasin.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wasum.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="watan.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="waxpy.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wbdiag.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wcerr.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wclmat.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wddiv.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wdiv.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wdotci.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wdotcr.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wdpow.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wdpow1.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wdpowe.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wdrdiv.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wexchn.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wexpm1.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wipow.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wipowe.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wlog.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wmmul.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wmprod.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wmsum.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wmul.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wrscal.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wscal.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wshrsl.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wsign.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wsqrt.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wswap.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wtan.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wvmul.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wwdiv.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wwpow.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wwpow1.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wwpowe.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="wwrdiv.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="find.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_find.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + </ItemGroup> + <ItemGroup> + <None Include="elementary_functions_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="Integer_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="core_import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="Output_stream_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="String_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="..\..\sci_gateway\elementary_functions_gateway.xml" /> + <None Include="..\..\Makefile.am" /> + <None Include="cacsd_f_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="polynomials_f_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="sparse_f_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="eispack_f_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="linpack_f_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="slatec_f_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="Core_f_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + </ItemGroup> +</Project>
\ No newline at end of file diff --git a/modules/elementary_functions/src/fortran/entier.f b/modules/elementary_functions/src/fortran/entier.f new file mode 100755 index 000000000..1499bd3c2 --- /dev/null +++ b/modules/elementary_functions/src/fortran/entier.f @@ -0,0 +1,20 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c +C/MEMBR ADD NAME=ENTIER,SSI=0 +c + subroutine entier(n,d,s) +c + double precision d(*) + integer s(*) + do 10 i=1,n + s(i)=int(d(i)) + 10 continue + return + end diff --git a/modules/elementary_functions/src/fortran/entier.lo b/modules/elementary_functions/src/fortran/entier.lo new file mode 100755 index 000000000..028a9c581 --- /dev/null +++ b/modules/elementary_functions/src/fortran/entier.lo @@ -0,0 +1,12 @@ +# src/fortran/entier.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/entier.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/exch.f b/modules/elementary_functions/src/fortran/exch.f new file mode 100755 index 000000000..0d0ce7a33 --- /dev/null +++ b/modules/elementary_functions/src/fortran/exch.f @@ -0,0 +1,186 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA - Serge STEER +c Copyright (C) INRIA - Francois DELEBECQUE +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine exch(nmax,n,a,z,l,ls1,ls2) +c + integer nmax,n,l,ls1,ls2 + double precision a(nmax,n),z(nmax,n) +c!purpose +c given upper hessenberg matrix a +c with consecutive ls1xls1 and ls2xls2 diagonal blocks (ls1,ls2.le.2) +c starting at row/column l, exch produces equivalence transforma- +c tion zt that exchange the blocks along with their +c eigenvalues. +c +c!calling sequence +c +c subroutine exch(nmax,n,a,z,l,ls1,ls2) +c integer nmax,n,l,ls1,ls2 +c double precision a(nmax,n),z(nmax,n) +c +c nmax the first dimension of a, b and z +c n the order of a, and z +c *a the matrix whose blocks are to be interchanged +c *z upon return this array is multiplied by the column +c transformation zt. +c l the position of the blocks +c ls1 the size of the first block +c ls2 the size of the second block +c +c!auxiliary routines +c drot (blas) +c giv +c max abs (fortran) +c!originator +c Delebecque f. and Steer s. INRIA adapted from exchqz (VanDooren) +c! + integer i,j,l1,l2,l3,li,lj,ll + double precision u(3,4),d,e,f,g,sa,sb + l1=l+1 + ll=ls1+ls2 + if (ll.gt.2) go to 50 +c ** interchange 1x1 and 1x1 blocks via an equivalence +c ** transformation a:=z'*a*z , +c ** where z is givens rotation + f=max(abs(a(l1,l1)),1.0d+0) + sa=a(l1,l1)/f + sb=1.0d+0/f + f=sa-sb*a(l,l) +c construct the column transformation z + g=-sb*a(l,l1) + call giv(f,g,d,e) + call drot(l1,a(1,l),1,a(1,l1),1,e,-d) + call drot(n,z(1,l),1,z(1,l1),1,e,-d) +c construct the row transformation q + call drot(n-l+1,a(l,l),nmax,a(l1,l),nmax,e,-d) + a(l1,l)=0.0d+0 + return +c ** interchange 1x1 and 2x2 blocks via an equivalence +c ** transformation a:=z2'*z1'*a*z1*z2 , +c ** where each zi is a givens rotation + 50 l2=l+2 + if(ls1.eq.2) go to 100 + g=max(abs(a(l,l)),1.0d+0) +c * evaluate the pencil at the eigenvalue corresponding +c * to the 1x1 block + 60 sa=a(l,l)/g + sb=1.0d+0/g + do 80 j=1,2 + lj=l+j + do 80 i=1,3 + li=l+i-1 + u(i,j)=-sb*a(li,lj) + 80 if(li.eq.lj) u(i,j)=u(i,j)+sa + call giv(u(3,1),u(3,2),d,e) + call drot(3,u(1,1),1,u(1,2),1,e,-d) +c perform the row transformation z1' + call giv(u(1,1),u(2,1),d,e) + u(2,2)=-u(1,2)*e+u(2,2)*d + call drot(n-l+1,a(l,l),nmax,a(l1,l),nmax,d,e) +c perform the column transformation z1 + call drot(l2,a(1,l),1,a(1,l1),1,d,e) + call drot(n,z(1,l),1,z(1,l1),1,d,e) +c perform the row transformation z2' + call giv(u(2,2),u(3,2),d,e) + call drot(n-l+1,a(l1,l),nmax,a(l2,l),nmax,d,e) +c perform the column transformation z2 + call drot(l2,a(1,l1),1,a(1,l2),1,d,e) + call drot(n,z(1,l1),1,z(1,l2),1,d,e) +c put the neglectable elements equal to zero + a(l2,l)=0.0d+0 + a(l2,l1)=0.0d+0 + return +c ** interchange 2x2 and 1x1 blocks via an equivalence +c ** transformation a:=z2'*z1'*a*z1*z2 , +c ** where each zi is a givens rotation + 100 if(ls2.eq.2) go to 150 + g=max(abs(a(l2,l2)),1.0d+0) +c * evaluate the pencil at the eigenvalue corresponding +c * to the 1x1 block + 120 sa=a(l2,l2)/g + sb=1.0d+0/g + do 130 i=1,2 + li=l+i-1 + do 130 j=1,3 + lj=l+j-1 + u(i,j)=-sb*a(li,lj) + 130 if(i.eq.j) u(i,j)=u(i,j)+sa + call giv (u(1,1),u(2,1),d,e) + call drot(3,u(1,1),3,u(2,1),3,d,e) +c perform the column transformation z1 + call giv (u(2,2),u(2,3),d,e) + u(1,2)=u(1,2)*e-u(1,3)*d + call drot(l2,a(1,l1),1,a(1,l2),1,e,-d) + call drot(n,z(1,l1),1,z(1,l2),1,e,-d) +c perform the row transformation z1' + call drot(n-l+1,a(l1,l),nmax,a(l2,l),nmax,e,-d) +c perform the column transformation z2 + call giv (u(1,1),u(1,2),d,e) + call drot(l2,a(1,l),1,a(1,l1),1,e,-d) + call drot(n,z(1,l),1,z(1,l1),1,e,-d) +c perform the row transformation z2' + call drot(n-l+1,a(l,l),nmax,a(l1,l),nmax,e,-d) +c put the neglectable elements equal to zero + 140 a(l1,l)=0.0d+0 + a(l2,l)=0.0d+0 + return +c ** interchange 2x2 and 2x2 blocks via a sequence of +c ** equivalence transformations +c ** a:=z5'*z4'*z3'*z2'*z1'*a*z1*z2*z3*z4*z5 +c ** where each zi is a givens rotation + 150 l3=l+3 + d=a(l2,l2)*a(l3,l3)-a(l2,l3)*a(l3,l2) + e=a(l2,l2)+a(l3,l3) + call dmmul(a(l,l),nmax,a(l,l),nmax,u,3,2,4,4) + do 20 i=1,2 + u(i,i)=u(i,i)+d + do 10 j=1,4 + u(i,j)=u(i,j)-e*a(l-1+i,l-1+j) + 10 continue + 20 continue +c g0 + call giv(u(1,1),u(2,1),d,e) + call drot(4,u(1,1),3,u(2,1),3,d,e) +c z1 + call giv(u(2,4),u(2,3),d,e) + call drot(2,u(1,4),1,u(1,3),1,d,e) + call drot(l3,a(1,l3),1,a(1,l2),1,d,e) + call drot(n,z(1,l3),1,z(1,l2),1,d,e) +c z1' + call drot(n-l+1,a(l3,l),nmax,a(l2,l),nmax,d,e) +c z2 + call giv(u(2,4),u(2,2),d,e) + call drot(2,u(1,4),1,u(1,2),1,d,e) + call drot(l3,a(1,l3),1,a(1,l1),1,d,e) + call drot(n,z(1,l3),1,z(1,l1),1,d,e) +c z2' + u(2,4)=d*u(2,4) + call drot(n-l+1,a(l3,l),nmax,a(l1,l),nmax,d,e) +c z3 + call giv(u(1,3),u(1,2),d,e) + call drot(1,u(1,3),1,u(1,2),1,d,e) + call drot(l3,a(1,l2),1,a(1,l1),1,d,e) + call drot(n,z(1,l2),1,z(1,l1),1,d,e) +c z3' + u(2,4)=d*u(2,4) + call drot(n-l+1,a(l2,l),nmax,a(l1,l),nmax,d,e) +c z4 + call giv(u(1,3),u(1,1),d,e) + call drot(l3,a(1,l2),1,a(1,l),1,d,e) + call drot(n,z(1,l2),1,z(1,l),1,d,e) +c z4' + call drot(n-l+1,a(l2,l),nmax,a(l,l),nmax,d,e) +c zeroes negligible elements + a(l2,l)=0.0d+0 + a(l3,l)=0.0d+0 + a(l2,l1)=0.0d+0 + a(l3,l1)=0.0d+0 + return + end diff --git a/modules/elementary_functions/src/fortran/exch.lo b/modules/elementary_functions/src/fortran/exch.lo new file mode 100755 index 000000000..03b78ad82 --- /dev/null +++ b/modules/elementary_functions/src/fortran/exch.lo @@ -0,0 +1,12 @@ +# src/fortran/exch.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/exch.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/find.f b/modules/elementary_functions/src/fortran/find.f new file mode 100755 index 000000000..c8d4ddd11 --- /dev/null +++ b/modules/elementary_functions/src/fortran/find.f @@ -0,0 +1,302 @@ +c ================================================== +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) -2011 - INRIA - Serge Steer +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + +c ================================================== + subroutine intsfind(nmax) +c find of a full standard or boolean matrix + include 'stack.h' + +c + logical ref + integer nmax + integer sadr,iadr +c + iadr(l)=l+l-1 + sadr(l)=(l/2)+1 +c + lw=lstk(top+1) +c + + + il1=iadr(lstk(top)) + ilr=il1 + if(nmax.eq.0) then + nt=nmax + goto 17 + endif + if(istk(il1).lt.0) il1=iadr(istk(il1+1)) + ref=ilr.ne.il1 + + if(istk(il1).eq.1) then +c argument is a standard matrix + m1=istk(il1+1) + mn1=istk(il1+1)*istk(il1+2) + it1=istk(il1+3) + if(it1.ne.0) then + call putfunnam('find',top) + if(nmax.ne.-1) top=top+1 + fun=-1 + return + endif + l1=sadr(il1+4) + if(ref) then + err=sadr(ilr+4)+mn1-lstk(bot) + if(err.gt.0) then + call error(17) + return + endif + call icopy(4,istk(il1),1,istk(ilr),1) + endif + lr=sadr(ilr+4) + l=lr + if(mn1.gt.0) then + if (nmax.lt.0) then +c . get all the occurences + do 11 k=0,mn1-1 + if(stk(l1+k).ne.0.0d0) then + stk(l)=dble(k+1) + l=l+1 + endif + 11 continue + else +c . get at most nmax occurences + do 12 k=0,mn1-1 + if(stk(l1+k).ne.0.0d0) then + stk(l)=dble(k+1) + l=l+1 + if(l-lr.ge.nmax) goto 13 + endif + 12 continue + endif + 13 nt=l-lr + else + nt=0 + endif + elseif(istk(il1).eq.4) then +c argument is a full boolean matrix + m1=istk(il1+1) + mn1=istk(il1+1)*istk(il1+2) + if(.not.ref) then + il=max(il1+3+mn1,iadr(lstk(top)+mn1*lhs)+8) + err=sadr(il+mn1)-lstk(bot) + if(err.gt.0) then + call error(17) + return + endif + call icopy(mn1,istk(il1+3),1,istk(il),1) + else + il=il1+3 + endif + istk(ilr)=1 + lr=sadr(ilr+4) + if(mn1.gt.0) then + l=lr + if(nmax.lt.0) then +c . get all occurrences + do 14 k=0,mn1-1 + if(istk(il+k).ne.1) goto 14 + stk(l)=dble(k+1) + l=l+1 + 14 continue + else +c . get at most nmax occurences + do 15 k=0,mn1-1 + if(istk(il+k).ne.1) goto 15 + stk(l)=dble(k+1) + l=l+1 + if(l-lr.ge.nmax) goto 16 + 15 continue + endif + 16 nt=l-lr + else + nt=0 + endif + endif + 17 istk(ilr)=1 + istk(ilr+1)=min(1,nt) + istk(ilr+2)=nt + istk(ilr+3)=0 + lstk(top+1)=lr+nt + if(lhs.eq.1) goto 999 + top=top+1 + il2=iadr(lstk(top)) + err=sadr(il2+4)+nt-lstk(bot) + if(err.gt.0) then + call error(17) + return + endif + istk(il2)=1 + istk(il2+1)=min(1,nt) + istk(il2+2)=nt + istk(il2+3)=0 + l2=sadr(il2+4) + lstk(top+1)=l2+nt + if(nt.eq.0) goto 999 + do 18 k=0,nt-1 + stk(l2+k)=dble(int((stk(lr+k)-1.0d0)/m1)+1) + stk(lr+k)=stk(lr+k)-(stk(l2+k)-1.0d+0)*m1 + 18 continue + if (lhs.gt.2) then + do k=3,lhs + top=top+1 + ilk=iadr(lstk(top)) + err=sadr(ilk+4)+nt-lstk(bot) + if(err.gt.0) then + call error(17) + return + endif + istk(ilk)=1 + istk(ilk+1)=min(1,nt) + istk(ilk+2)=nt + istk(ilk+3)=0 + lr=sadr(ilk+4) + lstk(top+1)=lr+nt + if (nt.gt.0) then + call dset(nt,1.0D0,stk(lr),1) + endif + enddo + endif + goto 999 +c + 999 return + end + + subroutine intspfind(nmax) + include 'stack.h' + + logical ref + double precision temp + integer sadr,iadr +c + iadr(l)=l+l-1 + sadr(l)=(l/2)+1 +c + lw=lstk(top+1) + + + il1=iadr(lstk(top)) + ilr=il1 + if(nmax.eq.0) then + nt=nmax + goto 17 + endif + if(istk(il1).lt.0) il1=iadr(istk(il1+1)) + ref=ilr.ne.il1 + +c sparse matrix find + m1=istk(il1+1) + n1=istk(il1+2) + it1=istk(il1+3) + if(it1.ne.0) then + call putfunnam('find',top) + if(nmax.ne.-1) top=top+1 + fun=-1 + return + endif + nel1=istk(il1+4) + if(nel1.eq.0) then + nt=0 + lr=sadr(ilr+4) + goto 17 + endif +c + if(.not.ref) then + lr=lw + else + lr=sadr(ilr+4) + endif + err=lr+nel1-lstk(bot) + if(err.gt.0) then + call error(17) + return + endif + + li=il1+5 + lj=li+m1 + + l=lr + ip=lj + + do 10 i=0,m1-1 + ni=istk(li+i) + if(ni.ne.0) then + do 01 ii=0,ni-1 + stk(l+ii)=(i+1)+(istk(ip+ii)-1)*m1 + 01 continue + l=l+ni + ip=ip+ni + endif + 10 continue + +c order the index column wise + call dsort(stk(lr),nel1,istk(iadr(lr+nel1))) + do 11 i=1,int(nel1/2) + temp=stk(lr-1+i) + stk(lr-1+i)=stk(lr+nel1-i) + stk(lr+nel1-i)=temp + 11 continue + + nt=nel1 + if(nmax.ge.0) nt=min(nel1,nmax) + + if(.not.ref) then + l=sadr(il1+4) + call dcopy(nt,stk(lr),1,stk(l),1) + lr=l + endif + + + 17 istk(ilr)=1 + istk(ilr+1)=min(1,nt) + istk(ilr+2)=nt + istk(ilr+3)=0 + lstk(top+1)=lr+nt + if(lhs.eq.1) return + top=top+1 + il2=iadr(lstk(top)) + err=sadr(il2+4)+nt-lstk(bot) + if(err.gt.0) then + call error(17) + return + endif + istk(il2)=1 + istk(il2+1)=min(1,nt) + istk(il2+2)=nt + istk(il2+3)=0 + l2=sadr(il2+4) + lstk(top+1)=l2+nt + if(nt.eq.0) return + do 18 k=0,nt-1 + stk(l2+k)=dble(int((stk(lr+k)-1.0d0)/m1)+1) + stk(lr+k)=stk(lr+k)-(stk(l2+k)-1.0d+0)*m1 + 18 continue + if (lhs.gt.2) then + do k=3,lhs + top=top+1 + ilk=iadr(lstk(top)) + err=sadr(ilk+4)+nt-lstk(bot) + if(err.gt.0) then + call error(17) + return + endif + istk(ilk)=1 + istk(ilk+1)=min(1,nt) + istk(ilk+2)=nt + istk(ilk+3)=0 + lr=sadr(ilk+4) + lstk(top+1)=lr+nt + if (nt.gt.0) then + call dset(nt,1.0D0,stk(lr),1) + endif + enddo + endif + return + end +c ================================================== diff --git a/modules/elementary_functions/src/fortran/find.lo b/modules/elementary_functions/src/fortran/find.lo new file mode 100755 index 000000000..297a16f89 --- /dev/null +++ b/modules/elementary_functions/src/fortran/find.lo @@ -0,0 +1,12 @@ +# src/fortran/find.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/find.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/franck.f b/modules/elementary_functions/src/fortran/franck.f new file mode 100755 index 000000000..9263aad15 --- /dev/null +++ b/modules/elementary_functions/src/fortran/franck.f @@ -0,0 +1,80 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c +C/MEMBR ADD NAME=FRANCK,SSI=0 +c + subroutine franck(a,na,n,job) +c!but +c cette subroutine genere la matrice de franck d'ordre n +c definie par : a(i,j)=j si i.le.j , a(j,j-1)=j , a(i,j)=0 +c si i.gt.j+1 . ou son inverse +c!liste d'appel +c subroutine franck(a,na,n,job) +c +c double precision a(na,n) +c integer na,n,job +c +c a :tableau contenant apres execution la matrice +c na:nombre de ligne du tableau a +c n : dimension de la matrice +c job : entier caracterisant le resultat demande +c job = 0 : matrice de franck +c job = 1 : son inverse +c!sous programme appeles +c dble real (fortran) +c! + double precision a(na,n) +c variables internes + integer n1,k,l,ls + double precision x,dble +c + if(job.eq.1) goto 50 +c + a(1,1)=dble(real(n)) + if(n.eq.1) return + do 20 k=2,n + x=dble(real(n+1-k)) + a(k,k-1)=x + do 10 l=1,k + a(l,k)=x + 10 continue + 20 continue + if(n.eq.2) return + do 40 l=3,n + n1=l-2 + do 40 k=1,n1 + a(l,k)=0.0d+0 + 40 continue + return +c + 50 continue + if(n.eq.1) return + n1=n-1 + do 60 k=1,n1 + a(k,k+1)=-1.0d+0 + a(k+1,k+1)=dble(real(n+1-k)) + 60 continue + a(1,1)=1.0d+0 + do 66 ksd=1,n1 + ls=n-ksd + do 65 l=1,ls + klig=n+1-l + kcol=klig-ksd + a(klig,kcol)=-a(klig-1,kcol)*l + 65 continue + 66 continue +c + if(n.lt.3) return + do 70 kcol=3,n + n1=kcol-2 + do 70 klig=1,n1 + a(klig,kcol)=0.0d+0 + 70 continue + return + end diff --git a/modules/elementary_functions/src/fortran/franck.lo b/modules/elementary_functions/src/fortran/franck.lo new file mode 100755 index 000000000..0866f66c3 --- /dev/null +++ b/modules/elementary_functions/src/fortran/franck.lo @@ -0,0 +1,12 @@ +# src/fortran/franck.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/franck.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/gdcp2i.f b/modules/elementary_functions/src/fortran/gdcp2i.f new file mode 100755 index 000000000..8e9c846d3 --- /dev/null +++ b/modules/elementary_functions/src/fortran/gdcp2i.f @@ -0,0 +1,44 @@ + subroutine gdcp2i(n, itab, m) +c!purpose +c decomposition of an integer n in a base tw0. +c n=a1+a2*2+a3*2**2+.........+am*2**(m-1). +c!calling sequence +c subroutine gdcp2i(n,itab,m) +c integer n,itab,m +c +c n : integer to be decomposed (n.le.32767) +c +c itab :logical vector of dimension 15. +c in output: if(a(i-1).ne.0)then itab(i)=.true. +c else itab(i)=.false. +c +c m :the number of itab elements to be consider in output. +c +c!originator +c j. hanen -september 1978-ensm-nantes. +c! +c + dimension ipow2(15) + logical itab(*) +c + data ipow2(1), ipow2(2), ipow2(3), ipow2(4), ipow2(5), + * ipow2(6), ipow2(7), ipow2(8), ipow2(9), ipow2(10), + * ipow2(11), ipow2(12), ipow2(13), ipow2(14), ipow2(15) + * /16384,8192,4096,2048,1024,512,256,128,64,32,16,8,4,2,1/ +c + m = 0 + k = 15 + nn = abs(n) + if (nn.gt.32767) nn = mod(nn,32767) + do 30 i=1,15 + if (nn.lt.ipow2(i)) go to 10 + itab(k) = .true. + nn = nn - ipow2(i) + if (m.eq.0) m = k + go to 20 + 10 itab(k) = .false. + 20 k = k - 1 + 30 continue +c + return + end diff --git a/modules/elementary_functions/src/fortran/gdcp2i.lo b/modules/elementary_functions/src/fortran/gdcp2i.lo new file mode 100755 index 000000000..b68d85633 --- /dev/null +++ b/modules/elementary_functions/src/fortran/gdcp2i.lo @@ -0,0 +1,12 @@ +# src/fortran/gdcp2i.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/gdcp2i.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/getdimfromvar.f b/modules/elementary_functions/src/fortran/getdimfromvar.f new file mode 100755 index 000000000..029d192bd --- /dev/null +++ b/modules/elementary_functions/src/fortran/getdimfromvar.f @@ -0,0 +1,54 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine getdimfromvar(k,num,n) + integer k,num,n +c + INCLUDE 'stack.h' + integer iadr,sadr + + iadr(l)=l+l-1 + sadr(l)=(l/2)+1 + + il=iadr(lstk(k)) + if(istk(il).lt.0) il=iadr(istk(il+1)) + + if(istk(il).eq.1) then + if(istk(il+3).ne.0) then + err=num + call error(52) + return + endif + if(istk(il+1)*istk(il+2).ne.1) then + err=num + call error(89) + return + endif + if (stk(sadr(il+4)).ge.2.0**31) then !depends on the stack (32 bits...) + call error(17) + return + endif + n=max(int(stk(sadr(il+4))),0) + elseif(istk(il).eq.8) then + if(istk(il+1)*istk(il+2).ne.1) then + err=num + call error(89) + return + endif + call tpconv(istk(il+3),4,1,istk(il+4),1,n,1) + n=max(n,0) + else + err=num + call error(53) + return + endif +c + end +c ------------------------------- + diff --git a/modules/elementary_functions/src/fortran/getdimfromvar.lo b/modules/elementary_functions/src/fortran/getdimfromvar.lo new file mode 100755 index 000000000..78f171833 --- /dev/null +++ b/modules/elementary_functions/src/fortran/getdimfromvar.lo @@ -0,0 +1,12 @@ +# src/fortran/getdimfromvar.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/getdimfromvar.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/getorient.f b/modules/elementary_functions/src/fortran/getorient.f new file mode 100755 index 000000000..594cbd9f8 --- /dev/null +++ b/modules/elementary_functions/src/fortran/getorient.f @@ -0,0 +1,138 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine orientandtype(orient,type) + INCLUDE 'stack.h' + integer orient,type,native + parameter (native=0) + + if(rhs.eq.3) then +c . last argument must be "native" or "double" and previous must be +c . an orientation flag + call getresulttype(top,type) + if (type.lt.0) then + top=top-1 + call getorient(top,orient) + if (err.gt.0.or.err1.gt.0) return + err=3 + if (type.eq.-2) then + call error(55) + elseif (type.eq.-3) then + call error(89) + else + call error(116) + endif + return + endif + top=top-1 + call getorient(top,orient) + if(err.gt.0) return + top=top-1 + elseif(rhs.eq.2) then +c . last argument must be an orientation flag or "native" or "double" + call getresulttype(top,type) + if (type.lt.0) then +c . orientation flag + type=native + call getorient(top,orient) + if(err.gt.0) return + else + orient=0 + endif + top=top-1 + else + type=native + orient=0 + endif + return + end + + subroutine getorient(k,sel) + INCLUDE 'stack.h' +c + integer sel,row,col,star + integer iadr,sadr +c + data row/27/,col/12/,star/47/,mtlb/22/ +c + iadr(l)=l+l-1 + sadr(l)=(l/2)+1 + + sel=-1 + il=iadr(lstk(k)) + if(istk(il).lt.0) il=iadr(istk(il+1)) + if(istk(il).eq.1) then + if(istk(il+1)*istk(il+2).ne.1) then + err=2 + call error(89) + return + endif + sel=stk(sadr(il+4)) + if(sel.lt.1) then + err=2 + call error(44) + return + endif + elseif (istk(il).eq.10) then + if(istk(il+1)*istk(il+2).ne.1) then + err=2 + call error(89) + return + endif + if(istk(il+6).eq.row) then + sel=1 + elseif(istk(il+6).eq.col) then + sel=2 + elseif(istk(il+6).eq.star) then + sel=0 + elseif(istk(il+6).eq.mtlb) then + sel=-1 + else + err=2 + call error(44) + return + endif + else + err=2 + call error(44) + return + endif + return + end + +c ------------------------------- + subroutine getresulttype(k,type) + INCLUDE 'stack.h' + integer type + character*7 temp + integer iadr +c + iadr(l)=l+l-1 + + il=iadr(lstk(k)) + if (istk(il).lt.0) il=iadr(istk(il+1)) + if (istk(il).ne.10) then + type=-2 + elseif (istk(il+1).ne.1.or.istk(il+2).ne.1) then + type=-3 + else + n=min(7,istk(il+5)-1) + id=il+4 + l=id+2 + call codetoascii(min(n,7),istk(l),temp) + if (temp(1:n).eq.'native') then + type=0 + elseif(temp(1:n).eq.'double') then + type=1 + else + type=-1 + endif + endif + return + end diff --git a/modules/elementary_functions/src/fortran/getorient.lo b/modules/elementary_functions/src/fortran/getorient.lo new file mode 100755 index 000000000..af22a78e0 --- /dev/null +++ b/modules/elementary_functions/src/fortran/getorient.lo @@ -0,0 +1,12 @@ +# src/fortran/getorient.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/getorient.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/hilber.f b/modules/elementary_functions/src/fortran/hilber.f new file mode 100755 index 000000000..14c222b81 --- /dev/null +++ b/modules/elementary_functions/src/fortran/hilber.f @@ -0,0 +1,40 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c +C/MEMBR ADD NAME=HILBER,SSI=0 +c + subroutine hilber(a,lda,n) + double precision a(lda,n) +c!but +c hilber genere l'inverse de la matrice de hilbert +c!liste d'appel +c subroutine hilber(a,lda,n) +c double precision a(lda,n) +c +c a : tableau contenant apres execution l'inverse de la matrice +c de hilbert de dimension n +c lda : nombre de ligne de a dans le programme appelant +c n : dimension de la matrice de hilbert +c! + double precision p,r + p = dble(n) + do 20 i = 1, n + if (i.ne.1) p = (dble(n-i+1)*p*dble(n+i-1))/dble(i-1)**2 + r = p*p + a(i,i) = r/dble(2*i-1) + if (i.eq.n) go to 20 + ip1 = i+1 + do 10 j = ip1, n + r = -(dble(n-j+1)*r*(n+j-1))/dble(j-1)**2 + a(i,j) = r/dble(i+j-1) + a(j,i) = a(i,j) + 10 continue + 20 continue + return + end diff --git a/modules/elementary_functions/src/fortran/hilber.lo b/modules/elementary_functions/src/fortran/hilber.lo new file mode 100755 index 000000000..1f1c3e53f --- /dev/null +++ b/modules/elementary_functions/src/fortran/hilber.lo @@ -0,0 +1,12 @@ +# src/fortran/hilber.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/hilber.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/i1mach.f b/modules/elementary_functions/src/fortran/i1mach.f new file mode 100755 index 000000000..90ea8fa43 --- /dev/null +++ b/modules/elementary_functions/src/fortran/i1mach.f @@ -0,0 +1,68 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + INTEGER FUNCTION I1MACH(I) +C Integer machine dependent constants +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 Reference: Fox P.A., Hall A.D., Schryer N.L.,"Framework for a +C Portable Library", ACM Transactions on Mathematical +C Software, Vol. 4, no. 2, June 1978, PP. 177-188. +C + REAL*8 DLAMCH + INTEGER IMACH(16) + DATA IMACH/ 5,6,0,6,32,4,2,31,2147483647,2,0,0,0,0,0,0 / +C +C Get double precision values from DLAMCH + IF (IMACH(16) .EQ. 0) THEN + IMACH(14) = DLAMCH('N') + IMACH(15) = DLAMCH('M') + IMACH(16) = DLAMCH('L') + ENDIF +C + I1MACH=IMACH(I) + RETURN + END diff --git a/modules/elementary_functions/src/fortran/i1mach.lo b/modules/elementary_functions/src/fortran/i1mach.lo new file mode 100755 index 000000000..92b68a4a4 --- /dev/null +++ b/modules/elementary_functions/src/fortran/i1mach.lo @@ -0,0 +1,12 @@ +# src/fortran/i1mach.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/i1mach.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/imcopy.f b/modules/elementary_functions/src/fortran/imcopy.f new file mode 100755 index 000000000..5d21adc1a --- /dev/null +++ b/modules/elementary_functions/src/fortran/imcopy.f @@ -0,0 +1,53 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c +C/MEMBR ADD NAME=IMCOPY,SSI=0 +c + subroutine imcopy(a,na,b,nb,m,n) +c!but +c ce sous programme effectue:b=a +c avec a matrice m lignes et n colonnes +c imcopy utilise un code particulier si les matrices sont +c compactes +c!liste d'appel +c +c subroutine imcopy(a,na,b,nb,m,n) +c integer a(na,n),b(nb,m) +c integer na,nb,m,n +c +c a tableau contenant la matrice a +c na nombre de lignes du tableau a dans le prog appelant +c b,nb definition similaires a :a,na +c m nombre de lignes des matrices a et b +c n nombre de colonnes des matrices a et b +c!sous programmes utilises +c neant +c! + integer a(*),b(*) + integer na,nb,m,n + integer ia,ib,i,j,mn +c + if(na.eq.m .and. nb.eq.m) goto 20 + ia=-na + ib=-nb + do 10 j=1,n + ia=ia+na + ib=ib+nb + do 10 i=1,m + b(ib+i)=a(ia+i) + 10 continue + return + 20 continue +c code pour des matrices compactes + mn=m*n + do 30 i=1,mn + b(i)=a(i) + 30 continue + return + end diff --git a/modules/elementary_functions/src/fortran/imcopy.lo b/modules/elementary_functions/src/fortran/imcopy.lo new file mode 100755 index 000000000..692946e75 --- /dev/null +++ b/modules/elementary_functions/src/fortran/imcopy.lo @@ -0,0 +1,12 @@ +# src/fortran/imcopy.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/imcopy.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/infinity.f b/modules/elementary_functions/src/fortran/infinity.f new file mode 100755 index 000000000..07dea3837 --- /dev/null +++ b/modules/elementary_functions/src/fortran/infinity.f @@ -0,0 +1,21 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + double precision function infinity(x) +c Purpose +c Return infinity value +c Calling sequence +c a = infinity(0.0d) +c + double precision x + + infinity = 1.0d0/x + + return + end diff --git a/modules/elementary_functions/src/fortran/infinity.lo b/modules/elementary_functions/src/fortran/infinity.lo new file mode 100755 index 000000000..9d2340274 --- /dev/null +++ b/modules/elementary_functions/src/fortran/infinity.lo @@ -0,0 +1,12 @@ +# src/fortran/infinity.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/infinity.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/intp.f b/modules/elementary_functions/src/fortran/intp.f new file mode 100755 index 000000000..8f4c35e98 --- /dev/null +++ b/modules/elementary_functions/src/fortran/intp.f @@ -0,0 +1,59 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine intp(x,xd,yd,n,nc,y) +c!purpose +c linear interpolation computes y=F(x) for f a tabulated function +c from R to R^n +c!parameters +c x : x given point +c xd : vector (nc) of abscissae mesh points (xd(i+1)>=xd(i)) +c yd : matrix (nc x n): yd(i,j)=Fj(x(i)) +c n : dimension of F image +c returned values +c y : vector (n) :interpolated value of F(x) +c!remarks +c if x<=xd(1) y=yd(1,:) +c if x>=xd(nc) y=yd(nc,:) +c!origin +c Pejman GOHARI 1996 +c + double precision x,xd(*),y(*),yd(nc,*) + integer n,nc +c + if (nc.eq.1) then + call dcopy(n,yd(1,1),nc,y,1) + elseif(x.ge.xd(nc)) then + call dcopy(n,yd(nc,1),nc,y,1) + elseif(x.le.xd(1)) then + call dcopy(n,yd(1,1),nc,y,1) + else +c find x interval + do 10 i=1,nc + if (x.lt.xd(i)) then + inter=i-1 + goto 20 + endif + 10 continue + 20 continue +c +c compute interpolated y +c + if (xd(inter+1).eq.xd(inter)) then + call dcopy(n,yd(inter,1),nc,y,1) + else + do 40 i=1,n + y(i)=yd(inter,i)+ + & (x-xd(inter))*((yd(inter+1,i)-yd(inter,i))/ + & (xd(inter+1)-xd(inter))) + 40 continue + endif + endif + end + diff --git a/modules/elementary_functions/src/fortran/intp.lo b/modules/elementary_functions/src/fortran/intp.lo new file mode 100755 index 000000000..2651b202f --- /dev/null +++ b/modules/elementary_functions/src/fortran/intp.lo @@ -0,0 +1,12 @@ +# src/fortran/intp.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/intp.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/iset.f b/modules/elementary_functions/src/fortran/iset.f new file mode 100755 index 000000000..565837385 --- /dev/null +++ b/modules/elementary_functions/src/fortran/iset.f @@ -0,0 +1,22 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c +C/MEMBR ADD NAME=ISET,SSI=0 +c + subroutine iset (n, value, array, inc) +c + integer n, value, inc + integer array(*) +c + do 10 i = 1, n + array(i) = value + 10 continue +c + return + end diff --git a/modules/elementary_functions/src/fortran/iset.lo b/modules/elementary_functions/src/fortran/iset.lo new file mode 100755 index 000000000..069d3ff90 --- /dev/null +++ b/modules/elementary_functions/src/fortran/iset.lo @@ -0,0 +1,12 @@ +# src/fortran/iset.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/iset.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/isort.f b/modules/elementary_functions/src/fortran/isort.f new file mode 100755 index 000000000..12be6ce78 --- /dev/null +++ b/modules/elementary_functions/src/fortran/isort.f @@ -0,0 +1,139 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine isort(count,n,index) +c +c!purpose +c isort sort integer array,maintaining an index array +c +c!calling sequence +c subroutine isort(count,n,index) +c integer n,index(n) +c integer count(n) +c +c count : array to be sorted +c n :size of count and index +c index : array containing on return index of sorted array +c +c!method +c quick sort method is used +c!restriction +c n must be less than 2**(50/2) ! due to lengh of work space mark +c + dimension mark(50),index(n) + integer count(n),av,x +c set index array to original order . + do 10 i=1,n + index(i)=i + 10 continue +c check that a trivial case has not been entered . + if(n.eq.1)goto 200 + if(n.ge.1)go to 30 + goto 200 +c 'm' is the length of segment which is short enough to enter +c the final sorting routine. it may be easily changed. + 30 m=12 +c set up initial values. + la=2 + is=1 + if=n + do 190 mloop=1,n +c if segment is short enough sort with final sorting routine . + ifka=if-is + if((ifka+1).gt.m)goto 70 +c********* final sorting *** +c ( a simple bubble sort ) + is1=is+1 + do 60 j=is1,if + i=j + 40 if(count(i-1).gt.count(i))goto 60 + if(count(i-1).lt.count(i))goto 50 + if(index(i-1).lt.index(i))goto 60 + 50 av=count(i-1) + count(i-1)=count(i) + count(i)=av + int=index(i-1) + index(i-1)=index(i) + index(i)=int + i=i-1 + if(i.gt.is)goto 40 + 60 continue + la=la-2 + goto 170 +c ******* quicksort ******** +c select the number in the central position in the segment as +c the test number.replace it with the number from the segment's +c highest address. + 70 iy=(is+if)/2 + x=count(iy) + intest=index(iy) + count(iy)=count(if) + index(iy)=index(if) +c the markers 'i' and 'ifk' are used for the beginning and end +c of the section not so far tested against the present value +c of x . + k=1 + ifk=if +c we alternate between the outer loop that increases i and the +c inner loop that reduces ifk, moving numbers and indices as +c necessary, until they meet . + do 110 i=is,if + if(x.lt.count(i))goto 110 + if(x.gt.count(i))goto 80 + if(intest.gt.index(i))goto 110 + 80 if(i.ge.ifk)goto 120 + count(ifk)=count(i) + index(ifk)=index(i) + k1=k + do 100 k=k1,ifka + ifk=if-k + if(count(ifk).lt.x)goto 100 + if(count(ifk).gt.x)goto 90 + if(intest.le.index(ifk))goto 100 + 90 if(i.ge.ifk)goto 130 + count(i)=count(ifk) + index(i)=index(ifk) + go to 110 + 100 continue + goto 120 + 110 continue +c return the test number to the position marked by the marker +c which did not move last. it divides the initial segment into +c 2 parts. any element in the first part is less than or equal +c to any element in the second part, and they may now be sorted +c independently . + 120 count(ifk)=x + index(ifk)=intest + ip=ifk + goto 140 + 130 count(i)=x + index(i)=intest + ip=i +c store the longer subdivision in workspace. + 140 if((ip-is).gt.(if-ip))goto 150 + mark(la)=if + mark(la-1)=ip+1 + if=ip-1 + goto 160 + 150 mark(la)=ip-1 + mark(la-1)=is + is=ip+1 +c find the length of the shorter subdivision. + 160 lngth=if-is + if(lngth.le.0)goto 180 +c if it contains more than one element supply it with workspace . + la=la+2 + goto 190 + 170 if(la.le.0)goto 200 +c obtain the address of the shortest segment awaiting quicksort + 180 if=mark(la) + is=mark(la-1) + 190 continue + 200 return + end diff --git a/modules/elementary_functions/src/fortran/isort.lo b/modules/elementary_functions/src/fortran/isort.lo new file mode 100755 index 000000000..31dd3ba2a --- /dev/null +++ b/modules/elementary_functions/src/fortran/isort.lo @@ -0,0 +1,12 @@ +# src/fortran/isort.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/isort.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/isova0.f b/modules/elementary_functions/src/fortran/isova0.f new file mode 100755 index 000000000..001efd4c1 --- /dev/null +++ b/modules/elementary_functions/src/fortran/isova0.f @@ -0,0 +1,152 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine isova0(a,lda,m,n,path,kpath,ir,ic,dir,pend, +c + $ h,v,c) +c% but +c Sous programme appele par le sous programme isoval +c% + double precision a(lda,*),c,path(2,*) + integer lda,m,n,h(m,*),v(m-1,*) +c + logical pend + integer north,south,east,west,dir + data north/0/,south/1/,east/2/,west/3/ + +c extend the path at this level by one edge element + + if(dir.eq.north) then + if(v(ir,ic).lt.0) then + if(kpath.gt.1) h(ir,ic)=0 +c path to east + goto 30 + else if(v(ir,ic+1).lt.0) then + if(kpath.gt.1) h(ir,ic)=0 +c path to west + goto 40 + else if(h(ir+1,ic).lt.0) then + if(kpath.gt.1) h(ir,ic)=0 +c path to north + goto 10 + else + pend=.true. + endif + else if(dir.eq.west) then + if(h(ir+1,ic).lt.0) then + if(kpath.gt.1) v(ir,ic)=0 +c path to north + goto 10 + else if(h(ir,ic).lt.0) then + if(kpath.gt.1) v(ir,ic)=0 +c path to south + goto 20 + else if(v(ir,ic+1).lt.0) then + if(kpath.gt.1) v(ir,ic)=0 +c path to west + goto 40 + else + pend=.true. + endif + else if( dir.eq.south) then + if(v(ir,ic+1).lt.0) then + if(kpath.gt.1) h(ir+1,ic)=0 +c path to west + goto 40 + else if(v(ir,ic).lt.0) then + if(kpath.gt.1) h(ir+1,ic)=0 +c path to east + goto 30 + else if(h(ir,ic).lt.0) then + if(kpath.gt.1) h(ir+1,ic)=0 +c path to south + goto 20 + else + pend=.true. + endif + else if(dir.eq.east) then + if(h(ir,ic).lt.0) then + if(kpath.gt.1) v(ir,ic+1)=0 +c path to south + goto 20 + else if(h(ir+1,ic).lt.0) then + if(kpath.gt.1) v(ir,ic+1)=0 +c path to north + goto 10 + else if(v(ir,ic).lt.0) then + if(kpath.gt.1) v(ir,ic+1)=0 +c path to east + goto 30 + else + pend=.true. + endif + endif + return +c + 10 continue +c +c NORTH +c + kpath=kpath+1 + path(2,kpath)=ir+1 + path(1,kpath)=ic+(c-a(ir+1,ic))/(a(ir+1,ic+1)-a(ir+1,ic)) + if(ir+1.lt.m) then + ir=ir+1 + dir=north + else + pend=.true. + endif + return + 20 continue +c +c SOUTH +c + kpath=kpath+1 + path(2,kpath)=ir + path(1,kpath)=ic+(c-a(ir,ic))/(a(ir,ic+1)-a(ir,ic)) + if(ir.gt.1) then + ir=ir-1 + dir=south + else + pend=.true. + endif + return +c + 30 continue +c +c EAST +c + kpath=kpath+1 + path(2,kpath)=ir+(c-a(ir,ic))/(a(ir+1,ic)-a(ir,ic)) + path(1,kpath)=ic + if(ic.gt.1) then + ic=ic-1 + dir=east + else + pend=.true. + endif + return +c + 40 continue +c +c WEST +c + kpath=kpath+1 + path(2,kpath)=ir+(c-a(ir,ic+1))/(a(ir+1,ic+1)-a(ir,ic+1)) + path(1,kpath)=ic+1 + if(ic+1.lt.n) then + ic=ic+1 + dir=west + else + pend=.true. + endif + return +c + end + diff --git a/modules/elementary_functions/src/fortran/isova0.lo b/modules/elementary_functions/src/fortran/isova0.lo new file mode 100755 index 000000000..284356ed4 --- /dev/null +++ b/modules/elementary_functions/src/fortran/isova0.lo @@ -0,0 +1,12 @@ +# src/fortran/isova0.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/isova0.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/isoval.f b/modules/elementary_functions/src/fortran/isoval.f new file mode 100755 index 000000000..a3e232ee3 --- /dev/null +++ b/modules/elementary_functions/src/fortran/isoval.f @@ -0,0 +1,297 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine isoval(a,lda,m,n,c,path,npath,maxp,ierr,iw,job) +c! but +c Etant donnee une matrice A telle que A(l,k)=f(X(l),Y(k)) ou +c f est une fonction de R X R dans R, ce sous programme recherche +c les lignes d'isovaleurs (relatives a la valeur c) de la +c tabulation reguliere ( X(l+1)-X(l)=DX,Y(k+1)-Y(k)=DY ) +c de f donnee par A +c! liste d'appel +c subroutine isoval(a,lda,m,n,c,path,npath,maxp,ierr,iw,job) +c +c double precision a(lda,n),c,path(2,maxp) +c integer iw(m*n-n) +c integer lda,m,n,maxp,ierr,job +c +c a : tableau contenant la tabulation de f +c lda : nombre de lignes du tableau a +c m : nombre de lignes effectif de a +c n : nombre de colonnes de a +c c : valeur pour la quelle on cherche les isovaleurs +c path : contient en sortie la description des isovaleurs: +c path=[path ,...., path ] +c 1 npath +c ou pathi a la structure suivante : +c [np x1,...xnp] +c [0 y1,...ynp] +c si : +c np est la longueur de l'isovaleur +c xj,yj les coordonnees interpolees des points de l'isovaleur +c npath : le nombre de courbes disjointes d'isovaleurs +c maxp : la dimension maximale admise pour le tableau path +c ierr : indicateur d'erreur +c 0 : ok +c 1 : nombre de points decrivant les isovaleur > maxp +c iw : tableau de travail +c job : flag permettant d'indiquer au programme si la fonction f +c est definie sur l'ensemble des points de la matrice A +c job=0 : f definie partout +c job=1 : f n'est pas definie au points A(i,j) si +c iw(i+(j-1)m)=0 +c! origine +c programme par S Steer a partir de la macro scilab de Carey Bunks +c 1990 +c +c Corrige par C Bunks pour isovaleurs qui sont exactement egales +c a des entrees de la matrice 6 mars 1991. +c + double precision a(*),c,path(2,*) + integer iw(*) + integer lda,m,n,maxp,ierr,job +c + logical pend + integer north,south,east,west,dir + data north/0/,south/1/,east/2/,west/3/ +c + ierr=0 +c + kv=1 + kh=kv+m*n + kw=kh+m*(n-1) +c +c perturb values which are exactly equal to the level value + do 5 ip=1,n*m + if(a(ip).eq.c) a(ip)=a(ip)+1d-14 + 5 continue + +c +c make horizontal and vertical edge matrices for level value + if(job.eq.0) then + ih=kh-1 + ia=-lda + do 11 k=1,n-1 + ia=ia+lda + do 10 l=1,m + ih=ih+1 + iw(ih)=1 + if((a(ia+lda+l)-c)*(a(ia+l)-c).lt.0.0d0) iw(ih)=-1 + 10 continue + 11 continue +c + iv=kv-1 + ia=-lda + do 13 k=1,n + ia=ia+lda + do 12 l=1,m-1 + iv=iv+1 + iw(iv)=1 + if((a(ia+l+1)-c)*(a(ia+l)-c).lt.0.0d0) iw(iv)=-1 + 12 continue + 13 continue + else +c + kj=kv +c + ih=kh-1 + ia=-lda + ij=kj-1 + do 21 k=1,n-1 + ia=ia+lda + do 20 l=1,m + ij=ij+1 + ih=ih+1 + iw(ih)=1 + if(iw(ij)*iw(ij+m).eq.0) goto 20 + if((a(ia+lda+l)-c)*(a(ia+l)-c).lt.0.0d0) iw(ih)=-1 + 20 continue + 21 continue +c + iv=kv-1 + ia=-lda + ij=kj-1 + do 23 k=1,n + ia=ia+lda + do 22 l=1,m-1 + iv=iv+1 + ij=ij+1 + iw(iv)=1 + if(iw(ij)*iw(ij+1).eq.0) goto 22 + if((a(ia+l+1)-c)*(a(ia+l)-c).lt.0.0d0) iw(iv)=-1 + 22 continue + ij=ij+1 + 23 continue + endif +c + npath=0 + kpath0=1 + kpath=0 +c +c search pathes (starting with boundaries) +c + +c horizontal boundaries +c northern border + ih=kh-m + ia=1-lda + + do 31 ic=1,n-1 + ih=ih+m + ia=ia+lda + if(iw(ih).lt.0) then + kpath=1 + path(2,kpath0+1)=1.0d0 + path(1,kpath0+1)=ic+(c-a(ia))/(a(ia+lda)-a(ia)) + i=1 + j=ic + dir=north + pend=.false. + 30 call isova0(a,lda,m,n,path(1,kpath0+1),kpath,i,j,dir,pend, + $ iw(kh),iw(kv),c) + if(kpath0+kpath.ge.maxp) goto 999 + if(.not.pend) goto 30 + if(kpath.gt.1) then + path(1,kpath0)=kpath + path(2,kpath0)=0 + kpath0=kpath0+1+kpath + npath=npath+1 + endif + kpath=0 + endif + 31 continue +c +c southern border +c + ih=kh+(m-1)+(n-1)*m + ia=1+(m-1)+(n-1)*lda + do 41 ic=n-1,1,-1 + ih=ih-m + ia=ia-lda + if(iw(ih).lt.0) then + kpath=1 + path(2,kpath0+1)=m + path(1,kpath0+1)=ic+(c-a(ia))/(a(ia+lda)-a(ia)) + i=m-1 + j=ic + dir=south + pend=.false. + 40 call isova0(a,lda,m,n,path(1,kpath0+1),kpath,i,j,dir,pend, + $ iw(kh),iw(kv),c) + if(kpath0+kpath.ge.maxp) goto 999 + if(.not.pend) goto 40 + if(kpath.gt.1) then + path(1,kpath0)=kpath + path(2,kpath0)=0 + kpath0=kpath0+kpath+1 + npath=npath+1 + endif + kpath=0 + endif + 41 continue +c +c vertical boundaries +c +c eastern border + + iv=kv-1+(n-1)*(m-1) + ia=(n-1)*lda + do 51 ir=1,m-1 + iv=iv+1 + ia=ia+1 + if(iw(iv).lt.0) then + kpath=1 + path(2,kpath0+1)=ir+(c-a(ia))/(a(ia+1)-a(ia)) + path(1,kpath0+1)=n + i=ir + j=n-1 + dir=east + pend=.false. + 50 call isova0(a,lda,m,n,path(1,kpath0+1),kpath,i,j,dir,pend, + $ iw(kh),iw(kv),c) + if(kpath0+kpath.ge.maxp) goto 999 + if(.not.pend) goto 50 + if(kpath.gt.1) then + path(1,kpath0)=kpath + path(2,kpath0)=0 + kpath0=kpath0+1+kpath + npath=npath+1 + endif + kpath=0 + endif + 51 continue +c +c western border +c + iv=kv+m-1 + ia=m + do 61 ir=m-1,1,-1 + iv=iv-1 + ia=ia-1 + if(iw(iv).lt.0) then + kpath=1 + path(2,kpath0+1)=ir+(c-a(ia))/(a(ia+1)-a(ia)) + path(1,kpath0+1)=1.0d0 + i=ir + j=1 + dir=west + pend=.false. + 60 call isova0(a,lda,m,n,path(1,kpath0+1),kpath,i,j,dir,pend, + $ iw(kh),iw(kv),c) + if(kpath0+kpath.ge.maxp) goto 999 + if(.not.pend) goto 60 + if(kpath.gt.1) then + path(1,kpath0)=kpath + path(2,kpath0)=0 + kpath0=kpath0+kpath+1 + npath=npath+1 + endif + kpath=0 + endif + 61 continue +c +c all the rest +c + ih=kh-1 + ia1=1-lda + do 72 ic=1,n-1 + ia1=ia1+lda + ia=ia1 + ih=ih+1 + do 71 ir=2,m-1 + ih=ih+1 + ia=ia+1 + if(iw(ih).lt.0) then + kpath=1 + path(2,kpath0+1)=ir + path(1,kpath0+1)=ic+(c-a(ia))/(a(ia+lda)-a(ia)) + i=ir + j=ic + dir=north + pend=.false. + 70 call isova0(a,lda,m,n,path(1,kpath0+1),kpath,i,j,dir, + $ pend,iw(kh),iw(kv),c) + if(kpath0+kpath.ge.maxp) goto 999 + if(.not.pend) goto 70 + if(kpath.gt.1) then + path(1,kpath0)=kpath + path(2,kpath0)=0 + kpath0=kpath0+kpath+1 + npath=npath+1 + endif + kpath=0 + endif + 71 continue + ih=ih+1 + 72 continue + return + 999 ierr=1 + end + + diff --git a/modules/elementary_functions/src/fortran/isoval.lo b/modules/elementary_functions/src/fortran/isoval.lo new file mode 100755 index 000000000..570acabba --- /dev/null +++ b/modules/elementary_functions/src/fortran/isoval.lo @@ -0,0 +1,12 @@ +# src/fortran/isoval.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/isoval.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/israt.f b/modules/elementary_functions/src/fortran/israt.f new file mode 100755 index 000000000..d3360ecd8 --- /dev/null +++ b/modules/elementary_functions/src/fortran/israt.f @@ -0,0 +1,50 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + logical function israt(il,ilnum,ilden,ildom) +c given a scilab variable stored in the stack, beginning at istk(il) +c israt checks is this variable is a rational fraction +c if ok it also returns ilnum and ilden the adress of the beginning +c of the variables (in istk) containing the numerator and the denominator + + INCLUDE 'stack.h' + integer iadr, sadr +c + iadr(l)=l+l-1 + sadr(l)=(l/2)+1 +c + israt=.false. + +c check if variable is a mlist or tlist (for compatibility) + if(istk(il).ne.16.and.istk(il).ne.17) return + +c check if mlist has 4 elements + if(istk(il+1).ne.4) return + +c check if first element is a character string vector + ll=sadr(il+7) + ill=iadr(ll) + if(istk(ill).ne.10) return + +c check if first entry of the character string vector is 'r' + if(abs(istk(ill+5+istk(ill+1)*istk(ill+2))).ne.27) return + +c check second and third tlist components + ilnum=iadr(ll+istk(il+3)-1) + + if(istk(ilnum).gt.2) return + + ilden=iadr(ll+istk(il+4)-1) + if(istk(ilden).gt.2) return + + ildom=iadr(ll+istk(il+5)-1) + + israt=.true. + return + end diff --git a/modules/elementary_functions/src/fortran/israt.lo b/modules/elementary_functions/src/fortran/israt.lo new file mode 100755 index 000000000..941cabec0 --- /dev/null +++ b/modules/elementary_functions/src/fortran/israt.lo @@ -0,0 +1,12 @@ +# src/fortran/israt.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/israt.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/ivimp.f b/modules/elementary_functions/src/fortran/ivimp.f new file mode 100755 index 000000000..41f41131f --- /dev/null +++ b/modules/elementary_functions/src/fortran/ivimp.f @@ -0,0 +1,19 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine ivimp(i1,i2,pas,iv) +c generate iv=i1:pas:i2 +c + integer i1,i2,pas,iv(*) + k=0 + do 10 i=i1,i2,pas + k=k+1 + iv(k)=i + 10 continue + end diff --git a/modules/elementary_functions/src/fortran/ivimp.lo b/modules/elementary_functions/src/fortran/ivimp.lo new file mode 100755 index 000000000..c9f38e348 --- /dev/null +++ b/modules/elementary_functions/src/fortran/ivimp.lo @@ -0,0 +1,12 @@ +# src/fortran/ivimp.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ivimp.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/iwamax.f b/modules/elementary_functions/src/fortran/iwamax.f new file mode 100755 index 000000000..c95fbe79f --- /dev/null +++ b/modules/elementary_functions/src/fortran/iwamax.f @@ -0,0 +1,43 @@ + integer function iwamax(n,xr,xi,incx) +c!but +c +c la fonction iwamax determine l'indice de la composante +c de plus grande norme l1 d'un vecteur complexe dont les +c parties reelles des composantes sont rangees dans le +c vecteur double precision xr et les parties imaginaires +c dans le vecteur xi. +c +c!liste d'appel +c +c integer function iwamax(n,xr,xi,incx) +c +c n: taille du vecteur +c +c xr, xi: vecteurs double precision qui contiennent, +c respectivement, les parties reelles et imaginaires +c des composantes du vecteur a traiter. +c +c incx: increment entre deux elements consecitifs des +c vecteurs xr ou xi. +c +c!auteur +c +c cleve moler.- mathlab. +c +c! + double precision xr(*),xi(*),s,p +c index of norminf(x) + k = 0 + if (n .le. 0) go to 20 + k = 1 + s = 0.0d+0 + ix = 1 + do 10 i = 1, n + p = abs(xr(ix)) + abs(xi(ix)) + if (p .gt. s) k = i + if (p .gt. s) s = p + ix = ix + incx + 10 continue + 20 iwamax = k + return + end diff --git a/modules/elementary_functions/src/fortran/iwamax.lo b/modules/elementary_functions/src/fortran/iwamax.lo new file mode 100755 index 000000000..0168f8652 --- /dev/null +++ b/modules/elementary_functions/src/fortran/iwamax.lo @@ -0,0 +1,12 @@ +# src/fortran/iwamax.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/iwamax.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/kronc.f b/modules/elementary_functions/src/fortran/kronc.f new file mode 100755 index 000000000..39dd668ec --- /dev/null +++ b/modules/elementary_functions/src/fortran/kronc.f @@ -0,0 +1,58 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c +C/MEMBR ADD NAME=KRONC,SSI=0 +c + subroutine kronc(ar,ai,ia,ma,na,br,bi,ib,mb,nb,pkr,pki,ik) +c!but +c ce sous programme genere le produit de kronecker de deux matrices +c a et b complexes pk(i,j)=a(i,j)*b +c!liste d'appel +c subroutine kronc(ar,ai,ia,ma,na,br,bi,ib,mb,nb,pkr,pki,ik) +c double precision ar(*),ai(*),br(*),bi(*),pkr(*),pki(*) +c integer ia,ma,na,ib,mb,nb,ik +c +c ar,ai : tableaux contenant les parties reelles et imaginaires +c de la matrice a +c ia : increment entre 2 elements consecutif d'une meme +c ligne de a +c ma : nombre de lignes de a +c na : nombre de colonnes dea +c br,bi,ib,mb,nb : definitions similaires pour la matrice b +c pkr,pki : tableaux contenant les parties reelles et imaginaires +c du resultat +c ik : increment entre deux elements consecutifs d'une meme +c ligne de pk +c! + integer ia,ma,na,ib,mb,nb,ik,ka,kb,kk,ka1,kk1,l1 + double precision ar(*),ai(*),br(*),bi(*),pkr(*),pki(*) +c + ka1=1-ia + kk1=-nb + do 30 ja=1,na + kb=1 + ka1=ka1+ia + kk1=kk1+nb + do 20 jb=1,nb + ka=ka1 + kk=1+(jb-1+kk1)*ik + do 10 i=1,ma + do 5 l=1,mb + l1=l-1 + pkr(kk+l1)=ar(ka)*br(kb+l1)-ai(ka)*bi(kb+l1) + pki(kk+l1)=ar(ka)*bi(kb+l1)+ai(ka)*br(kb+l1) + 5 continue + kk=kk+mb + ka=ka+1 + 10 continue + kb=kb+ib + 20 continue + 30 continue + return + end diff --git a/modules/elementary_functions/src/fortran/kronc.lo b/modules/elementary_functions/src/fortran/kronc.lo new file mode 100755 index 000000000..51317b768 --- /dev/null +++ b/modules/elementary_functions/src/fortran/kronc.lo @@ -0,0 +1,12 @@ +# src/fortran/kronc.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/kronc.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/kronr.f b/modules/elementary_functions/src/fortran/kronr.f new file mode 100755 index 000000000..42f731f58 --- /dev/null +++ b/modules/elementary_functions/src/fortran/kronr.f @@ -0,0 +1,52 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine kronr(a,ia,ma,na,b,ib,mb,nb,pk,ik) +c +c!but +c ce sous programme genere le produit de kronecker de deux matrices +c a et b pk(i,j)=a(i,j)*b +c!liste d'appel +c subroutine kronr(a,ia,ma,na,b,ib,mb,nb,pk,ik) +c double precision a(ia,na),b(ib,nb),pk(ik,*) +c integer ia,ma,na,ib,mb,nb,ik +c +c a : tableau contenant la matrice a +c ia : increment entre 2 elements consecutif d'une meme +c ligne de a +c ma : nombre de lignes de a +c na : nombre de colonnes dea +c b,ib,mb,nb : definitions similaires pour la matrice b +c pk : tableau contenant la matrice resultat pk +c ik : increment entre deux elements consecutifs d'une meme +c ligne de pk +c! + double precision a(*),b(*),pk(*) + integer ia,ma,na,ib,mb,nb,ik,ka,kb,kk,ka1,kk1 +c + ka1=1-ia + kk1=-nb + do 30 ja=1,na + kb=1 + ka1=ka1+ia + kk1=kk1+nb + do 20 jb=1,nb + ka=ka1 + kk=1+(jb-1+kk1)*ik + do 10 i=1,ma + call dcopy(mb,b(kb),1,pk(kk),1) + call dscal(mb,a(ka),pk(kk),1) + kk=kk+mb + ka=ka+1 + 10 continue + kb=kb+ib + 20 continue + 30 continue + return + end diff --git a/modules/elementary_functions/src/fortran/kronr.lo b/modules/elementary_functions/src/fortran/kronr.lo new file mode 100755 index 000000000..ad6d0c95a --- /dev/null +++ b/modules/elementary_functions/src/fortran/kronr.lo @@ -0,0 +1,12 @@ +# src/fortran/kronr.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/kronr.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/linpack/.deps/.dirstamp b/modules/elementary_functions/src/fortran/linpack/.deps/.dirstamp new file mode 100755 index 000000000..e69de29bb --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/.deps/.dirstamp diff --git a/modules/elementary_functions/src/fortran/linpack/.dirstamp b/modules/elementary_functions/src/fortran/linpack/.dirstamp new file mode 100755 index 000000000..e69de29bb --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/.dirstamp diff --git a/modules/elementary_functions/src/fortran/linpack/.libs/dgbfa.o b/modules/elementary_functions/src/fortran/linpack/.libs/dgbfa.o Binary files differnew file mode 100755 index 000000000..17924aa9c --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/.libs/dgbfa.o diff --git a/modules/elementary_functions/src/fortran/linpack/.libs/dgeco.o b/modules/elementary_functions/src/fortran/linpack/.libs/dgeco.o Binary files differnew file mode 100755 index 000000000..0f38cf3cd --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/.libs/dgeco.o diff --git a/modules/elementary_functions/src/fortran/linpack/.libs/dgedi.o b/modules/elementary_functions/src/fortran/linpack/.libs/dgedi.o Binary files differnew file mode 100755 index 000000000..bf44d865e --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/.libs/dgedi.o diff --git a/modules/elementary_functions/src/fortran/linpack/.libs/dgefa.o b/modules/elementary_functions/src/fortran/linpack/.libs/dgefa.o Binary files differnew file mode 100755 index 000000000..b29f6e4f8 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/.libs/dgefa.o diff --git a/modules/elementary_functions/src/fortran/linpack/.libs/dgesl.o b/modules/elementary_functions/src/fortran/linpack/.libs/dgesl.o Binary files differnew file mode 100755 index 000000000..04de036eb --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/.libs/dgesl.o diff --git a/modules/elementary_functions/src/fortran/linpack/.libs/dpofa.o b/modules/elementary_functions/src/fortran/linpack/.libs/dpofa.o Binary files differnew file mode 100755 index 000000000..898bf3c9f --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/.libs/dpofa.o diff --git a/modules/elementary_functions/src/fortran/linpack/.libs/dqrdc.o b/modules/elementary_functions/src/fortran/linpack/.libs/dqrdc.o Binary files differnew file mode 100755 index 000000000..10d761886 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/.libs/dqrdc.o diff --git a/modules/elementary_functions/src/fortran/linpack/.libs/dqrsl.o b/modules/elementary_functions/src/fortran/linpack/.libs/dqrsl.o Binary files differnew file mode 100755 index 000000000..fac639ffe --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/.libs/dqrsl.o diff --git a/modules/elementary_functions/src/fortran/linpack/.libs/dqrsm.o b/modules/elementary_functions/src/fortran/linpack/.libs/dqrsm.o Binary files differnew file mode 100755 index 000000000..94b9a3c38 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/.libs/dqrsm.o diff --git a/modules/elementary_functions/src/fortran/linpack/.libs/hhdml.o b/modules/elementary_functions/src/fortran/linpack/.libs/hhdml.o Binary files differnew file mode 100755 index 000000000..1114701fe --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/.libs/hhdml.o diff --git a/modules/elementary_functions/src/fortran/linpack/.libs/icopy.o b/modules/elementary_functions/src/fortran/linpack/.libs/icopy.o Binary files differnew file mode 100755 index 000000000..f94092001 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/.libs/icopy.o diff --git a/modules/elementary_functions/src/fortran/linpack/.libs/pade.o b/modules/elementary_functions/src/fortran/linpack/.libs/pade.o Binary files differnew file mode 100755 index 000000000..6f154d241 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/.libs/pade.o diff --git a/modules/elementary_functions/src/fortran/linpack/.libs/util.o b/modules/elementary_functions/src/fortran/linpack/.libs/util.o Binary files differnew file mode 100755 index 000000000..2c161cdcc --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/.libs/util.o diff --git a/modules/elementary_functions/src/fortran/linpack/.libs/wgeco.o b/modules/elementary_functions/src/fortran/linpack/.libs/wgeco.o Binary files differnew file mode 100755 index 000000000..2934d51e4 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/.libs/wgeco.o diff --git a/modules/elementary_functions/src/fortran/linpack/.libs/wgefa.o b/modules/elementary_functions/src/fortran/linpack/.libs/wgefa.o Binary files differnew file mode 100755 index 000000000..18010d010 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/.libs/wgefa.o diff --git a/modules/elementary_functions/src/fortran/linpack/.libs/wgesl.o b/modules/elementary_functions/src/fortran/linpack/.libs/wgesl.o Binary files differnew file mode 100755 index 000000000..23d2f1e33 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/.libs/wgesl.o diff --git a/modules/elementary_functions/src/fortran/linpack/.libs/wpade.o b/modules/elementary_functions/src/fortran/linpack/.libs/wpade.o Binary files differnew file mode 100755 index 000000000..7d15c1719 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/.libs/wpade.o diff --git a/modules/elementary_functions/src/fortran/linpack/Elementary_functions_Import.def b/modules/elementary_functions/src/fortran/linpack/Elementary_functions_Import.def new file mode 100755 index 000000000..295468dbd --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/Elementary_functions_Import.def @@ -0,0 +1,7 @@ + LIBRARY elementary_functions.dll + + +EXPORTS +; +;elementary_functions +dcoeff_ diff --git a/modules/elementary_functions/src/fortran/linpack/Elementary_functions_f_Import.def b/modules/elementary_functions/src/fortran/linpack/Elementary_functions_f_Import.def new file mode 100755 index 000000000..52d0296b4 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/Elementary_functions_f_Import.def @@ -0,0 +1,25 @@ + LIBRARY elementary_functions_f.dll + + +EXPORTS +; +;elementary_functions_f +dmcopy_ +dmmul_ +dclmat_ +cerr_ +coef_ +sdot_ +wdotci_ +wdotcr_ +waxpy_ +wmul_ +wdiv_ +wrscal_ +wsign_ +wasum_ +wscal_ +iwamax_ +wmmul_ +wclmat_ +wcerr_
\ No newline at end of file diff --git a/modules/elementary_functions/src/fortran/linpack/dgbfa.f b/modules/elementary_functions/src/fortran/linpack/dgbfa.f new file mode 100755 index 000000000..0373fd792 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/dgbfa.f @@ -0,0 +1,180 @@ + subroutine dgbfa(abd,lda,n,ml,mu,ipvt,info) + integer lda,n,ml,mu,ipvt(*),info + double precision abd(lda,*) +c!purpose +c +c dgbfa factors a double precision band matrix by elimination. +c +c dgbfa is usually called by dgbco, but it can be called +c directly with a saving in time if rcond is not needed. +c +c!calling sequence +c +c subroutine dgbfa(abd,lda,n,ml,mu,ipvt,info) +c on entry +c +c abd double precision(lda, n) +c contains the matrix in band storage. the columns +c of the matrix are stored in the columns of abd and +c the diagonals of the matrix are stored in rows +c ml+1 through 2*ml+mu+1 of abd . +c see the comments below for details. +c +c lda integer +c the leading dimension of the array abd . +c lda must be .ge. 2*ml + mu + 1 . +c +c n integer +c the order of the original matrix. +c +c ml integer +c number of diagonals below the main diagonal. +c 0 .le. ml .lt. n . +c +c mu integer +c number of diagonals above the main diagonal. +c 0 .le. mu .lt. n . +c more efficient if ml .le. mu . +c on return +c +c abd an upper triangular matrix in band storage and +c the multipliers 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 dgbsl will divide by zero if +c called. use rcond in dgbco for a reliable +c indication of singularity. +c +c band storage +c +c if a is a band matrix, the following program segment +c will set up the input. +c +c ml = (band width below the diagonal) +c mu = (band width above the diagonal) +c m = ml + mu + 1 +c do 20 j = 1, n +c i1 = max(1, j-mu) +c i2 = min(n, j+ml) +c do 10 i = i1, i2 +c k = i - j + m +c abd(k,j) = a(i,j) +c 10 continue +c 20 continue +c +c this uses rows ml+1 through 2*ml+mu+1 of abd . +c in addition, the first ml rows in abd are used for +c elements generated during the triangularization. +c the total number of rows needed in abd is 2*ml+mu+1 . +c the ml+mu by ml+mu upper left triangle and the +c ml by ml lower right triangle are not referenced. +c +c!originator +c linpack. this version dated 08/14/78 . +c cleve moler, university of new mexico, argonne national lab. +c +c!auxiliary routines +c +c blas daxpy,dscal,idamax +c fortran max,min +c +c! +c internal variables +c + double precision t + integer i,idamax,i0,j,ju,jz,j0,j1,k,kp1,l,lm,m,mm,nm1 +c +c + m = ml + mu + 1 + info = 0 +c +c zero initial fill-in columns +c + j0 = mu + 2 + j1 = min(n,m) - 1 + if (j1 .lt. j0) go to 30 + do 20 jz = j0, j1 + i0 = m + 1 - jz + do 10 i = i0, ml + abd(i,jz) = 0.0d+0 + 10 continue + 20 continue + 30 continue + jz = j1 + ju = 0 +c +c gaussian elimination with partial pivoting +c + nm1 = n - 1 + if (nm1 .lt. 1) go to 130 + do 120 k = 1, nm1 + kp1 = k + 1 +c +c zero next fill-in column +c + jz = jz + 1 + if (jz .gt. n) go to 50 + if (ml .lt. 1) go to 50 + do 40 i = 1, ml + abd(i,jz) = 0.0d+0 + 40 continue + 50 continue +c +c find l = pivot index +c + lm = min(ml,n-k) + l = idamax(lm+1,abd(m,k),1) + m - 1 + ipvt(k) = l + k - m +c +c zero pivot implies this column already triangularized +c + if (abd(l,k) .eq. 0.0d+0) go to 100 +c +c interchange if necessary +c + if (l .eq. m) go to 60 + t = abd(l,k) + abd(l,k) = abd(m,k) + abd(m,k) = t + 60 continue +c +c compute multipliers +c + t = -1.0d+0/abd(m,k) + call dscal(lm,t,abd(m+1,k),1) +c +c row elimination with column indexing +c + ju = min(max(ju,mu+ipvt(k)),n) + mm = m + if (ju .lt. kp1) go to 90 + do 80 j = kp1, ju + l = l - 1 + mm = mm - 1 + t = abd(l,j) + if (l .eq. mm) go to 70 + abd(l,j) = abd(mm,j) + abd(mm,j) = t + 70 continue + call daxpy(lm,t,abd(m+1,k),1,abd(mm+1,j),1) + 80 continue + 90 continue + go to 110 + 100 continue + info = k + 110 continue + 120 continue + 130 continue + ipvt(n) = n + if (abd(m,n) .eq. 0.0d+0) info = n + return + end diff --git a/modules/elementary_functions/src/fortran/linpack/dgbfa.lo b/modules/elementary_functions/src/fortran/linpack/dgbfa.lo new file mode 100755 index 000000000..058be5b45 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/dgbfa.lo @@ -0,0 +1,12 @@ +# src/fortran/linpack/dgbfa.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dgbfa.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/linpack/dgeco.f b/modules/elementary_functions/src/fortran/linpack/dgeco.f new file mode 100755 index 000000000..0d0591080 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/dgeco.f @@ -0,0 +1,199 @@ + subroutine dgeco(a,lda,n,ipvt,rcond,z) + integer lda,n,ipvt(*) + double precision a(lda,*),z(*) + double precision rcond +c!purpose +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!calling sequence +c +c subroutine dgeco(a,lda,n,ipvt,rcond,z) +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!originator +c linpack. this version dated 08/14/78 . +c cleve moler, university of new mexico, argonne national lab. +c +c!auxiliary routines +c +c linpack dgefa +c blas daxpy,ddot,dscal,dasum +c fortran abs,max,sign +c +c! +c internal variables +c + double precision ddot,ek,t,wk,wkm + double precision anorm,s,dasum,sm,ynorm + integer info,j,k,kb,kp1,l +c +c +c compute 1-norm of a +c + anorm = 0.0d+0 + 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.0d+0 + do 20 j = 1, n + z(j) = 0.0d+0 + 20 continue + do 100 k = 1, n + if (z(k) .ne. 0.0d+0) 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.0d+0) go to 40 + wk = wk/a(k,k) + wkm = wkm/a(k,k) + go to 50 + 40 continue + wk = 1.0d+0 + wkm = 1.0d+0 + 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.0d+0/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.0d+0) go to 110 + s = 1.0d+0/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.0d+0/dasum(n,z,1) + call dscal(n,s,z,1) +c + ynorm = 1.0d+0 +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.0d+0) go to 130 + s = 1.0d+0/abs(z(k)) + call dscal(n,s,z,1) + ynorm = s*ynorm + 130 continue + 140 continue + s = 1.0d+0/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.0d+0) z(k) = z(k)/a(k,k) + if (a(k,k) .eq. 0.0d+0) z(k) = 1.0d+0 + t = -z(k) + call daxpy(k-1,t,a(1,k),1,z(1),1) + 160 continue +c make znorm = 1.0 + s = 1.0d+0/dasum(n,z,1) + call dscal(n,s,z,1) + ynorm = s*ynorm +c + if (anorm .ne. 0.0d+0) rcond = ynorm/anorm + if (anorm .eq. 0.0d+0) rcond = 0.0d+0 + return + end diff --git a/modules/elementary_functions/src/fortran/linpack/dgeco.lo b/modules/elementary_functions/src/fortran/linpack/dgeco.lo new file mode 100755 index 000000000..4aa013e86 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/dgeco.lo @@ -0,0 +1,12 @@ +# src/fortran/linpack/dgeco.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dgeco.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/linpack/dgedi.f b/modules/elementary_functions/src/fortran/linpack/dgedi.f new file mode 100755 index 000000000..1fb8f5a37 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/dgedi.f @@ -0,0 +1,134 @@ + subroutine dgedi(a,lda,n,ipvt,det,work,job) + integer lda,n,ipvt(*),job + double precision a(lda,*),det(2),work(*) +c!purpose +c +c dgedi computes the determinant and inverse of a matrix +c using the factors computed by dgeco or dgefa. +c +c!calling sequence +c +c subroutine dgedi(a,lda,n,ipvt,det,work,job) +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 work double precision(n) +c work vector. contents destroyed. +c +c job integer +c = 11 both determinant and inverse. +c = 01 inverse only. +c = 10 determinant only. +c +c on return +c +c a inverse of original matrix if requested. +c otherwise unchanged. +c +c det double precision(2) +c determinant of original matrix if requested. +c otherwise not referenced. +c determinant = det(1) * 10.0**det(2) +c with 1.0 .le. abs(det(1)) .lt. 10.0 +c or det(1) .eq. 0.0 . +c +c error condition +c +c a division by zero will occur if the input factor contains +c a zero on the diagonal and the inverse is requested. +c it will not occur if the subroutines are called correctly +c and if dgeco has set rcond .gt. 0.0 or dgefa has set +c info .eq. 0 . +c +c!originator +c linpack. this version dated 08/14/78 . +c cleve moler, university of new mexico, argonne national lab. +c +c!auxiliary routines +c +c blas daxpy,dscal,dswap +c fortran abs,mod +c +c! +c internal variables +c + double precision t + double precision ten + integer i,j,k,kb,kp1,l,nm1 +c +c +c compute determinant +c + if (job/10 .eq. 0) go to 70 + det(1) = 1.0d+0 + det(2) = 0.0d+0 + ten = 10.0d+0 + do 50 i = 1, n + if (ipvt(i) .ne. i) det(1) = -det(1) + det(1) = a(i,i)*det(1) +c ...exit + if (det(1) .eq. 0.0d+0) go to 60 + 10 if (abs(det(1)) .ge. 1.0d+0) go to 20 + det(1) = ten*det(1) + det(2) = det(2) - 1.0d+0 + go to 10 + 20 continue + 30 if (abs(det(1)) .lt. ten) go to 40 + det(1) = det(1)/ten + det(2) = det(2) + 1.0d+0 + go to 30 + 40 continue + 50 continue + 60 continue + 70 continue +c +c compute inverse(u) +c + if (mod(job,10) .eq. 0) go to 150 + do 100 k = 1, n + a(k,k) = 1.0d+0/a(k,k) + t = -a(k,k) + call dscal(k-1,t,a(1,k),1) + kp1 = k + 1 + if (n .lt. kp1) go to 90 + do 80 j = kp1, n + t = a(k,j) + a(k,j) = 0.0d+0 + call daxpy(k,t,a(1,k),1,a(1,j),1) + 80 continue + 90 continue + 100 continue +c +c form inverse(u)*inverse(l) +c + nm1 = n - 1 + if (nm1 .lt. 1) go to 140 + do 130 kb = 1, nm1 + k = n - kb + kp1 = k + 1 + do 110 i = kp1, n + work(i) = a(i,k) + a(i,k) = 0.0d+0 + 110 continue + do 120 j = kp1, n + t = work(j) + call daxpy(n,t,a(1,j),1,a(1,k),1) + 120 continue + l = ipvt(k) + if (l .ne. k) call dswap(n,a(1,k),1,a(1,l),1) + 130 continue + 140 continue + 150 continue + return + end diff --git a/modules/elementary_functions/src/fortran/linpack/dgedi.lo b/modules/elementary_functions/src/fortran/linpack/dgedi.lo new file mode 100755 index 000000000..18a960f27 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/dgedi.lo @@ -0,0 +1,12 @@ +# src/fortran/linpack/dgedi.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dgedi.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/linpack/dgefa.f b/modules/elementary_functions/src/fortran/linpack/dgefa.f new file mode 100755 index 000000000..9f57fd96b --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/dgefa.f @@ -0,0 +1,109 @@ + subroutine dgefa(a,lda,n,ipvt,info) + integer lda,n,ipvt(*),info + double precision a(lda,*) +c!purpose +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!calling sequence +c +c subroutine dgefa(a,lda,n,ipvt,info) +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!originator +c linpack. this version dated 08/14/78 . +c cleve moler, university of new mexico, argonne national lab. +c +c!auxiliary routines +c +c blas daxpy,dscal,idamax +c +c! +c internal variables +c + double precision t + integer idamax,j,k,kp1,l,nm1 +c +c +c gaussian elimination with partial pivoting +c + 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.0d+0) 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.0d+0/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.0d+0) info = n + return + end diff --git a/modules/elementary_functions/src/fortran/linpack/dgefa.lo b/modules/elementary_functions/src/fortran/linpack/dgefa.lo new file mode 100755 index 000000000..6ba92c927 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/dgefa.lo @@ -0,0 +1,12 @@ +# src/fortran/linpack/dgefa.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dgefa.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/linpack/dgesl.f b/modules/elementary_functions/src/fortran/linpack/dgesl.f new file mode 100755 index 000000000..1d38e62e1 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/dgesl.f @@ -0,0 +1,123 @@ + subroutine dgesl(a,lda,n,ipvt,b,job) + integer lda,n,ipvt(*),job + double precision a(lda,*),b(*) +c!purpose +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!calling sequence +c +c subroutine dgesl(a,lda,n,ipvt,b,job) +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!originator +c linpack. this version dated 08/14/78 . +c cleve moler, university of new mexico, argonne national lab. +c +c!auxiliary routines +c +c blas daxpy,ddot +c +c! +c internal variables +c + double precision ddot,t + integer k,kb,l,nm1 +c + 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/modules/elementary_functions/src/fortran/linpack/dgesl.lo b/modules/elementary_functions/src/fortran/linpack/dgesl.lo new file mode 100755 index 000000000..f5e9ac896 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/dgesl.lo @@ -0,0 +1,12 @@ +# src/fortran/linpack/dgesl.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dgesl.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/linpack/dpofa.f b/modules/elementary_functions/src/fortran/linpack/dpofa.f new file mode 100755 index 000000000..f2a8c3e91 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/dpofa.f @@ -0,0 +1,78 @@ + subroutine dpofa(a,lda,n,info) + integer lda,n,info + double precision a(lda,*) +c!purpose +c +c dpofa factors a double precision symmetric positive definite +c matrix. +c +c dpofa is usually called by dpoco, but it can be called +c directly with a saving in time if rcond is not needed. +c (time for dpoco) = (1 + 18/n)*(time for dpofa) . +c +c!calling sequence +c +c subroutine dpofa(a,lda,n,info) +c on entry +c +c a double precision(lda, n) +c the symmetric matrix to be factored. only the +c 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 an upper triangular matrix r so that a = trans(r)*r +c where trans(r) is the transpose. +c the strict lower triangle is unaltered. +c if info .ne. 0 , the factorization is not complete. +c +c info integer +c = 0 for normal return. +c = k signals an error condition. the leading minor +c of order k is not positive definite. +c +c!originator +c linpack. this version dated 08/14/78 . +c cleve moler, university of new mexico, argonne national lab. +c +c!auxiliary routines +c +c blas ddot +c fortran sqrt +c +c! +c internal variables +c + double precision ddot,t + double precision s + integer j,jm1,k +c begin block with ...exits to 40 +c +c + do 30 j = 1, n + info = j + s = 0.0d+0 + jm1 = j - 1 + if (jm1 .lt. 1) go to 20 + do 10 k = 1, jm1 + t = a(k,j) - ddot(k-1,a(1,k),1,a(1,j),1) + t = t/a(k,k) + a(k,j) = t + s = s + t*t + 10 continue + 20 continue + s = a(j,j) - s +c ......exit + if (s .le. 0.0d+0) go to 40 + a(j,j) = sqrt(s) + 30 continue + info = 0 + 40 continue + return + end diff --git a/modules/elementary_functions/src/fortran/linpack/dpofa.lo b/modules/elementary_functions/src/fortran/linpack/dpofa.lo new file mode 100755 index 000000000..46d25ae20 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/dpofa.lo @@ -0,0 +1,12 @@ +# src/fortran/linpack/dpofa.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dpofa.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/linpack/dqrdc.f b/modules/elementary_functions/src/fortran/linpack/dqrdc.f new file mode 100755 index 000000000..1a7a75d82 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/dqrdc.f @@ -0,0 +1,213 @@ + subroutine dqrdc(x,ldx,n,p,qraux,jpvt,work,job) + integer ldx,n,p,job + integer jpvt(*) + double precision x(ldx,*),qraux(*),work(*) +c!purpose +c +c dqrdc uses householder transformations to compute the qr +c factorization of an n by p matrix x. column pivoting +c based on the 2-norms of the reduced columns may be +c performed at the users option. +c +c!calling sequence +c +c subroutine dqrdc(x,ldx,n,p,qraux,jpvt,work,job) +c on entry +c +c x double precision(ldx,p), where ldx .ge. n. +c x contains the matrix whose decomposition is to be +c computed. +c +c ldx integer. +c ldx is the leading dimension of the array x. +c +c n integer. +c n is the number of rows of the matrix x. +c +c p integer. +c p is the number of columns of the matrix x. +c +c jpvt integer(p). +c jpvt contains integers that control the selection +c of the pivot columns. the k-th column x(k) of x +c is placed in one of three classes according to the +c value of jpvt(k). +c +c if jpvt(k) .gt. 0, then x(k) is an initial +c column. +c +c if jpvt(k) .eq. 0, then x(k) is a free column. +c +c if jpvt(k) .lt. 0, then x(k) is a final column. +c +c before the decomposition is computed, initial columns +c are moved to the beginning of the array x and final +c columns to the end. both initial and final columns +c are frozen in place during the computation and only +c free columns are moved. at the k-th stage of the +c reduction, if x(k) is occupied by a free column +c it is interchanged with the free column of largest +c reduced norm. jpvt is not referenced if +c job .eq. 0. +c +c work double precision(p). +c work is a work array. work is not referenced if +c job .eq. 0. +c +c job integer. +c job is an integer that initiates column pivoting. +c if job .eq. 0, no pivoting is done. +c if job .ne. 0, pivoting is done. +c +c on return +c +c x x contains in its upper triangle the upper +c triangular matrix r of the qr factorization. +c below its diagonal x contains information from +c which the orthogonal part of the decomposition +c can be recovered. note that if pivoting has +c been requested, the decomposition is not that +c of the original matrix x but that of x +c with its columns permuted as described by jpvt. +c +c qraux double precision(p). +c qraux contains further information required to recover +c the orthogonal part of the decomposition. +c +c jpvt jpvt(k) contains the index of the column of the +c original matrix that has been interchanged into +c the k-th column, if pivoting was requested. +c +c!originator +c linpack. this version dated 08/14/78 . +c g.w. stewart, university of maryland, argonne national lab. +c +c!auxiliary routines +c +c blas daxpy,ddot,dscal,dswap,dnrm2 +c fortran abs,max,min,sqrt +c +c! +c internal variables +c + integer j,jp,l,lp1,lup,maxj,pl,pu + double precision maxnrm,dnrm2,tt + double precision ddot,nrmxl,t + logical negj,swapj +c +c + pl = 1 + pu = 0 + if (job .eq. 0) go to 60 +c +c pivoting has been requested. rearrange the columns +c according to jpvt. +c + do 20 j = 1, p + swapj = jpvt(j) .gt. 0 + negj = jpvt(j) .lt. 0 + jpvt(j) = j + if (negj) jpvt(j) = -j + if (.not.swapj) go to 10 + if (j .ne. pl) call dswap(n,x(1,pl),1,x(1,j),1) + jpvt(j) = jpvt(pl) + jpvt(pl) = j + pl = pl + 1 + 10 continue + 20 continue + pu = p + do 50 jj = 1, p + j = p - jj + 1 + if (jpvt(j) .ge. 0) go to 40 + jpvt(j) = -jpvt(j) + if (j .eq. pu) go to 30 + call dswap(n,x(1,pu),1,x(1,j),1) + jp = jpvt(pu) + jpvt(pu) = jpvt(j) + jpvt(j) = jp + 30 continue + pu = pu - 1 + 40 continue + 50 continue + 60 continue +c +c compute the norms of the free columns. +c + if (pu .lt. pl) go to 80 + do 70 j = pl, pu + qraux(j) = dnrm2(n,x(1,j),1) + work(j) = qraux(j) + 70 continue + 80 continue +c +c perform the householder reduction of x. +c + lup = min(n,p) + do 200 l = 1, lup + if (l .lt. pl .or. l .ge. pu) go to 120 +c +c locate the column of largest norm and bring it +c into the pivot position. +c + maxnrm = 0.0d+0 + maxj = l + do 100 j = l, pu + if (qraux(j) .le. maxnrm) go to 90 + maxnrm = qraux(j) + maxj = j + 90 continue + 100 continue + if (maxj .eq. l) go to 110 + call dswap(n,x(1,l),1,x(1,maxj),1) + qraux(maxj) = qraux(l) + work(maxj) = work(l) + jp = jpvt(maxj) + jpvt(maxj) = jpvt(l) + jpvt(l) = jp + 110 continue + 120 continue + qraux(l) = 0.0d+0 + if (l .eq. n) go to 190 +c +c compute the householder transformation for column l. +c + nrmxl = dnrm2(n-l+1,x(l,l),1) + if (nrmxl .eq. 0.0d+0) go to 180 + if (x(l,l) .ne. 0.0d+0) nrmxl = sign(nrmxl,x(l,l)) + call dscal(n-l+1,1.0d+0/nrmxl,x(l,l),1) + x(l,l) = 1.0d+0 + x(l,l) +c +c apply the transformation to the remaining columns, +c updating the norms. +c + lp1 = l + 1 + if (p .lt. lp1) go to 170 + do 160 j = lp1, p + t = -ddot(n-l+1,x(l,l),1,x(l,j),1)/x(l,l) + call daxpy(n-l+1,t,x(l,l),1,x(l,j),1) + if (j .lt. pl .or. j .gt. pu) go to 150 + if (qraux(j) .eq. 0.0d+0) go to 150 + tt = 1.0d+0 - (abs(x(l,j))/qraux(j))**2 + tt = max(tt,0.0d+0) + t = tt + tt = 1.0d+0 + 0.050d+0*tt*(qraux(j)/work(j))**2 + if (tt .eq. 1.0d+0) go to 130 + qraux(j) = qraux(j)*sqrt(t) + go to 140 + 130 continue + qraux(j) = dnrm2(n-l,x(l+1,j),1) + work(j) = qraux(j) + 140 continue + 150 continue + 160 continue + 170 continue +c +c save the transformation. +c + qraux(l) = x(l,l) + x(l,l) = -nrmxl + 180 continue + 190 continue + 200 continue + return + end diff --git a/modules/elementary_functions/src/fortran/linpack/dqrdc.lo b/modules/elementary_functions/src/fortran/linpack/dqrdc.lo new file mode 100755 index 000000000..d0f2af33e --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/dqrdc.lo @@ -0,0 +1,12 @@ +# src/fortran/linpack/dqrdc.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dqrdc.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/linpack/dqrsl.f b/modules/elementary_functions/src/fortran/linpack/dqrsl.f new file mode 100755 index 000000000..b60ba643f --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/dqrsl.f @@ -0,0 +1,280 @@ + subroutine dqrsl(x,ldx,n,k,qraux,y,qy,qty,b,rsd,xb,job,info) + integer ldx,n,k,job,info + double precision x(ldx,*),qraux(*),y(*),qy(*),qty(*),b(*),rsd(*), + * xb(*) +c!purpose +c +c dqrsl applies the output of dqrdc to compute coordinate +c transformations, projections, and least squares solutions. +c for k .le. min(n,p), let xk be the matrix +c +c xk = (x(jpvt(1)),x(jpvt(2)), ... ,x(jpvt(k))) +c +c formed from columnns jpvt(1), ... ,jpvt(k) of the original +c n x p matrix x that was input to dqrdc (if no pivoting was +c done, xk consists of the first k columns of x in their +c original order). dqrdc produces a factored orthogonal matrix q +c and an upper triangular matrix r such that +c +c xk = q * (r) +c (0) +c +c this information is contained in coded form in the arrays +c x and qraux. +c +c!calling sequence +c +c subroutine dqrsl(x,ldx,n,k,qraux,y,qy,qty,b,rsd,xb,job,info) +c on entry +c +c x double precision(ldx,p). +c x contains the output of dqrdc. +c +c ldx integer. +c ldx is the leading dimension of the array x. +c +c n integer. +c n is the number of rows of the matrix xk. it must +c have the same value as n in dqrdc. +c +c k integer. +c k is the number of columns of the matrix xk. k +c must nnot be greater than min(n,p), where p is the +c same as in the calling sequence to dqrdc. +c +c qraux double precision(p). +c qraux contains the auxiliary output from dqrdc. +c +c y double precision(n) +c y contains an n-vector that is to be manipulated +c by dqrsl. +c +c job integer. +c job specifies what is to be computed. job has +c the decimal expansion abcde, with the following +c meaning. +c +c if a.ne.0, compute qy. +c if b,c,d, or e .ne. 0, compute qty. +c if c.ne.0, compute b. +c if d.ne.0, compute rsd. +c if e.ne.0, compute xb. +c +c note that a request to compute b, rsd, or xb +c automatically triggers the computation of qty, for +c which an array must be provided in the calling +c sequence. +c +c on return +c +c qy double precision(n). +c qy conntains q*y, if its computation has been +c requested. +c +c qty double precision(n). +c qty contains trans(q)*y, if its computation has +c been requested. here trans(q) is the +c transpose of the matrix q. +c +c b double precision(k) +c b contains the solution of the least squares problem +c +c minimize norm2(y - xk*b), +c +c if its computation has been requested. (note that +c if pivoting was requested in dqrdc, the j-th +c component of b will be associated with column jpvt(j) +c of the original matrix x that was input into dqrdc.) +c +c rsd double precision(n). +c rsd contains the least squares residual y - xk*b, +c if its computation has been requested. rsd is +c also the orthogonal projection of y onto the +c orthogonal complement of the column space of xk. +c +c xb double precision(n). +c xb contains the least squares approximation xk*b, +c if its computation has been requested. xb is also +c the orthogonal projection of y onto the column space +c of x. +c +c info integer. +c info is zero unless the computation of b has +c been requested and r is exactly singular. in +c this case, info is the index of the first zero +c diagonal element of r and b is left unaltered. +c +c the parameters qy, qty, b, rsd, and xb are not referenced +c if their computation is not requested and in this case +c can be replaced by dummy variables in the calling program. +c to save storage, the user may in some cases use the same +c array for different parameters in the calling sequence. a +c frequently occuring example is when one wishes to compute +c any of b, rsd, or xb and does not need y or qty. in this +c case one may identify y, qty, and one of b, rsd, or xb, while +c providing separate arrays for anything else that is to be +c computed. thus the calling sequence +c +c call dqrsl(x,ldx,n,k,qraux,y,dum,y,b,y,dum,110,info) +c +c will result in the computation of b and rsd, with rsd +c overwriting y. more generally, each item in the following +c list contains groups of permissible identifications for +c a single callinng sequence. +c +c 1. (y,qty,b) (rsd) (xb) (qy) +c +c 2. (y,qty,rsd) (b) (xb) (qy) +c +c 3. (y,qty,xb) (b) (rsd) (qy) +c +c 4. (y,qy) (qty,b) (rsd) (xb) +c +c 5. (y,qy) (qty,rsd) (b) (xb) +c +c 6. (y,qy) (qty,xb) (b) (rsd) +c +c in any group the value returned in the array allocated to +c the group corresponds to the last member of the group. +c +c!originator +c linpack. this version dated 08/14/78 . +c g.w. stewart, university of maryland, argonne national lab. +c +c!auxiliary routines +c +c blas daxpy,dcopy,ddot +c fortran abs,min,mod +c +c! +c internal variables +c + integer i,j,jj,ju,kp1 + double precision ddot,t,temp + logical cb,cqy,cqty,cr,cxb +c +c +c set info flag. +c + info = 0 +c +c determine what is to be computed. +c + cqy = job/10000 .ne. 0 + cqty = mod(job,10000) .ne. 0 + cb = mod(job,1000)/100 .ne. 0 + cr = mod(job,100)/10 .ne. 0 + cxb = mod(job,10) .ne. 0 + ju = min(k,n-1) +c +c special action when n=1. +c + if (ju .ne. 0) go to 40 + if (cqy) qy(1) = y(1) + if (cqty) qty(1) = y(1) + if (cxb) xb(1) = y(1) + if (.not.cb) go to 30 + if (x(1,1) .ne. 0.0d+0) go to 10 + info = 1 + go to 20 + 10 continue + b(1) = y(1)/x(1,1) + 20 continue + 30 continue + if (cr) rsd(1) = 0.0d+0 + go to 250 + 40 continue +c +c set up to compute qy or qty. +c + if (cqy) call dcopy(n,y,1,qy,1) + if (cqty) call dcopy(n,y,1,qty,1) + if (.not.cqy) go to 70 +c +c compute qy. +c + do 60 jj = 1, ju + j = ju - jj + 1 + if (qraux(j) .eq. 0.0d+0) go to 50 + temp = x(j,j) + x(j,j) = qraux(j) + t = -ddot(n-j+1,x(j,j),1,qy(j),1)/x(j,j) + call daxpy(n-j+1,t,x(j,j),1,qy(j),1) + x(j,j) = temp + 50 continue + 60 continue + 70 continue + if (.not.cqty) go to 100 +c +c compute trans(q)*y. +c + do 90 j = 1, ju + if (qraux(j) .eq. 0.0d+0) go to 80 + temp = x(j,j) + x(j,j) = qraux(j) + t = -ddot(n-j+1,x(j,j),1,qty(j),1)/x(j,j) + call daxpy(n-j+1,t,x(j,j),1,qty(j),1) + x(j,j) = temp + 80 continue + 90 continue + 100 continue +c +c set up to compute b, rsd, or xb. +c + if (cb) call dcopy(k,qty,1,b,1) + kp1 = k + 1 + if (cxb) call dcopy(k,qty,1,xb,1) + if (cr .and. k .lt. n) call dcopy(n-k,qty(kp1),1,rsd(kp1),1) + if (.not.cxb .or. kp1 .gt. n) go to 120 + do 110 i = kp1, n + xb(i) = 0.0d+0 + 110 continue + 120 continue + if (.not.cr) go to 140 + do 130 i = 1, k + rsd(i) = 0.0d+0 + 130 continue + 140 continue + if (.not.cb) go to 190 +c +c compute b. +c + do 170 jj = 1, k + j = k - jj + 1 + if (x(j,j) .ne. 0.0d+0) go to 150 + info = j +c ......exit + go to 180 + 150 continue + b(j) = b(j)/x(j,j) + if (j .eq. 1) go to 160 + t = -b(j) + call daxpy(j-1,t,x(1,j),1,b,1) + 160 continue + 170 continue + 180 continue + 190 continue + if (.not.cr .and. .not.cxb) go to 240 +c +c compute rsd or xb as required. +c + do 230 jj = 1, ju + j = ju - jj + 1 + if (qraux(j) .eq. 0.0d+0) go to 220 + temp = x(j,j) + x(j,j) = qraux(j) + if (.not.cr) go to 200 + t = -ddot(n-j+1,x(j,j),1,rsd(j),1)/x(j,j) + call daxpy(n-j+1,t,x(j,j),1,rsd(j),1) + 200 continue + if (.not.cxb) go to 210 + t = -ddot(n-j+1,x(j,j),1,xb(j),1)/x(j,j) + call daxpy(n-j+1,t,x(j,j),1,xb(j),1) + 210 continue + x(j,j) = temp + 220 continue + 230 continue + 240 continue + 250 continue + return + end diff --git a/modules/elementary_functions/src/fortran/linpack/dqrsl.lo b/modules/elementary_functions/src/fortran/linpack/dqrsl.lo new file mode 100755 index 000000000..4b6f2aa48 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/dqrsl.lo @@ -0,0 +1,12 @@ +# src/fortran/linpack/dqrsl.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dqrsl.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/linpack/dqrsm.f b/modules/elementary_functions/src/fortran/linpack/dqrsm.f new file mode 100755 index 000000000..16c00d7aa --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/dqrsm.f @@ -0,0 +1,173 @@ + subroutine dqrsm(x,ldx,n,p,y,ldy,nc,b,ldb,k,jpvt,qraux,work) + integer ldx,n,p,ldy,nc,ldb,k,jpvt(*) + double precision x(ldx,*),y(ldy,*),b(ldb,*),qraux(*),work(*) +C +C!purpose +C sqrsm is a subroutine to compute least squares solutions +C to the system +C +C (1) x * b = y, +C +C which may be either under-determined or over-determined. +C the relative machine precision eps is used as a tolerance +C to limit the columns of x used in computing the solution. +C in effect, a set of columns with a condition number +C approximately rounded by 1/eps is used, the other +C components of b being set to zero +C if n.eq.1 and nc.gt.1 the elements in the nc-th column of b +C are set to one). +C!calling sequence +C +C subroutine dqrsm(x,ldx,n,p,y,ldy,nc,b,ldb,k,jpvt,qraux,work) +C +C on entry +C +C x real(ldx,p), where ldx.ge.n +C x contains the nxp coefficient matrix of +C the system (1), x is destroyed by sqrsm. +C +C ldx integer +C ldx is the leading dimension of the array x. +C +C n integer +C n is the number of rows of the matrix x. +C +C p integer +C p is the number of columns of the matrix x. +C +C y real(ldy,nc) +C y contains the right hand side of the system(1). +C +C ldy integer +C ldy is the leading dimension of the array y. +C +C nc integer +C nc is the number of columns of the matrix y. +C +C jpvt integer(p) +C jpvt is an integer array used by sqrdc. +C +C qraux real(p) +C qraux is an array used by sqrdc and sqrsl +C +C work real(p) +C work is an array used by sqrdc. +C +C on return +C +C x x contains the output array from sqrdc. +C +C b real(ldb,nc) +C b contains the solution matrix. components +C corresponding io columns not used are set to zero +C (if n.eq.1 and nc.gt.1 the elements in the nc-th +C column of b are set to one). +C +C ldb integer +C +C k integer +C k contains the number of columns used in the +C solutions. +C +C jpvt contains the pivot information from sqrdc. +C +C qraux contains the array output by sqrdc. +C +C on return the arrays x, jpvt and qraux contain the +C usual output from dqrdc, so that the qr decomposition +C of x with pivoting is fully available to the user. +C in particular, columns jpvt(1), jpvt(2),...,jpvt(k) +C were used in the solution, and the condition number +C associated with those columns is estimated by +C abs(x(1,1)/x(k,k)). +C!auxiliary routines +C dqrdc dqrsl (linpack) +C!originator +C this subroutine is a modification of the example program sqrst, +C given in the linpack users' guide: +C dongarra j.j., j.r.bunch, c.b.moler and g.w.stewart. +C linpack users' guide. siam, philadelphia, 1979. +C! +C internal variables +C + integer info,j,kk,l,m + double precision t,tt(1) +C +C initialize jpvt so that all columns are free. +C + do 10 j = 1,p + jpvt(j) = 0 + 10 continue +C +C reduce x. +C + call dqrdc(x,ldx,n,p,qraux,jpvt,work,1) +C +C determine which columns to use. +C + k = 0 + m = min(n,p) + do 20 kk = 1,m + t = abs(x(1,1)) + abs(x(kk,kk)) + if (t .eq. abs(x(1,1))) goto 30 + k = kk + 20 continue + 30 continue +C +C solve the least squares problem. +C + if (k .eq. 0) goto 160 + if (n.ge.p .or. n.gt.1 .or. nc.eq.1) goto 60 + np1 = n + 1 + do 50 j = 1,n + do 40 kk = np1,p + y(j,nc) = y(j,nc) - x(j,kk) + 40 continue + 50 continue + 60 do 70 l = 1,nc + call dqrsl(x,ldx,n,k,qraux,y(1,l),tt,y(1,l),b(1,l),tt,tt,100, + & info) + 70 continue +C +C set the unused components of b to zero and initialize jpvt +C for unscrambling. +C + do 90 j = 1,p + jpvt(j) = -jpvt(j) + if (j .le. k) goto 90 + do 80 l = 1,nc + b(j,l) = 0.0d+0 + 80 continue + 90 continue + if (n.ne.1 .or. nc.le.1 .or. p.le.n) goto 110 +C +C if n.eq.1 and nc.gt.1 set the elements in the nc-th +C column of b to one. +C + do 100 j = np1,p + b(j,nc) = 1.0d+0 + 100 continue + 110 continue +C +C unscramble the solution. +C + do 150 j = 1,p + if (jpvt(j) .gt. 0) goto 150 + kk = -jpvt(j) + jpvt(j) = kk + 120 continue + if (kk .eq. j) goto 140 + do 130 l = 1,nc + t = b(j,l) + b(j,l) = b(kk,l) + b(kk,l) = t + 130 continue + jpvt(kk) = -jpvt(kk) + kk = jpvt(kk) + goto 120 + 140 continue + 150 continue + 160 continue + return + end + diff --git a/modules/elementary_functions/src/fortran/linpack/dqrsm.lo b/modules/elementary_functions/src/fortran/linpack/dqrsm.lo new file mode 100755 index 000000000..a3f08ca58 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/dqrsm.lo @@ -0,0 +1,12 @@ +# src/fortran/linpack/dqrsm.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dqrsm.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/linpack/hhdml.f b/modules/elementary_functions/src/fortran/linpack/hhdml.f new file mode 100755 index 000000000..372de2935 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/hhdml.f @@ -0,0 +1,242 @@ + subroutine hhdml(ktrans,nrowa,ncola,ioff,joff,nrowbl,ncolbl, + 1 x,nx,qraux,a,na,mode,ierr) +c!purpose +c +c to pre- or post-multiply a specified block of matrix a by the +c orthogonal matrix q (or its transpose), where q is the +c product of householder transformations which are stored as by +c linpack routine dqrdc in arrays x and qraux. +c +c!method +c +c the block of a to be transformed is the (nrowbl x ncolbl) one +c with offset (ioff,joff), ie with first (top left) element +c (ioff + 1,joff + 1). this is operated on by the orthogonal +c (ndimq x ndimq) q = h(1) * ... * h(ktrans) or its transpose, +c where ndimq equals nrowbl for pre-multiplication and ncolbl +c for post-multiplication. each householder transformation +c h(l) is completely described by the sub-vector stored in the +c l-th element of qraux and the sub-diagonal part of the l-th +c column of the (ndimq x ktrans) x. note finally that ktrans +c .le. ndimq. +c +c!reference +c +c dongarra, j.j. et al +c "linpack users' guide" +c siam, 1979. (chapter 9) +c +c!auxiliary routines +c +c none +c +c! calling sequence +c +c subroutine hhdml(ktrans,nrowa,ncola,ioff,joff,nrowbl,ncolbl, +c 1 x,nx,qraux,a,na,mode,ierr) +c +c integer ktrans,nrowa,ncola,ioff,joff,nrowbl,ncolbl,nx,na +c integer mode,ierr +c +c double precision x(nx,ktrans),qraux(ktrans),a(na,ncola) +c +c +c arguments in +c +c ktrans integer +c -the number of householder transformations making up +c q; declared first dimension of qraux and second +c dimension of x +c +c nrowa integer +c -the number of rows of matrix a +c +c ncola integer +c -the number of columns of matrix a +c +c ioff integer +c -the row offset of the specified block of a +c +c joff integer +c -the column offset of the specified block of a +c +c nrowbl integer +c -the number of rows of the specified block of a +c +c ncolbl integer +c -the number of columns of the specified block of a +c +c x double precision(ndimq,ktrans) +c -the matrix containing in its sub-diagonal part most +c of the information necessary to construct q +c +c nx integer +c -the declared first dimension of x. note that +c nx .ge. ndimq .ge. ktrans +c +c qraux double precision(ktrans) +c -the remaining information necessary to construct q +c +c a double precision(nrowa,ncola) +c -the matrix of which a specified block is to be +c transformed. note that this block is overwritten +c here +c +c na integer +c -the declared first dimension of a. note that +c na .ge. nrowa +c +c mode integer +c -mode is a two-digit non-negative integer: its units +c digit is 0 if q is to be applied and non-zero if +c qtrans is, and its tens digit is 0 for post-multipli- +c cation and non-zero for pre-multiplication +c +c arguments out +c +c a double precision(nrowa,ncola) +c -the given matrix with specified block transformed +c +c ierr integer +c -error indicator +c +c ierr = 0 successful return +c +c ierr = 1 nrowa .lt. (ioff + nrowbl) +c +c ierr = 2 ncola .lt. (joff + ncolbl) +c +c ierr = 3 ndimq does not lie in the interval +c ktrans, nx +c +c working space +c +c none +c +c!originator +c +c t.w.c.williams, control systems research group, +c kingston polytechnic, march 16 1982 +c +c! +c + integer ktrans,nrowa,ncola,ioff,joff,nrowbl,ncolbl,nx,na + integer mode,ierr +c + double precision x(nx,ktrans),qraux(ktrans),a(na,ncola) +c +c local variables: + integer itrans,ipre,ndimq,iback,lstep,ia,ja,i,j,k,l +c + double precision diag,temp +c + double precision tau +c +c + ierr = 0 +c + if ( (ioff + nrowbl) .le. nrowa) go to 10 +c + ierr = 1 + go to 150 +c + 10 if ( (joff + ncolbl) .le. ncola) go to 20 +c + ierr = 2 + go to 150 +c +c itrans units digit of mode: 0 iff non-transposed q to be used +c + 20 itrans = mod(mode,10) +c +c ipre 10 * (tens digit of mode): 0 iff post-multiplying ablk +c + ipre = mode - itrans +c + ndimq = ncolbl + if (ipre .ne. 0) ndimq = nrowbl + if ( (ktrans .le. ndimq) .and. (ndimq .le. nx) ) go to 30 +c + ierr = 3 + go to 150 +c +c iback 1 iff precisely one of itrans, ipre .ne. 0, ie iff the +c householder transformations h(l) are applied in descending order +c + 30 iback = 0 + if (itrans .ne. 0) iback = 1 + if (ipre .ne. 0) iback = iback + 1 +c + if (iback .eq. 1) go to 40 +c +c initialization for h(l) applied in ascending order +c + l = 1 + lstep = 1 + go to 50 +c +c initialization for h(l) applied in descending order +c + 40 l = ktrans + lstep = -1 +c + 50 if (ipre .eq. 0) go to 100 +c +c pre-multiply appropriate block of a by h(l) in correct order +c + do 90 k = 1,ktrans + diag = qraux(l) + if (diag .eq. 0.0d+0) go to 90 + temp = x(l,l) + x(l,l) = diag +c +c operate on a one column at a time +c + do 80 j = 1,ncolbl + ja = joff + j + tau = 0.0d+0 + do 60 i = l,nrowbl + ia = ioff + i + 60 tau = tau + (x(i,l) * a(ia,ja) ) + tau = tau / diag + do 70 i = l,nrowbl + ia = ioff + i + 70 a(ia,ja) = a(ia,ja) - (tau * x(i,l) ) +c + 80 continue +c + x(l,l) = temp + 90 l = l + lstep + go to 150 +c +c post-multiply appropriate block of a by h(l) in correct order +c + 100 continue + do 140 k = 1,ktrans + diag = qraux(l) + if (diag .eq. 0.0d+0) go to 140 + temp = x(l,l) + x(l,l) = diag +c +c operate on a one row at a time +c + do 130 i = 1,nrowbl + ia = ioff + i + tau = 0.0d+0 + do 110 j = l,ncolbl + ja = joff + j + 110 tau = tau + (a(ia,ja) * x(j,l) ) + tau = tau / diag + do 120 j = l,ncolbl + ja = joff + j + 120 a(ia,ja) = a(ia,ja) - (tau * x(j,l) ) +c + 130 continue +c + x(l,l) = temp + 140 l = l + lstep +c + 150 continue +c + return + end diff --git a/modules/elementary_functions/src/fortran/linpack/hhdml.lo b/modules/elementary_functions/src/fortran/linpack/hhdml.lo new file mode 100755 index 000000000..56207bbe5 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/hhdml.lo @@ -0,0 +1,12 @@ +# src/fortran/linpack/hhdml.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/hhdml.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/linpack/icopy.f b/modules/elementary_functions/src/fortran/linpack/icopy.f new file mode 100755 index 000000000..dd0d134b0 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/icopy.f @@ -0,0 +1,57 @@ +C/MEMBR ADD NAME=ICOPY,SSI=0 +c + subroutine icopy(n,dx,incx,dy,incy) +c!but +c +c cette subroutine copie un vecteur dx, de taille n, sur un +c vecteur dy. +c dans le cas de deux increments egaux a 1, cette subroutine +c emploie des boucles "epanouies". +c dans le cas ou les increments sont negatifs cette +c subroutine prend les composantes en ordre inverse. +c +c!liste d'appel +c +c subroutine dcopy(n,dx,incx,dy,incy) +c +c n: taille du vecteur dx +c +c dx: integer, vecteur "emetteur". +c +c dy: integer, vecteur "recepteur". +c +c incx, incy: increments entre les composantes des vecteurs. +c +c!auteur +c +c jack dongarra, linpack, 3/11/78. +c +c! +c + integer dx(*),dy(*) + integer i,incx,incy,ix,iy,n +c + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments not equal to 1 +c + 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) = dx(ix) + ix = ix + incx + iy = iy + incy + 10 continue + return +c +c code for both increments equal to 1 +c + 20 continue + do 30 i = 1,n + dy(i) = dx(i) + 30 continue +c + end diff --git a/modules/elementary_functions/src/fortran/linpack/icopy.lo b/modules/elementary_functions/src/fortran/linpack/icopy.lo new file mode 100755 index 000000000..bcabb9698 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/icopy.lo @@ -0,0 +1,12 @@ +# src/fortran/linpack/icopy.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/icopy.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/linpack/linpack_f.rc b/modules/elementary_functions/src/fortran/linpack/linpack_f.rc new file mode 100755 index 000000000..c762bcd67 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/linpack_f.rc @@ -0,0 +1,96 @@ +// Microsoft Visual C++ generated resource script. +// + + +#define APSTUDIO_READONLY_SYMBOLS +///////////////////////////////////////////////////////////////////////////// +// +// Generated from the TEXTINCLUDE 2 resource. +// +//#include "afxres.h" +#define APSTUDIO_HIDDEN_SYMBOLS +#include "windows.h" +///////////////////////////////////////////////////////////////////////////// +#undef APSTUDIO_READONLY_SYMBOLS + +///////////////////////////////////////////////////////////////////////////// +// French (France) resources + +#if !defined(AFX_RESOURCE_DLL) || defined(AFX_TARG_FRA) +#ifdef _WIN32 +LANGUAGE LANG_FRENCH, SUBLANG_FRENCH +#pragma code_page(1252) +#endif //_WIN32 + +#ifdef APSTUDIO_INVOKED +///////////////////////////////////////////////////////////////////////////// +// +// TEXTINCLUDE +// + +1 TEXTINCLUDE +BEGIN + "resource.h\0" +END + +3 TEXTINCLUDE +BEGIN + "\r\n" + "\0" +END + +#endif // APSTUDIO_INVOKED + + +///////////////////////////////////////////////////////////////////////////// +// +// Version +// + +VS_VERSION_INFO VERSIONINFO + FILEVERSION 5,5,2,0 + PRODUCTVERSION 5,5,2,0 + FILEFLAGSMASK 0x17L +#ifdef _DEBUG + FILEFLAGS 0x1L +#else + FILEFLAGS 0x0L +#endif + FILEOS 0x4L + FILETYPE 0x2L + FILESUBTYPE 0x0L +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "040c04b0" + BEGIN + VALUE "FileDescription", "linpack_f module" + VALUE "FileVersion", "5, 5, 2, 0" + VALUE "InternalName", "linpack_f module" + VALUE "LegalCopyright", "Copyright (C) 2017" + VALUE "OriginalFilename", "linpack_f.dll" + VALUE "ProductName", "linpack_f module" + VALUE "ProductVersion", "5, 5, 2, 0" + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x40c, 1200 + END +END + +#endif // French (France) resources +///////////////////////////////////////////////////////////////////////////// + + + +#ifndef APSTUDIO_INVOKED +///////////////////////////////////////////////////////////////////////////// +// +// Generated from the TEXTINCLUDE 3 resource. +// + + +///////////////////////////////////////////////////////////////////////////// +#endif // not APSTUDIO_INVOKED + diff --git a/modules/elementary_functions/src/fortran/linpack/linpack_f.vfproj b/modules/elementary_functions/src/fortran/linpack/linpack_f.vfproj new file mode 100755 index 000000000..e0c31403a --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/linpack_f.vfproj @@ -0,0 +1,104 @@ +<?xml version="1.0" encoding="UTF-8"?> +<VisualStudioProject ProjectType="typeDynamicLibrary" ProjectCreator="Intel Fortran" Keyword="Dll" Version="11.0" ProjectIdGuid="{F0F55692-0355-4BC3-BE9D-552C8AAC5238}"> + <Platforms> + <Platform Name="Win32"/> + <Platform Name="x64"/></Platforms> + <Configurations> + <Configuration Name="Debug|Win32" OutputDirectory="$(SolutionDir)bin\" IntermediateDirectory="$(ProjectDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary"> + <Tool Name="VFFortranCompilerTool" SuppressStartupBanner="true" DebugInformationFormat="debugEnabled" Optimization="optimizeDisabled" AdditionalIncludeDirectories="../../../../core/includes" PreprocessorDefinitions="WIN32;FORDLL" AlternateParameterSyntax="false" F77RuntimeCompatibility="true" FPS4Libs="false" CallingConvention="callConventionCRef" ExternalNameUnderscore="true" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" RuntimeLibrary="rtMultiThreadedDebugDLL"/> + <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin\$(ProjectName).dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" ModuleDefinitionFile="linpack_f.def" GenerateDebugInformation="true" SubSystem="subSystemWindows" ImportLibrary="$(SolutionDir)bin\$(ProjectName).lib" LinkDLL="true" AdditionalDependencies="../../../../../bin/blasplus.lib elementary_functions_f.lib elementary_functions.lib"/> + <Tool Name="VFResourceCompilerTool"/> + <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/> + <Tool Name="VFCustomBuildTool"/> + <Tool Name="VFPreLinkEventTool" CommandLine="setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .." Description="Build $(ProjectName).def"/> + <Tool Name="VFPreBuildEventTool" CommandLine="lib /DEF:"$(InputDir)Elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)Elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)Elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)Elementary_functions.lib" 1>NUL 2>NUL" Description="Build dependencies"/> + <Tool Name="VFPostBuildEventTool"/> + <Tool Name="VFManifestTool" SuppressStartupBanner="true"/></Configuration> + <Configuration Name="Release|Win32" OutputDirectory="$(SolutionDir)bin\" IntermediateDirectory="$(ProjectDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary"> + <Tool Name="VFFortranCompilerTool" SuppressStartupBanner="true" AdditionalIncludeDirectories="../../../../core/includes" PreprocessorDefinitions="WIN32;FORDLL" AlternateParameterSyntax="false" F77RuntimeCompatibility="true" FPS4Libs="false" CallingConvention="callConventionCRef" ExternalNameUnderscore="true" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" RuntimeLibrary="rtMultiThreadedDLL"/> + <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin\$(ProjectName).dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" ModuleDefinitionFile="linpack_f.def" SubSystem="subSystemWindows" ImportLibrary="$(SolutionDir)bin\$(ProjectName).lib" LinkDLL="true" AdditionalDependencies="../../../../../bin/blasplus.lib elementary_functions_f.lib elementary_functions.lib"/> + <Tool Name="VFResourceCompilerTool"/> + <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/> + <Tool Name="VFCustomBuildTool"/> + <Tool Name="VFPreLinkEventTool" CommandLine="setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .." Description="Build $(ProjectName).def"/> + <Tool Name="VFPreBuildEventTool" CommandLine="lib /DEF:"$(InputDir)Elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)Elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)Elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)Elementary_functions.lib" 1>NUL 2>NUL" Description="Build dependencies"/> + <Tool Name="VFPostBuildEventTool"/> + <Tool Name="VFManifestTool" SuppressStartupBanner="true"/></Configuration> + <Configuration Name="Debug|x64" OutputDirectory="$(SolutionDir)bin\" IntermediateDirectory="$(ProjectDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary"> + <Tool Name="VFFortranCompilerTool" SuppressStartupBanner="true" DebugInformationFormat="debugEnabled" Optimization="optimizeDisabled" AdditionalIncludeDirectories="../../../../core/includes" PreprocessorDefinitions="WIN32;FORDLL" AlternateParameterSyntax="false" F77RuntimeCompatibility="true" FPS4Libs="false" CallingConvention="callConventionCRef" ExternalNameUnderscore="true" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" RuntimeLibrary="rtMultiThreadedDebugDLL"/> + <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin\$(ProjectName).dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" ModuleDefinitionFile="linpack_f.def" GenerateDebugInformation="true" SubSystem="subSystemWindows" ImportLibrary="$(SolutionDir)bin\$(ProjectName).lib" LinkDLL="true" AdditionalDependencies="../../../../../bin/blasplus.lib elementary_functions_f.lib elementary_functions.lib"/> + <Tool Name="VFResourceCompilerTool"/> + <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/> + <Tool Name="VFCustomBuildTool"/> + <Tool Name="VFPreLinkEventTool" CommandLine="setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .." Description="Build $(ProjectName).def"/> + <Tool Name="VFPreBuildEventTool" CommandLine="lib /DEF:"$(InputDir)Elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)Elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)Elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)Elementary_functions.lib" 1>NUL 2>NUL" Description="Build dependencies"/> + <Tool Name="VFPostBuildEventTool"/> + <Tool Name="VFManifestTool" SuppressStartupBanner="true"/></Configuration> + <Configuration Name="Release|x64" OutputDirectory="$(SolutionDir)bin\" IntermediateDirectory="$(ProjectDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary"> + <Tool Name="VFFortranCompilerTool" SuppressStartupBanner="true" AdditionalIncludeDirectories="../../../../core/includes" PreprocessorDefinitions="WIN32;FORDLL" AlternateParameterSyntax="false" F77RuntimeCompatibility="true" FPS4Libs="false" CallingConvention="callConventionCRef" ExternalNameUnderscore="true" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" RuntimeLibrary="rtMultiThreadedDLL"/> + <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin\$(ProjectName).dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" ModuleDefinitionFile="linpack_f.def" SubSystem="subSystemWindows" ImportLibrary="$(SolutionDir)bin\$(ProjectName).lib" LinkDLL="true" AdditionalDependencies="../../../../../bin/blasplus.lib elementary_functions_f.lib elementary_functions.lib"/> + <Tool Name="VFResourceCompilerTool"/> + <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/> + <Tool Name="VFCustomBuildTool"/> + <Tool Name="VFPreLinkEventTool" CommandLine="setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .." Description="Build $(ProjectName).def"/> + <Tool Name="VFPreBuildEventTool" CommandLine="lib /DEF:"$(InputDir)Elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)Elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)Elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)Elementary_functions.lib" 1>NUL 2>NUL" Description="Build dependencies"/> + <Tool Name="VFPostBuildEventTool"/> + <Tool Name="VFManifestTool" SuppressStartupBanner="true"/></Configuration></Configurations> + <Files> + <Filter Name="Header Files" Filter="fi;fd"/> + <Filter Name="Library dependencies"> + <File RelativePath=".\Elementary_functions_f_Import.def"/> + <File RelativePath=".\Elementary_functions_Import.def"/></Filter> + <Filter Name="Resource Files" Filter="rc;ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe"> + <File RelativePath=".\linpack_f.rc"/></Filter> + <Filter Name="Source Files" Filter="f90;for;f;fpp;ftn;def;odl;idl"> + <File RelativePath=".\dgbfa.f"/> + <File RelativePath=".\dgeco.f"/> + <File RelativePath=".\dgedi.f"/> + <File RelativePath=".\dgefa.f"/> + <File RelativePath=".\dgesl.f"/> + <File RelativePath=".\dpofa.f"/> + <File RelativePath=".\dqrdc.f"/> + <File RelativePath=".\dqrsl.f"/> + <File RelativePath=".\dqrsm.f"/> + <File RelativePath=".\hhdml.f"/> + <File RelativePath=".\icopy.f"/> + <File RelativePath=".\pade.f"/> + <File RelativePath=".\util.f"/> + <File RelativePath=".\wgeco.f"/> + <File RelativePath=".\wgefa.f"/> + <File RelativePath=".\wgesl.f"/> + <File RelativePath=".\wpade.f"/></Filter></Files> + <Globals/></VisualStudioProject> diff --git a/modules/elementary_functions/src/fortran/linpack/linpack_f2c.vcxproj b/modules/elementary_functions/src/fortran/linpack/linpack_f2c.vcxproj new file mode 100755 index 000000000..d073eb86a --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/linpack_f2c.vcxproj @@ -0,0 +1,298 @@ +<?xml version="1.0" encoding="utf-8"?> +<Project DefaultTargets="Build" ToolsVersion="4.0" xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <ItemGroup Label="ProjectConfigurations"> + <ProjectConfiguration Include="Debug|Win32"> + <Configuration>Debug</Configuration> + <Platform>Win32</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Debug|x64"> + <Configuration>Debug</Configuration> + <Platform>x64</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Release|Win32"> + <Configuration>Release</Configuration> + <Platform>Win32</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Release|x64"> + <Configuration>Release</Configuration> + <Platform>x64</Platform> + </ProjectConfiguration> + </ItemGroup> + <PropertyGroup Label="Globals"> + <ProjectName>linpack_f</ProjectName> + <ProjectGuid>{F0F55692-0355-4BC3-BE9D-552C8AAC5238}</ProjectGuid> + <RootNamespace>linpack_f2c</RootNamespace> + <Keyword>Win32Proj</Keyword> + </PropertyGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.Default.props" /> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>Unicode</CharacterSet> + <WholeProgramOptimization>true</WholeProgramOptimization> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>Unicode</CharacterSet> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>Unicode</CharacterSet> + <WholeProgramOptimization>true</WholeProgramOptimization> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>Unicode</CharacterSet> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.props" /> + <ImportGroup Label="ExtensionSettings"> + <Import Project="..\..\..\..\..\Visual-Studio-settings\f2c.props" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <PropertyGroup Label="UserMacros" /> + <PropertyGroup> + <_ProjectFileVersion>10.0.30319.1</_ProjectFileVersion> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">true</LinkIncremental> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">true</LinkIncremental> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">false</LinkIncremental> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Release|x64'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Release|x64'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Release|x64'">false</LinkIncremental> + </PropertyGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'"> + <PreBuildEvent> + <Message>Build dependencies</Message> + <Command>lib /DEF:"$(ProjectDir)Elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)Elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)Elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)Elementary_functions.lib" 1>NUL 2>NUL</Command> + </PreBuildEvent> + <ClCompile> + <Optimization>Disabled</Optimization> + <AdditionalIncludeDirectories>../../../../../libs/f2c;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>WIN32;_DEBUG;_WINDOWS;_USRDLL;LINPACK_F2C_EXPORTS;FORDLL;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDebugDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + </ClCompile> + <PreLinkEvent> + <Message>Build $(ProjectName).def</Message> + <Command>setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .. +</Command> + </PreLinkEvent> + <Link> + <AdditionalDependencies>elementary_functions_f.lib;elementary_functions.lib;../../../../../bin/blasplus.lib;../../../../../bin/libf2c.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <ModuleDefinitionFile>linpack_f.def</ModuleDefinitionFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX86</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + <LinkTimeCodeGeneration>Default</LinkTimeCodeGeneration> + </Link> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'"> + <PreBuildEvent> + <Message>Build dependencies</Message> + <Command>lib /DEF:"$(ProjectDir)Elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)Elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)Elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)Elementary_functions.lib" 1>NUL 2>NUL</Command> + </PreBuildEvent> + <Midl> + <TargetEnvironment>X64</TargetEnvironment> + </Midl> + <ClCompile> + <Optimization>Disabled</Optimization> + <AdditionalIncludeDirectories>../../../../../libs/f2c;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>WIN32;_DEBUG;_WINDOWS;_USRDLL;LINPACK_F2C_EXPORTS;FORDLL;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDebugDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + </ClCompile> + <PreLinkEvent> + <Message>Build $(ProjectName).def</Message> + <Command>setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .. +</Command> + </PreLinkEvent> + <Link> + <AdditionalDependencies>elementary_functions_f.lib;elementary_functions.lib;../../../../../bin/blasplus.lib;../../../../../bin/libf2c.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <ModuleDefinitionFile>linpack_f.def</ModuleDefinitionFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX64</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + <LinkTimeCodeGeneration>Default</LinkTimeCodeGeneration> + </Link> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'"> + <PreBuildEvent> + <Message>Build dependencies</Message> + <Command>lib /DEF:"$(ProjectDir)Elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)Elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)Elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)Elementary_functions.lib" 1>NUL 2>NUL</Command> + </PreBuildEvent> + <ClCompile> + <WholeProgramOptimization>false</WholeProgramOptimization> + <AdditionalIncludeDirectories>../../../../../libs/f2c;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>WIN32;NDEBUG;_WINDOWS;_USRDLL;LINPACK_F2C_EXPORTS;FORDLL;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + <MultiProcessorCompilation>true</MultiProcessorCompilation> + </ClCompile> + <PreLinkEvent> + <Message>Build $(ProjectName).def</Message> + <Command>setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .. +</Command> + </PreLinkEvent> + <Link> + <AdditionalDependencies>elementary_functions_f.lib;elementary_functions.lib;../../../../../bin/blasplus.lib;../../../../../bin/libf2c.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <ModuleDefinitionFile>linpack_f.def</ModuleDefinitionFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <OptimizeReferences>true</OptimizeReferences> + <EnableCOMDATFolding>true</EnableCOMDATFolding> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX86</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + <LinkTimeCodeGeneration>Default</LinkTimeCodeGeneration> + </Link> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'"> + <PreBuildEvent> + <Message>Build dependencies</Message> + <Command>lib /DEF:"$(ProjectDir)Elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)Elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)Elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)Elementary_functions.lib" 1>NUL 2>NUL</Command> + </PreBuildEvent> + <Midl> + <TargetEnvironment>X64</TargetEnvironment> + </Midl> + <ClCompile> + <WholeProgramOptimization>false</WholeProgramOptimization> + <AdditionalIncludeDirectories>../../../../../libs/f2c;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>WIN32;NDEBUG;_WINDOWS;_USRDLL;LINPACK_F2C_EXPORTS;FORDLL;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + <MultiProcessorCompilation>true</MultiProcessorCompilation> + </ClCompile> + <PreLinkEvent> + <Message>Build $(ProjectName).def</Message> + <Command>setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .. +</Command> + </PreLinkEvent> + <Link> + <AdditionalDependencies>elementary_functions_f.lib;elementary_functions.lib;../../../../../bin/blasplus.lib;../../../../../bin/libf2c.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <ModuleDefinitionFile>linpack_f.def</ModuleDefinitionFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <OptimizeReferences>true</OptimizeReferences> + <EnableCOMDATFolding>true</EnableCOMDATFolding> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX64</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + <LinkTimeCodeGeneration>Default</LinkTimeCodeGeneration> + </Link> + </ItemDefinitionGroup> + <ItemGroup> + <ClCompile Include="dgbfa.c" /> + <ClCompile Include="dgeco.c" /> + <ClCompile Include="dgedi.c" /> + <ClCompile Include="dgefa.c" /> + <ClCompile Include="dgesl.c" /> + <ClCompile Include="dpofa.c" /> + <ClCompile Include="dqrdc.c" /> + <ClCompile Include="dqrsl.c" /> + <ClCompile Include="dqrsm.c" /> + <ClCompile Include="hhdml.c" /> + <ClCompile Include="icopy.c" /> + <ClCompile Include="pade.c" /> + <ClCompile Include="util.c" /> + <ClCompile Include="wgeco.c" /> + <ClCompile Include="wgefa.c" /> + <ClCompile Include="wgesl.c" /> + <ClCompile Include="wpade.c" /> + </ItemGroup> + <ItemGroup> + <f2c_rule Include="dgbfa.f" /> + <f2c_rule Include="dgeco.f" /> + <f2c_rule Include="dgedi.f" /> + <f2c_rule Include="dgefa.f" /> + <f2c_rule Include="dgesl.f" /> + <f2c_rule Include="dpofa.f" /> + <f2c_rule Include="dqrdc.f" /> + <f2c_rule Include="dqrsl.f" /> + <f2c_rule Include="dqrsm.f" /> + <f2c_rule Include="hhdml.f" /> + <f2c_rule Include="icopy.f" /> + <f2c_rule Include="pade.f" /> + <f2c_rule Include="util.f" /> + <f2c_rule Include="wgeco.f" /> + <f2c_rule Include="wgefa.f" /> + <f2c_rule Include="wgesl.f" /> + <f2c_rule Include="wpade.f" /> + </ItemGroup> + <ItemGroup> + <ProjectReference Include="..\..\..\..\..\tools\Dumpexts\Dumpexts.vcxproj"> + <Project>{3170e4c2-1173-4264-a222-7ee8ccb3ddf7}</Project> + <ReferenceOutputAssembly>false</ReferenceOutputAssembly> + </ProjectReference> + </ItemGroup> + <ItemGroup> + <None Include="Elementary_functions_f_Import.def" /> + <None Include="Elementary_functions_Import.def" /> + </ItemGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.targets" /> + <ImportGroup Label="ExtensionTargets"> + <Import Project="..\..\..\..\..\Visual-Studio-settings\f2c.targets" /> + </ImportGroup> +</Project>
\ No newline at end of file diff --git a/modules/elementary_functions/src/fortran/linpack/linpack_f2c.vcxproj.filters b/modules/elementary_functions/src/fortran/linpack/linpack_f2c.vcxproj.filters new file mode 100755 index 000000000..748ad639a --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/linpack_f2c.vcxproj.filters @@ -0,0 +1,137 @@ +<?xml version="1.0" encoding="utf-8"?> +<Project ToolsVersion="4.0" xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <ItemGroup> + <Filter Include="Source Files"> + <UniqueIdentifier>{4FC737F1-C7A5-4376-A066-2A32D752A2FF}</UniqueIdentifier> + <Extensions>cpp;c;cc;cxx;def;odl;idl;hpj;bat;asm;asmx</Extensions> + </Filter> + <Filter Include="Header Files"> + <UniqueIdentifier>{93995380-89BD-4b04-88EB-625FBE52EBFB}</UniqueIdentifier> + <Extensions>h;hpp;hxx;hm;inl;inc;xsd</Extensions> + </Filter> + <Filter Include="Resource Files"> + <UniqueIdentifier>{67DA6AB6-F800-4c08-8B7A-83BB121AAD01}</UniqueIdentifier> + <Extensions>rc;ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe;resx;tiff;tif;png;wav</Extensions> + </Filter> + <Filter Include="Fortran Files"> + <UniqueIdentifier>{1e471463-5740-4315-918f-8b1e325d24e1}</UniqueIdentifier> + </Filter> + <Filter Include="Libraries Dependencies"> + <UniqueIdentifier>{a740827c-ee24-40a4-b7f9-73c4b3b85904}</UniqueIdentifier> + </Filter> + </ItemGroup> + <ItemGroup> + <ClCompile Include="dgbfa.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dgeco.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dgedi.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dgefa.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dgesl.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dpofa.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dqrdc.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dqrsl.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dqrsm.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="hhdml.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="icopy.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="pade.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="util.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wgeco.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wgefa.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wgesl.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="wpade.c"> + <Filter>Source Files</Filter> + </ClCompile> + </ItemGroup> + <ItemGroup> + <f2c_rule Include="dgbfa.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dgeco.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dgedi.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dgefa.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dgesl.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dpofa.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dqrdc.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dqrsl.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dqrsm.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="hhdml.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="icopy.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="pade.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="util.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="wgeco.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="wgefa.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="wgesl.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="wpade.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + </ItemGroup> + <ItemGroup> + <None Include="Elementary_functions_f_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="Elementary_functions_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + </ItemGroup> +</Project>
\ No newline at end of file diff --git a/modules/elementary_functions/src/fortran/linpack/pade.f b/modules/elementary_functions/src/fortran/linpack/pade.f new file mode 100755 index 000000000..53afc5802 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/pade.f @@ -0,0 +1,162 @@ + subroutine pade(a,ia,n,ea,iea,alpha,wk,ipvt,ierr) +c +c!purpose +c compute the pade approximants of the exponential of a +c matrix a. we scale a until the spectral radius of a*2**-m +c are smaler than one. +c +c!calling sequence +c +c subroutine pade(a,ia,n,ea,iea,alpha,wk,ipvt,ierr) +c +c integer ia,n,iea,ipvt,ierr +c double precision a,ea,alpha,wk, +c dimension a(ia,*),ea(iea,*),wk(*),ipvt(*) +c +c a : array containing the matrix a +c ia : the leading dimension of arrays a. +c n : the order of the matrices a,ea . +c ea : the array that contains the n*n +c matrix exp(a). +c iea : the leading dimension of array ea. +c alpha : variable containing the maximun +c norm of the eigenvalues of a. +c wk : workspace array of size 2*n*(n+1) +c ipvt : integer workspace of size n +c ierr : error indicator +c ierr= 0 if normal return +c =-4 if alpha is to big for any accuracy. +c +c +c common /dcoeff/ c, ndng +c double precision c(41) +c integer ndng +c +c c : array containing on return pade coefficients +c ndng : on first call ndng must be set to -1,on return +c contains degree of pade approximant +c +c!auxiliary routines +c dclmat coef cerr (j. roche) +c dmmul dmcopy (blas.extension) +c dgeco dgesl (linpack) +c sqrt (fortran) +c! +c + integer ia,n,iea,ipvt,ierr + double precision a,ea,alpha,wk + dimension a(ia,*),ea(iea,*),wk(*),ipvt(*) +c internal variables + integer i,j,k,m,ndng,maxc,n2 + double precision rcond,c,efact,two,zero,norm,one,w + dimension c(41) +c +cDEC$ IF DEFINED (FORDLL) +cDEC$ ATTRIBUTES DLLIMPORT:: /dcoeff/ +cDEC$ ENDIF + common /dcoeff/ c, ndng +c + data zero, one, two, maxc /0.0d+0,1.0d+0,2.0d+0,15/ + n2=n*n +c + if (ndng.ge.0) go to 10 +c +c compute de pade's aprroximants type which is necessary to obtain +c machine precision +c + call coef(ierr) + if(ierr.ne.0) goto 170 + +c look for a power of 2 greater than alpha + 10 m = 0 + efact = one + if (alpha.le.1.0d+0) go to 90 +c + w=log(alpha)/log(2.0d0) + m=int(w) + if (dble(m).lt.w) m=m+1 + efact=2.0d0**m + goto 60 +c$$$ do 20 i=1,maxc +c$$$ m = m + 1 +c$$$ efact = efact*two +c$$$ if (alpha.le.efact) go to 60 +c$$$ 20 continue +c$$$ +c$$$ ierr = -4 +c$$$ go to 170 + 30 m = m + 1 + efact = efact*two + do 50 i=1,n + do 40 j=1,n + a(i,j) = a(i,j)/two + 40 continue + 50 continue + norm = norm/two + go to 115 +c +c we find a matrix a'=a*2-m whith a spectral radius smaller than one. +c + 60 continue + do 80 i=1,n + do 70 j=1,n + a(i,j) = a(i,j)/efact + 70 continue + 80 continue + 90 continue +c +c + call cerr(a, wk, ia, n, ndng, m, maxc) +c +c + norm = zero + do 110 i=1,n + alpha = zero + do 100 j=1,n + alpha = alpha + abs(a(i,j)) + 100 continue + if (alpha.gt.norm) norm = alpha + 110 continue +c +c compute the inverse of the denominator of dpade's approximants. +c + 115 continue + do 130 i=1,n + do 120 j=1,n + ea(i,j) = -a(i,j) + 120 continue + 130 continue + call dclmat(iea, n, ea, wk, n, wk(n2+1), c, ndng) +c +c compute de l-u decomposition of n (-a) and the condition numbwk(n2+1) +c pp +c + call dgeco(wk, n, n, ipvt, rcond, wk(n2+1)) +c + rcond=rcond*rcond*rcond*rcond + if ((rcond+one.le.one) .and. ((norm.gt.one) .and. + * (m.lt.maxc))) go to 30 +c +c compute the numerator of dpade's approximants. +c + call dclmat(ia, n, a, ea, iea, wk(n2+1), c, ndng) +c +c compute the dpade's approximants by +c +c n (-a) x=n (a) +c pp pp +c + do 150 j=1,n + call dgesl(wk, n, n, ipvt, ea(1,j), 0) + 150 continue + if (m.eq.0) go to 170 +c +c remove the effects of normalization. +c + do 160 k=1,m + call dmmul(ea,iea,ea,iea,wk,n,n,n,n) + call dmcopy(wk,n,ea,iea,n,n) + 160 continue + 170 continue + return + end diff --git a/modules/elementary_functions/src/fortran/linpack/pade.lo b/modules/elementary_functions/src/fortran/linpack/pade.lo new file mode 100755 index 000000000..38c826a7e --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/pade.lo @@ -0,0 +1,12 @@ +# src/fortran/linpack/pade.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/pade.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/linpack/util.f b/modules/elementary_functions/src/fortran/linpack/util.f new file mode 100755 index 000000000..01292ddb3 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/util.f @@ -0,0 +1,137 @@ + subroutine dpori(a,lda,n) + integer lda,n + double precision a(lda,1) +c +c dpori computes the inverse of the factor of a +c double precision symmetric positive definite matrix +c using the factors computed by dpofa. +c +c modification of dpodi by BaT 05/11/95 +c +c on entry +c +c a double precision(lda, n) +c the output a from dpofa +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 if dpofa was used to factor a then +c dpodi produces the upper half of inverse(a) . +c elements of a below the diagonal are unchanged. +c +c error condition +c +c a division by zero will occur if the input factor contains +c a zero on the diagonal and the inverse is requested. +c it will not occur if the subroutines are called correctly +c and if dpoco or dpofa has set info .eq. 0 . +c +c linpack. this version dated 08/14/78 . +c cleve moler, university of new mexico, argonne national lab. +c modified by Berwin A. Turlach 05/11/95 +c +c subroutines and functions +c +c blas daxpy,dscal +c fortran mod +c +c internal variables +c + double precision t + integer j,k,kp1 +c +c compute inverse(r) +c + do 100 k = 1, n + a(k,k) = 1.0d0/a(k,k) + t = -a(k,k) + call dscal(k-1,t,a(1,k),1) + kp1 = k + 1 + if (n .lt. kp1) go to 90 + do 80 j = kp1, n + t = a(k,j) + a(k,j) = 0.0d0 + call daxpy(k,t,a(1,k),1,a(1,j),1) + 80 continue + 90 continue + 100 continue + return + end + + subroutine dposl(a,lda,n,b) + integer lda,n + double precision a(lda,1),b(1) +c +c dposl solves the double precision symmetric positive definite +c system a * x = b +c using the factors computed by dpoco or dpofa. +c +c on entry +c +c a double precision(lda, n) +c the output from dpoco or dpofa. +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 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 will occur if the input factor contains +c a zero on the diagonal. technically this indicates +c singularity but it is usually caused by improper subroutine +c arguments. it will not occur if the subroutines are called +c correctly and info .eq. 0 . +c +c to compute inverse(a) * c where c is a matrix +c with p columns +c call dpoco(a,lda,n,rcond,z,info) +c if (rcond is too small .or. info .ne. 0) go to ... +c do 10 j = 1, p +c call dposl(a,lda,n,c(1,j)) +c 10 continue +c +c linpack. this version dated 08/14/78 . +c cleve moler, university of new mexico, argonne national lab. +c +c subroutines and functions +c +c blas daxpy,ddot +c +c internal variables +c + double precision ddot,t + integer k,kb +c +c solve trans(r)*y = b +c + do 10 k = 1, n + t = ddot(k-1,a(1,k),1,b(1),1) + b(k) = (b(k) - t)/a(k,k) + 10 continue +c +c solve r*x = y +c + do 20 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) + 20 continue + return + end diff --git a/modules/elementary_functions/src/fortran/linpack/util.lo b/modules/elementary_functions/src/fortran/linpack/util.lo new file mode 100755 index 000000000..43db922ee --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/util.lo @@ -0,0 +1,12 @@ +# src/fortran/linpack/util.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/util.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/linpack/wgeco.f b/modules/elementary_functions/src/fortran/linpack/wgeco.f new file mode 100755 index 000000000..407c9ae7a --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/wgeco.f @@ -0,0 +1,239 @@ + subroutine wgeco(ar,ai,lda,n,ipvt,rcond,zr,zi) + + integer lda,n,ipvt(*) + double precision ar(lda,*),ai(lda,*),zr(*),zi(*) + double precision rcond +c!purpose +c +c wgeco factors a double-complex matrix by gaussian elimination +c and estimates the condition of the matrix. +c +c if rcond is not needed, wgefa is slightly faster. +c to solve a*x = b , follow wgeco by wgesl. +c to compute inverse(a)*c , follow wgeco by wgesl. +c to compute determinant(a) , follow wgeco by wgedi. +c to compute inverse(a) , follow wgeco by wgedi. +c +c!calling sequence +c +c subroutine wgeco(ar,ai,lda,n,ipvt,rcond,zr,zi) +c on entry +c +c a double-complex(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-complex(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!originator +c linpack. this version dated 07/01/79 . +c cleve moler, university of new mexico, argonne national lab. +c +c!auxiliary routines +c +c linpack wgefa +c blas waxpy,wdotc,wasum +c fortran abs,max +c +c! +c internal variables +c + double precision wdotcr,wdotci,ekr,eki,tr,ti,wkr,wki,wkmr,wkmi + double precision anorm,s,wasum,sm,ynorm + integer info,j,k,kb,kp1,l +c + double precision zdumr,zdumi + double precision cabs1 + cabs1(zdumr,zdumi) = abs(zdumr) + abs(zdumi) +c +c compute 1-norm of a +c + anorm = 0.0d+0 + do 10 j = 1, n + anorm = max(anorm,wasum(n,ar(1,j),ai(1,j),1)) + 10 continue +c +c factor +c + call wgefa(ar,ai,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 ctrans(a)*y = e . +c ctrans(a) is the conjugate transpose of a . +c the components of e are chosen to cause maximum local +c growth in the elements of w where ctrans(u)*w = e . +c the vectors are frequently rescaled to avoid overflow. +c +c solve ctrans(u)*w = e +c + ekr = 1.0d+0 + eki = 0.0d+0 + do 20 j = 1, n + zr(j) = 0.0d+0 + zi(j) = 0.0d+0 + 20 continue + do 110 k = 1, n + call wsign(ekr,eki,-zr(k),-zi(k),ekr,eki) + if (cabs1(ekr-zr(k),eki-zi(k)) + * .le. cabs1(ar(k,k),ai(k,k))) go to 40 + s = cabs1(ar(k,k),ai(k,k)) + * /cabs1(ekr-zr(k),eki-zi(k)) + call wrscal(n,s,zr,zi,1) + ekr = s*ekr + eki = s*eki + 40 continue + wkr = ekr - zr(k) + wki = eki - zi(k) + wkmr = -ekr - zr(k) + wkmi = -eki - zi(k) + s = cabs1(wkr,wki) + sm = cabs1(wkmr,wkmi) + if (cabs1(ar(k,k),ai(k,k)) .eq. 0.0d+0) go to 50 + call wdiv(wkr,wki,ar(k,k),-ai(k,k),wkr,wki) + call wdiv(wkmr,wkmi,ar(k,k),-ai(k,k),wkmr,wkmi) + go to 60 + 50 continue + wkr = 1.0d+0 + wki = 0.0d+0 + wkmr = 1.0d+0 + wkmi = 0.0d+0 + 60 continue + kp1 = k + 1 + if (kp1 .gt. n) go to 100 + do 70 j = kp1, n + call wmul(wkmr,wkmi,ar(k,j),-ai(k,j),tr,ti) + sm = sm + cabs1(zr(j)+tr,zi(j)+ti) + call waxpy(1,wkr,wki,ar(k,j),-ai(k,j),1, + $ zr(j),zi(j),1) + s = s + cabs1(zr(j),zi(j)) + 70 continue + if (s .ge. sm) go to 90 + tr = wkmr - wkr + ti = wkmi - wki + wkr = wkmr + wki = wkmi + do 80 j = kp1, n + call waxpy(1,tr,ti,ar(k,j),-ai(k,j),1, + $ zr(j),zi(j),1) + 80 continue + 90 continue + 100 continue + zr(k) = wkr + zi(k) = wki + 110 continue + s = 1.0d+0/wasum(n,zr,zi,1) + call wrscal(n,s,zr,zi,1) +c +c solve ctrans(l)*y = w +c + do 140 kb = 1, n + k = n + 1 - kb + if (k .ge. n) go to 120 + zr(k) = zr(k) + * + wdotcr(n-k,ar(k+1,k),ai(k+1,k),1,zr(k+1),zi(k+1),1) + zi(k) = zi(k) + * + wdotci(n-k,ar(k+1,k),ai(k+1,k),1,zr(k+1),zi(k+1),1) + 120 continue + if (cabs1(zr(k),zi(k)) .le. 1.0d+0) go to 130 + s = 1.0d+0/cabs1(zr(k),zi(k)) + call wrscal(n,s,zr,zi,1) + 130 continue + l = ipvt(k) + tr = zr(l) + ti = zi(l) + zr(l) = zr(k) + zi(l) = zi(k) + zr(k) = tr + zi(k) = ti + 140 continue + s = 1.0d+0/wasum(n,zr,zi,1) + call wrscal(n,s,zr,zi,1) +c + ynorm = 1.0d+0 +c +c solve l*v = y +c + do 160 k = 1, n + l = ipvt(k) + tr = zr(l) + ti = zi(l) + zr(l) = zr(k) + zi(l) = zi(k) + zr(k) = tr + zi(k) = ti + if (k .lt. n) + * call waxpy(n-k,tr,ti,ar(k+1,k),ai(k+1,k),1,zr(k+1),zi(k+1), + * 1) + if (cabs1(zr(k),zi(k)) .le. 1.0d+0) go to 150 + s = 1.0d+0/cabs1(zr(k),zi(k)) + call wrscal(n,s,zr,zi,1) + ynorm = s*ynorm + 150 continue + 160 continue + s = 1.0d+0/wasum(n,zr,zi,1) + call wrscal(n,s,zr,zi,1) + ynorm = s*ynorm +c +c solve u*z = v +c + do 200 kb = 1, n + k = n + 1 - kb + if (cabs1(zr(k),zi(k)) + * .le. cabs1(ar(k,k),ai(k,k))) go to 170 + s = cabs1(ar(k,k),ai(k,k)) + * /cabs1(zr(k),zi(k)) + call wrscal(n,s,zr,zi,1) + ynorm = s*ynorm + 170 continue + if (cabs1(ar(k,k),ai(k,k)) .eq. 0.0d+0) go to 180 + call wdiv(zr(k),zi(k),ar(k,k),ai(k,k),zr(k),zi(k)) + 180 continue + if (cabs1(ar(k,k),ai(k,k)) .ne. 0.0d+0) go to 190 + zr(k) = 1.0d+0 + zi(k) = 0.0d+0 + 190 continue + tr = -zr(k) + ti = -zi(k) + call waxpy(k-1,tr,ti,ar(1,k),ai(1,k),1,zr(1),zi(1),1) + 200 continue +c make znorm = 1.0 + s = 1.0d+0/wasum(n,zr,zi,1) + call wrscal(n,s,zr,zi,1) + ynorm = s*ynorm +c + if (anorm .ne. 0.0d+0) rcond = ynorm/anorm + if (anorm .eq. 0.0d+0) rcond = 0.0d+0 + return + end diff --git a/modules/elementary_functions/src/fortran/linpack/wgeco.lo b/modules/elementary_functions/src/fortran/linpack/wgeco.lo new file mode 100755 index 000000000..6e73ec789 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/wgeco.lo @@ -0,0 +1,12 @@ +# src/fortran/linpack/wgeco.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wgeco.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/linpack/wgefa.f b/modules/elementary_functions/src/fortran/linpack/wgefa.f new file mode 100755 index 000000000..2160c3663 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/wgefa.f @@ -0,0 +1,121 @@ + subroutine wgefa(ar,ai,lda,n,ipvt,info) + + integer lda,n,ipvt(*),info + double precision ar(lda,*),ai(lda,*) +c!purpose +c +c wgefa factors a double-complex matrix by gaussian elimination. +c +c wgefa is usually called by wgeco, but it can be called +c directly with a saving in time if rcond is not needed. +c (time for wgeco) = (1 + 9/n)*(time for wgefa) . +c +c!calling sequence +c +c subroutine wgefa(ar,ai,lda,n,ipvt,info) +c on entry +c +c a double-complex(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 wgesl or wgedi will divide by zero +c if called. use rcond in wgeco for a reliable +c indication of singularity. +c +c!originator +c linpack. this version dated 07/01/79 . +c cleve moler, university of new mexico, argonne national lab. +c +c!auxiliary routines +c +c blas waxpy,wscal,iwamax +c fortran abs +c +c! +c internal variables +c + double precision tr,ti + integer iwamax,j,k,kp1,l,nm1 +c + double precision zdumr,zdumi + double precision cabs1 + cabs1(zdumr,zdumi) = abs(zdumr) + abs(zdumi) +c +c gaussian elimination with partial pivoting +c + 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 = iwamax(n-k+1,ar(k,k),ai(k,k),1) + k - 1 + ipvt(k) = l +c +c zero pivot implies this column already triangularized +c + if (cabs1(ar(l,k),ai(l,k)) .eq. 0.0d+0) go to 40 +c +c interchange if necessary +c + if (l .eq. k) go to 10 + tr = ar(l,k) + ti = ai(l,k) + ar(l,k) = ar(k,k) + ai(l,k) = ai(k,k) + ar(k,k) = tr + ai(k,k) = ti + 10 continue +c +c compute multipliers +c + call wdiv(-1.0d+0,0.0d+0,ar(k,k),ai(k,k),tr,ti) + call wscal(n-k,tr,ti,ar(k+1,k),ai(k+1,k),1) +c +c row elimination with column indexing +c + do 30 j = kp1, n + tr = ar(l,j) + ti = ai(l,j) + if (l .eq. k) go to 20 + ar(l,j) = ar(k,j) + ai(l,j) = ai(k,j) + ar(k,j) = tr + ai(k,j) = ti + 20 continue + call waxpy(n-k,tr,ti,ar(k+1,k),ai(k+1,k),1,ar(k+1,j), + * ai(k+1,j),1) + 30 continue + go to 50 + 40 continue + info = k + 50 continue + 60 continue + 70 continue + ipvt(n) = n + if (cabs1(ar(n,n),ai(n,n)) .eq. 0.0d+0) info = n + return + end diff --git a/modules/elementary_functions/src/fortran/linpack/wgefa.lo b/modules/elementary_functions/src/fortran/linpack/wgefa.lo new file mode 100755 index 000000000..239c501f7 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/wgefa.lo @@ -0,0 +1,12 @@ +# src/fortran/linpack/wgefa.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wgefa.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/linpack/wgesl.f b/modules/elementary_functions/src/fortran/linpack/wgesl.f new file mode 100755 index 000000000..d6cdbf878 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/wgesl.f @@ -0,0 +1,136 @@ + subroutine wgesl(ar,ai,lda,n,ipvt,br,bi,job) + + integer lda,n,ipvt(*),job + double precision ar(lda,*),ai(lda,*),br(*),bi(*) +c!purpose +c +c wgesl solves the double-complex system +c a * x = b or ctrans(a) * x = b +c using the factors computed by wgeco or wgefa. +c +c!calling sequence +c +c subroutine wgesl(ar,ai,lda,n,ipvt,br,bi,job) +c on entry +c +c a double-complex(lda, n) +c the output from wgeco or wgefa. +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 wgeco or wgefa. +c +c b double-complex(n) +c the right hand side vector. +c +c job integer +c = 0 to solve a*x = b , +c = nonzero to solve ctrans(a)*x = b where +c ctrans(a) is the conjugate 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 wgeco has set rcond .gt. 0.0 +c or wgefa has set info .eq. 0 . +c +c to compute inverse(a) * c where c is a matrix +c with p columns +c call wgeco(a,lda,n,ipvt,rcond,z) +c if (rcond is too small) go to ... +c do 10 j = 1, p +c call wgesl(a,lda,n,ipvt,c(1,j),0) +c 10 continue +c +c!originator +c linpack. this version dated 07/01/79 . +c cleve moler, university of new mexico, argonne national lab. +c +c!auxiliary routines +c +c blas waxpy,wdotc +c +c! +c internal variables +c + double precision wdotcr,wdotci,tr,ti + integer k,kb,l,nm1 +c + 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) + tr = br(l) + ti = bi(l) + if (l .eq. k) go to 10 + br(l) = br(k) + bi(l) = bi(k) + br(k) = tr + bi(k) = ti + 10 continue + call waxpy(n-k,tr,ti,ar(k+1,k),ai(k+1,k),1,br(k+1),bi(k+1), + * 1) + 20 continue + 30 continue +c +c now solve u*x = y +c + do 40 kb = 1, n + k = n + 1 - kb + call wdiv(br(k),bi(k),ar(k,k),ai(k,k),br(k),bi(k)) + tr = -br(k) + ti = -bi(k) + call waxpy(k-1,tr,ti,ar(1,k),ai(1,k),1,br(1),bi(1),1) + 40 continue + go to 100 + 50 continue +c +c job = nonzero, solve ctrans(a) * x = b +c first solve ctrans(u)*y = b +c + do 60 k = 1, n + tr = br(k) - wdotcr(k-1,ar(1,k),ai(1,k),1,br(1),bi(1),1) + ti = bi(k) - wdotci(k-1,ar(1,k),ai(1,k),1,br(1),bi(1),1) + call wdiv(tr,ti,ar(k,k),-ai(k,k),br(k),bi(k)) + 60 continue +c +c now solve ctrans(l)*x = y +c + if (nm1 .lt. 1) go to 90 + do 80 kb = 1, nm1 + k = n - kb + br(k) = br(k) + * + wdotcr(n-k,ar(k+1,k),ai(k+1,k),1,br(k+1),bi(k+1),1) + bi(k) = bi(k) + * + wdotci(n-k,ar(k+1,k),ai(k+1,k),1,br(k+1),bi(k+1),1) + l = ipvt(k) + if (l .eq. k) go to 70 + tr = br(l) + ti = bi(l) + br(l) = br(k) + bi(l) = bi(k) + br(k) = tr + bi(k) = ti + 70 continue + 80 continue + 90 continue + 100 continue + return + end diff --git a/modules/elementary_functions/src/fortran/linpack/wgesl.lo b/modules/elementary_functions/src/fortran/linpack/wgesl.lo new file mode 100755 index 000000000..b30bf7b88 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/wgesl.lo @@ -0,0 +1,12 @@ +# src/fortran/linpack/wgesl.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wgesl.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/linpack/wpade.f b/modules/elementary_functions/src/fortran/linpack/wpade.f new file mode 100755 index 000000000..c3235ef48 --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/wpade.f @@ -0,0 +1,169 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c +C/MEMBR ADD NAME=WPADE,SSI=0 +c + subroutine wpade(ar,ai,ia,n,ear,eai,iea,alpha,w,ipvt,ierr) +c +c!purpose +c compute the pade approximants of the exponential of a complex +c matrix a. we scale a until the spectral radius of a*2**-m +c are smaler than one. +c +c!calling sequence +c +c subroutine wpade(ar,ai,ia,n,ear,eai,iea,alpha,w,ipvt,ierr) +c +c integer ia,n,iea,ipvt,ierr +c double precision ar,ai,ear,eai,alpha,w +c dimension ar(ia,n),ai(ia,n),ear(iea,n),eai(iea,n),w(*),ipvt(*) +c +c ar,ai : array containing the matrix a +c ia : the leading dimension of arrays a. +c n : the order of the matrices a,ea . +c ear,eai : the array that contains the n*n +c matrix exp(a). +c iea : the leading dimension of array ea. +c alpha : variable containing the maximun +c norm of the eigenvalues of a. +c w : workspace array of size 4*n +4*n*n +c ipvt : integer workspace of size n +c ierr : error indicator +c ierr= 0 if normal return +c =-4 if alpha is to big for any accuracy. +c +c common /dcoeff/ c, ndng +c double precision c(41) +c integer ndng +c +c c : array containing on return pade coefficients +c ndng : on first call ndng must be set to -1,on return +c contains degree of pade approximant +c +c!auxiliary routines +c wclmat coef wcerr (j. roche) +c wmmul dmcopy (blas.extension) +c wgeco wgesl (linpack.extension) +c sqrt (fortran) +c! +c + integer ia,n,iea,ipvt,ierr + double precision ar,ai,ear,eai,alpha,w + dimension ar(ia,n),ai(ia,n),ear(iea,n),eai(iea,n),w(*),ipvt(*) +c +cDEC$ IF DEFINED (FORDLL) +cDEC$ ATTRIBUTES DLLIMPORT:: /dcoeff/ +cDEC$ ENDIF + common /dcoeff/ c, ndng +c internal variables + integer i,j,k,m,ndng,maxc,n2 + double precision rcond,c,efact,two,zero,norm,one + dimension c(41) +c + data zero, one, two, maxc /0.0d+0,1.0d+0,2.0d+0,10/ + n2=n*n + kr=1 + ki=kr+n2 + kw=ki+n2 +c + if (ndng.ge.0) go to 10 +c +c compute de pade's approximants type which is necessary to obtain +c machine precision +c + call coef(ierr) + if(ierr.ne.0) goto 170 + 10 m = 0 + efact = one + if (alpha.le.1.0d+0) go to 90 + do 20 i=1,maxc + m = m + 1 + efact = efact*two + if (alpha.le.efact) go to 60 + 20 continue + ierr = -4 + go to 170 + 30 m = m + 1 + efact = efact*two + do 50 i=1,n + do 40 j=1,n + ar(i,j) = ar(i,j)/two + ai(i,j) = ai(i,j)/two + 40 continue + 50 continue + norm = norm/two + go to 115 +c +c we find a matrix a'=a*2-m whith a spectral radius smaller than one. +c + 60 do 80 i=1,n + do 70 j=1,n + ar(i,j) = ar(i,j)/efact + ai(i,j) = ai(i,j)/efact + 70 continue + 80 continue + 90 continue +c +c + call wcerr(ar,ai,w,ia,n,ndng,m,maxc) +c +c + norm = zero + do 110 i=1,n + alpha = zero + do 100 j=1,n + alpha = alpha + abs(ar(i,j)) + abs(ai(i,j)) + 100 continue + if (alpha.gt.norm) norm = alpha + 110 continue +c +c compute the inverse of the denominator of dpade's approximants. +c + 115 continue + do 130 i=1,n + do 120 j=1,n + ear(i,j) = -ar(i,j) + eai(i,j) = -ai(i,j) + 120 continue + 130 continue + call wclmat(iea,n,ear,eai,w(kr),w(ki),n,w(kw),c,ndng) +c +c compute de l-u decomposition of n (-a) and the condition number +c pp +c + call wgeco(w(kr),w(ki), n, n, ipvt, rcond, w(kw),w(kw+n)) +c + rcond=rcond**4 + if ((rcond+one .le. one) .and. ((norm.gt.one) .and. + * (m.lt.maxc))) go to 30 +c +c compute the numerator of dpade's approximants. +c + call wclmat(ia, n, ar,ai,ear,eai, iea, w(kw), c, ndng) +c +c compute the dpade's approximants by +c +c n (-a) x=n (a) +c pp pp +c + do 150 j=1,n + call wgesl(w(kr),w(ki), n, n, ipvt, ear(1,j),eai(1,j), 0) + 150 continue + if (m.eq.0) go to 170 +c +c remove the effects of normalization. +c + do 160 k=1,m + call wmmul(ear,eai,iea,ear,eai,iea,w(kr),w(ki),n,n,n,n) + call dmcopy(w(kr),n,ear,iea,n,n) + call dmcopy(w(ki),n,eai,iea,n,n) + 160 continue + 170 continue + return + end diff --git a/modules/elementary_functions/src/fortran/linpack/wpade.lo b/modules/elementary_functions/src/fortran/linpack/wpade.lo new file mode 100755 index 000000000..a575332bc --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack/wpade.lo @@ -0,0 +1,12 @@ +# src/fortran/linpack/wpade.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wpade.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/linpack_f_Import.def b/modules/elementary_functions/src/fortran/linpack_f_Import.def new file mode 100755 index 000000000..5ecd46a0d --- /dev/null +++ b/modules/elementary_functions/src/fortran/linpack_f_Import.def @@ -0,0 +1,7 @@ +LIBRARY linpack_f.dll + + +EXPORTS +icopy_ +pade_ +wpade_ diff --git a/modules/elementary_functions/src/fortran/lnblnk.f b/modules/elementary_functions/src/fortran/lnblnk.f new file mode 100755 index 000000000..9430053ad --- /dev/null +++ b/modules/elementary_functions/src/fortran/lnblnk.f @@ -0,0 +1,26 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + integer function lnblnk(str) +c + character*(*) str + n=len(str)+1 + 10 continue + n=n-1 + if (n.eq.0) then + lnblnk=0 + return + else + if (str(n:n).ne.' ') then + lnblnk=n + return + endif + endif + goto 10 + end diff --git a/modules/elementary_functions/src/fortran/lnblnk.lo b/modules/elementary_functions/src/fortran/lnblnk.lo new file mode 100755 index 000000000..25eccfa43 --- /dev/null +++ b/modules/elementary_functions/src/fortran/lnblnk.lo @@ -0,0 +1,12 @@ +# src/fortran/lnblnk.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/lnblnk.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/magic.f b/modules/elementary_functions/src/fortran/magic.f new file mode 100755 index 000000000..f88e0e8f5 --- /dev/null +++ b/modules/elementary_functions/src/fortran/magic.f @@ -0,0 +1,90 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c +C/MEMBR ADD NAME=MAGIC,SSI=0 + subroutine magic(a,lda,n) +c!purpose +c algorithms for magic squares taken from +c mathematical recreations and essays, 12th ed., +c by w. w. rouse ball and h. s. m. coxeter +c!calling sequence +c subroutine magic(a,lda,n) +c double precision a(lda,n) +c integer lda,n +c! + double precision a(lda,n),t +c + if (mod(n,4) .eq. 0) go to 100 + if (mod(n,2) .eq. 0) m = n/2 + if (mod(n,2) .ne. 0) m = n +c +c odd order or upper corner of even order +c + do 20 j = 1,m + do 10 i = 1,m + a(i,j) = 0 + 10 continue + 20 continue + i = 1 + j = (m+1)/2 + mm = m*m + do 40 k = 1, mm + a(i,j) = k + i1 = i-1 + j1 = j+1 + if(i1.lt.1) i1 = m + if(j1.gt.m) j1 = 1 + if(int(a(i1,j1)).eq.0) go to 30 + i1 = i+1 + j1 = j + 30 i = i1 + j = j1 + 40 continue + if (mod(n,2) .ne. 0) return +c +c rest of even order +c + t = m*m + do 60 i = 1, m + do 50 j = 1, m + im = i+m + jm = j+m + a(i,jm) = a(i,j) + 2*t + a(im,j) = a(i,j) + 3*t + a(im,jm) = a(i,j) + t + 50 continue + 60 continue + m1 = (m-1)/2 + if (m1.eq.0) return + do 70 j = 1, m1 + call dswap(m,a(1,j),1,a(m+1,j),1) + 70 continue + m1 = (m+1)/2 + m2 = m1 + m + call dswap(1,a(m1,1),1,a(m2,1),1) + call dswap(1,a(m1,m1),1,a(m2,m1),1) + m1 = n+1-(m-3)/2 + if(m1.gt.n) return + do 80 j = m1, n + call dswap(m,a(1,j),1,a(m+1,j),1) + 80 continue + return +c +c double even order +c + 100 k = 1 + do 120 i = 1, n + do 110 j = 1, n + a(i,j) = k + if (mod(i,4)/2 .eq. mod(j,4)/2) a(i,j) = n*n+1 - k + k = k+1 + 110 continue + 120 continue + return + end diff --git a/modules/elementary_functions/src/fortran/magic.lo b/modules/elementary_functions/src/fortran/magic.lo new file mode 100755 index 000000000..91db3685c --- /dev/null +++ b/modules/elementary_functions/src/fortran/magic.lo @@ -0,0 +1,12 @@ +# src/fortran/magic.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/magic.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/mtran.f b/modules/elementary_functions/src/fortran/mtran.f new file mode 100755 index 000000000..716d1e640 --- /dev/null +++ b/modules/elementary_functions/src/fortran/mtran.f @@ -0,0 +1,44 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c +C/MEMBR ADD NAME=MTRAN,SSI=0 +c + subroutine mtran(a,na,b,nb,m,n) +c!but +c mtran transpose la matrice a dans le tableau b +c a et b n'ayant pas la meme implantation memoire +c +c!liste d'appel +c subroutine mtran(a,na,b,nb,m,n) +c double precision a(na,n),b(nb,m) +c integer na,nb,m,n +c +c a tableau contenant la matrice a +c na nombre de ligne du tableau a dans le prog appelant +c b,nb definition similaire a celle de a,na +c m nombre de lignes de a et de colonnes de b +c n nombre de colonnes de a et de lignes de b +c!sous programmes utilises +c neant +c! + double precision a(*),b(*) + integer na,nb,m,n + integer i,j,ia,ib +c + ia=0 + do 20 j=1,n + ib=j + do 10 i=1,m + b(ib)=a(ia+i) + ib=ib+nb + 10 continue + ia=ia+na + 20 continue + return + end diff --git a/modules/elementary_functions/src/fortran/mtran.lo b/modules/elementary_functions/src/fortran/mtran.lo new file mode 100755 index 000000000..8205bfdff --- /dev/null +++ b/modules/elementary_functions/src/fortran/mtran.lo @@ -0,0 +1,12 @@ +# src/fortran/mtran.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/mtran.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/nearfloat.f b/modules/elementary_functions/src/fortran/nearfloat.f new file mode 100755 index 000000000..92b68824c --- /dev/null +++ b/modules/elementary_functions/src/fortran/nearfloat.f @@ -0,0 +1,162 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) Bruno Pincon +C Copyright (C) 2010 - DIGITEO - Michael Baudin +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + double precision function nearfloat(x, dir) +* +* PURPOSE +* Compute the near (double) float from x in +* the direction dir +* dir >= 0 => toward +oo +* dir < 0 => toward -oo +* +* AUTHOR +* Bruno Pincon <Bruno.Pincon@iecn.u-nancy.fr> +* +* REMARK +* This code may be shorter if we assume that the +* radix base of floating point numbers is 2 : one +* could use the frexp C function to extract the +* mantissa and exponent part in place of dealing +* with a call to the log function with corrections +* to avoid possible floating point error... +* + implicit none + +* PARAMETERS + double precision x, dir + +* EXTERNAL FUNCTIONS + double precision dlamch + external dlamch + integer isanan + external isanan +* LOCAL VARIABLES + double precision sign_x, ep, xa, d, m + integer e, i, p + +* STATIC VARIABLES + logical first, DENORM + + double precision RMAX, RMIN, ULP, BASE, LNB, TINY + save RMAX, RMIN, ULP, BASE, LNB, TINY + save first, DENORM + data first /.true./ + + +* TEXT +* got f.p. parameters used by the algorithm + if (first) then + RMAX = dlamch('o') + RMIN = dlamch('u') + BASE = dlamch('b') + p = int(dlamch('n')) + LNB = log(BASE) + +* computation of 1 ulp : 1 ulp = base^(1-p) +* p = number of digits for the mantissa = dlamch('n') + ULP = BASE**(1 - p) + +* query if denormalized numbers are used : if yes +* compute TINY the smallest denormalized number > 0 : +* TINY is also the increment between 2 neighbooring +* denormalized numbers + if (RMIN/BASE .ne. 0.d0) then + DENORM = .true. + TINY = RMIN + do i = 1, p-1 + TINY = TINY / BASE + enddo + else + DENORM = .false. + endif + first = .false. + endif + + d = sign(1.d0, dir) + sign_x = sign(1.d0, x) + xa = abs(x) + + if (isanan(x) .eq. 1) then +* nan + nearfloat = x + + elseif (xa .gt. RMAX) then +* +-inf + if (d*sign_x .lt. 0.d0) then + nearfloat = sign_x * RMAX + else + nearfloat = x + endif + + elseif (xa .ge. RMIN) then +* usual case : x is a normalized floating point number +* 1/ got the exponent e and the exponent part ep = base^e + e = int( log(xa)/LNB ) + ep = BASE**e +* in case of xa very near RMAX an error in e (of + 1) +* result in an overflow in ep + if ( ep .gt. RMAX ) then + e = e - 1 + ep = BASE**e + endif +* also in case of xa very near RMIN and when denormalized +* number are not used, an error in e (of -1) results in a +* flush to 0 for ep. + if ( ep .eq. 0.d0 ) then + e = e + 1 + ep = BASE**e + endif + +* 2/ got the mantissa + m = xa/ep + +* 3/ verify that 1 <= m < BASE + if ( m .lt. 1.d0 ) then +* multiply m by BASE + do while ( m .lt. 1.d0 ) + m = m * BASE + ep = ep / BASE + enddo + elseif ( m .ge. BASE ) then +* divide m by BASE + do while ( m .ge. 1.d0 ) + m = m / BASE + ep = ep * BASE + enddo + endif + +* 4/ now compute the near float + if (d*sign_x .lt. 0.d0) then +* retrieve one ULP to m but there is a special case + if ( m .eq. 1.d0 .and. xa .ne. RMIN ) then +* this is the special case : we must retrieve ULP / BASE + nearfloat = sign_x*( m - (ULP/BASE) )*ep + else + nearfloat = sign_x*( m - ULP )*ep + endif + else + nearfloat = sign_x*(m + ULP)*ep + endif + + elseif ( x .eq. 0.d0 ) then +* case x = 0 nearfloat depends if denormalized numbers are used + if (DENORM) then + nearfloat = d*TINY + else + nearfloat = d*RMIN + endif + + else +* x is a denormalized number + nearfloat = x + d*TINY + + endif + + end diff --git a/modules/elementary_functions/src/fortran/nearfloat.lo b/modules/elementary_functions/src/fortran/nearfloat.lo new file mode 100755 index 000000000..c3e0961d4 --- /dev/null +++ b/modules/elementary_functions/src/fortran/nearfloat.lo @@ -0,0 +1,12 @@ +# src/fortran/nearfloat.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/nearfloat.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/orthes.f b/modules/elementary_functions/src/fortran/orthes.f new file mode 100755 index 000000000..3dc463d94 --- /dev/null +++ b/modules/elementary_functions/src/fortran/orthes.f @@ -0,0 +1,114 @@ +C/MEMBR ADD NAME=ORTHES,SSI=0 + subroutine orthes(nm,n,low,igh,a,ort) +c + integer i,j,m,n,ii,jj,la,mp,nm,igh,kp1,low + double precision a(nm,n),ort(igh) + double precision f,g,h,scale +c! purpose +c +c given a real general matrix, this subroutine +c reduces a submatrix situated in rows and columns +c low through igh to upper hessenberg form by +c orthogonal similarity transformations. +c +c! calling sequence +c +c subroutine orthes(nm,n,low,igh,a,ort) +c +c on input: +c +c nm must be set to the row dimension of two-dimensional +c array parameters as declared in the calling program +c dimension statement; +c +c n is the order of the matrix; +c +c low and igh are integers determined by the balancing +c subroutine balanc. if balanc has not been used, +c set low=1, igh=n; +c +c a contains the input matrix. +c +c on output: +c +c a contains the hessenberg matrix. information about +c the orthogonal transformations used in the reduction +c is stored in the remaining triangle under the +c hessenberg matrix; +c +c ort contains further information about the transformations. +c only elements low through igh are used. +c +c!originator +c +c this subroutine is a translation of the algol procedure orthes, +c num. math. 12, 349-368(1968) by martin and wilkinson. +c handbook for auto. comp., vol.ii-linear algebra, 339-358(1971). +c questions and comments should be directed to b. s. garbow, +c applied mathematics division, argonne national laboratory +c +c! +c ------------------------------------------------------------------ +c + la = igh - 1 + kp1 = low + 1 + if (la .lt. kp1) go to 200 +c + do 180 m = kp1, la + h = 0.0d+0 + ort(m) = 0.0d+0 + scale = 0.0d+0 +c :::::::::: scale column (algol tol then not needed) :::::::::: + do 90 i = m, igh + 90 scale = scale + abs(a(i,m-1)) +c + if (scale .eq. 0.0d+0) go to 180 + mp = m + igh +c :::::::::: for i=igh step -1 until m do -- :::::::::: + do 100 ii = m, igh + i = mp - ii + ort(i) = a(i,m-1) / scale + h = h + ort(i) * ort(i) + 100 continue +c + g = -sign(sqrt(h),ort(m)) + h = h - ort(m) * g + ort(m) = ort(m) - g +c :::::::::: form (i-(u*ut)/h) * a :::::::::: + do 130 j = m, n + f = 0.0d+0 +c :::::::::: for i=igh step -1 until m do -- :::::::::: + do 110 ii = m, igh + i = mp - ii + f = f + ort(i) * a(i,j) + 110 continue +c + f = f / h +c + do 120 i = m, igh + 120 a(i,j) = a(i,j) - f * ort(i) +c + 130 continue +c :::::::::: form (i-(u*ut)/h)*a*(i-(u*ut)/h) :::::::::: + do 160 i = 1, igh + f = 0.0d+0 +c :::::::::: for j=igh step -1 until m do -- :::::::::: + do 140 jj = m, igh + j = mp - jj + f = f + ort(j) * a(i,j) + 140 continue +c + f = f / h +c + do 150 j = m, igh + 150 a(i,j) = a(i,j) - f * ort(j) +c + 160 continue +c + ort(m) = scale * ort(m) + a(m,m-1) = scale * g + 180 continue +c + 200 return +c :::::::::: last card of orthes :::::::::: + end diff --git a/modules/elementary_functions/src/fortran/orthes.lo b/modules/elementary_functions/src/fortran/orthes.lo new file mode 100755 index 000000000..6582b1218 --- /dev/null +++ b/modules/elementary_functions/src/fortran/orthes.lo @@ -0,0 +1,12 @@ +# src/fortran/orthes.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/orthes.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/ortran.f b/modules/elementary_functions/src/fortran/ortran.f new file mode 100755 index 000000000..34c300518 --- /dev/null +++ b/modules/elementary_functions/src/fortran/ortran.f @@ -0,0 +1,93 @@ +C/MEMBR ADD NAME=ORTRAN,SSI=0 + subroutine ortran(nm,n,low,igh,a,ort,z) +c + integer i,j,n,kl,mm,mp,nm,igh,low,mp1 + double precision a(nm,igh),ort(igh),z(nm,n) + double precision g +c!purpose +c +c this subroutine accumulates the orthogonal similarity +c transformations used in the reduction of a real general +c matrix to upper hessenberg form by orthes. +c +c!calling sequence +c +c subroutine ortran(nm,n,low,igh,a,ort,z) +c +c on input: +c +c nm must be set to the row dimension of two-dimensional +c array parameters as declared in the calling program +c dimension statement; +c +c n is the order of the matrix; +c +c low and igh are integers determined by the balancing +c subroutine balanc. if balanc has not been used, +c set low=1, igh=n; +c +c a contains information about the orthogonal trans- +c formations used in the reduction by orthes +c in its strict lower triangle; +c +c ort contains further information about the trans- +c formations used in the reduction by orthes. +c only elements low through igh are used. +c +c on output: +c +c z contains the transformation matrix produced in the +c reduction by orthes; +c +c ort has been altered. +c +c!originator +c +c this subroutine is a translation of the algol procedure ortrans, +c num. math. 16, 181-204(1970) by peters and wilkinson. +c handbook for auto. comp., vol.ii-linear algebra, 372-395(1971). +c! +c questions and comments should be directed to b. s. garbow, +c applied mathematics division, argonne national laboratory +c +c ------------------------------------------------------------------ +c +c :::::::::: initialize z to identity matrix :::::::::: + do 80 i = 1, n +c + do 60 j = 1, n + 60 z(i,j) = 0.0d+0 +c + z(i,i) = 1.0d+0 + 80 continue +c + kl = igh - low - 1 + if (kl .lt. 1) go to 200 +c :::::::::: for mp=igh-1 step -1 until low+1 do -- :::::::::: + do 140 mm = 1, kl + mp = igh - mm + if (a(mp,mp-1) .eq. 0.0d+0) go to 140 + mp1 = mp + 1 +c + do 100 i = mp1, igh + 100 ort(i) = a(i,mp-1) +c + do 130 j = mp, igh + g = 0.0d+0 +c + do 110 i = mp, igh + 110 g = g + ort(i) * z(i,j) +c :::::::::: divisor below is negative of h formed in orthes. +c double division avoids possible underflow :::::::::: + g = (g / ort(mp)) / a(mp,mp-1) +c + do 120 i = mp, igh + 120 z(i,j) = z(i,j) + g * ort(i) +c + 130 continue +c + 140 continue +c + 200 return +c :::::::::: last card of ortran :::::::::: + end diff --git a/modules/elementary_functions/src/fortran/ortran.lo b/modules/elementary_functions/src/fortran/ortran.lo new file mode 100755 index 000000000..6aad98fe2 --- /dev/null +++ b/modules/elementary_functions/src/fortran/ortran.lo @@ -0,0 +1,12 @@ +# src/fortran/ortran.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ortran.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/polynomials_f_Import.def b/modules/elementary_functions/src/fortran/polynomials_f_Import.def new file mode 100755 index 000000000..63d232e70 --- /dev/null +++ b/modules/elementary_functions/src/fortran/polynomials_f_Import.def @@ -0,0 +1,6 @@ +LIBRARY polynomials_f.dll + + +EXPORTS +dmpcle_ +huge_ diff --git a/modules/elementary_functions/src/fortran/pythag.f b/modules/elementary_functions/src/fortran/pythag.f new file mode 100755 index 000000000..4f17b46ea --- /dev/null +++ b/modules/elementary_functions/src/fortran/pythag.f @@ -0,0 +1,145 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) Bruno Pincon +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + double precision function pythag(a, b) +* +* PURPOSE +* computes sqrt(a^2 + b^2) with accuracy and +* without spurious underflow / overflow problems +* +* MOTIVATION +* This work was motivated by the fact that the original Scilab +* PYTHAG, which implements Moler and Morrison's algorithm is slow. +* Some tests showed that the Kahan's algorithm, is superior in +* precision and moreover faster than the original PYTHAG. The speed +* gain partly comes from not calling DLAMCH. +* +* REFERENCE +* This is a Fortran-77 translation of an algorithm by William Kahan, +* which appears in his article "Branch cuts for complex elementary +* functions, or much ado about nothing's sign bit", +* Editors: Iserles, A. and Powell, M. J. D. +* in "States of the Art in Numerical Analysis" +* Oxford, Clarendon Press, 1987 +* ISBN 0-19-853614-3 +* +* AUTHOR +* Bruno Pincon <Bruno.Pincon@iecn.u-nancy.fr>, +* Thanks to Lydia van Dijk <lvandijk@hammersmith-consulting.com> +* + implicit none + +* PARAMETERS + double precision a, b + +* EXTERNAL FUNCTIONS + integer isanan + external isanan + double precision dlamch + external dlamch + +* CONSTANTS + double precision r2, r2p1, t2p1 +* These constants depend upon the floating point arithmetic of the +* machine. Here, we give them assuming radix 2 and a 53 bits wide +* mantissa, correspond to IEEE 754 double precision format. YOU +* MUST RE-COMPUTE THESE CONSTANTS FOR A MACHINE THAT HAS DIFFERENT +* CHARACTERISTIC! +* +* (1) r2 must approximate sqrt(2) to machine precision. The near +* floating point from sqrt(2) is exactly: +* +* r2 = (1.0110101000001001111001100110011111110011101111001101)_2 +* = (1.4142135623730951454746218587388284504413604736328125)_10 +* sqrt(2) = (1.41421356237309504880168872420969807856967187537694807317...)_10 +* +* (2) r2p1 must approximate 1+sqrt(2) to machine precision. +* The near floating point is exactly: +* +* r2p1 = (10.011010100000100111100110011001111111001110111100110)_2 +* = (2.41421356237309492343001693370752036571502685546875)_10 +* sqrt(2)+1 = (2.41421356237309504880168872420969807856967187537694...)_10 +* +* (3) t2p1 must approximate 1+sqrt(2)-r2p1 to machine precision, +* this is +* 1.25371671790502177712854645019908198073176679... 10^(-16) +* and the near float is exactly: +* (5085679199899093/40564819207303340847894502572032)_10 +* t2p1 = (1.253716717905021735741793363204945859....)_10 +* + parameter ( r2 = 1.41421356237309504d0, + $ r2p1 = 2.41421356237309504d0, + $ t2p1 = 1.25371671790502177d-16) +* LOCAL VARIABLES + double precision x, y + double precision s, t, temp + +* STATIC VARIABLES + double precision rmax + save rmax + + logical first + save first + data first /.true./ + + +* TEXT +* Initialize rmax with computed largest non-overflowing number + if (first) then + rmax = dlamch('o') + first = .false. + endif + +* Test for arguments being NaN + if (isanan(a) .eq. 1) then + pythag = a + return + endif + if (isanan(b) .eq. 1) then + pythag = b + return + endif + + x = abs(a) + y = abs(b) + +* Order x and y such that 0 <= y <= x + if (x .lt. y) then + temp = x + x = y + y = temp + endif + +* Test for overflowing x + if (x .gt. rmax) then + pythag = x + return + endif + +* Handle generic case + t = x - y + if (t .ne. x) then + if (t .gt. y) then +* 2 < x/y < 2/epsm + s = x / y + s = s + sqrt(1d0 + s*s) + else +* 1 <= x/y <= 2 + s = t / y + t = (2d0 + s) * s + s = ( ( t2p1 + t/(r2 + sqrt(2d0 + t)) ) + s ) + r2p1 + endif + pythag = x + y/s + else + pythag = x + endif + end + + + diff --git a/modules/elementary_functions/src/fortran/pythag.lo b/modules/elementary_functions/src/fortran/pythag.lo new file mode 100755 index 000000000..aa92d388a --- /dev/null +++ b/modules/elementary_functions/src/fortran/pythag.lo @@ -0,0 +1,12 @@ +# src/fortran/pythag.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/pythag.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/rat.f b/modules/elementary_functions/src/fortran/rat.f new file mode 100755 index 000000000..3da246d66 --- /dev/null +++ b/modules/elementary_functions/src/fortran/rat.f @@ -0,0 +1,63 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA - Serge STEER +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine rat(x,eps,n,d,fail) +c!but +c ce sous programme approximme un reel x par un rationnel n/d +c!liste d'appel +c +c subroutine rat(x,eps,n,d,fail) +c double precision x,eps +c integer n,d,fail +c +c x: reel contenant le nombre a approximer +c eps: precision requise : (abs(x-n/d))<eps +c n,d:entiers contenant respectivement le numerateur et le +c denominateur du resultat +c fail:indicateur d'erreur +c fail=0 : ok +c fail.ne.0 precision requise trop grande ou nombre trop +c grand ou trop petit pour etre code sous cette forme +c!origine +c s steer inria +c + double precision x,eps,z,err,dz,xn,xd,ax + integer n,d,nmax,n0,d0,n1,d1,bm,fail +c possibly the largest integer (hum ???) + nmax=2147483647 + fail=0 + n0=0 + d0=1 + n1=1 + d1=0 + z=abs(x) + ax=z + 10 err=abs(d1*ax-n1) + if(err.le.d1*eps) goto 20 + if(z.gt.nmax) goto 30 + bm=int(z) + dz=z-bm + if(dz.eq.0.0d+0) goto 15 + z=1.0d+0/dz + 15 xn=n0+dble(bm)*n1 + xd=d0+dble(bm)*d1 + if(xn.gt.nmax.or.xd.gt.nmax) goto 30 + n0=n1 + d0=d1 + n1=int(xn) + d1=int(xd) + if(dz.eq.0.0d+0) goto 20 + goto 10 + 20 n=n1 + d=d1 + if (x.lt.0.0d+0) n=-n + return + 30 fail=1 + return + end diff --git a/modules/elementary_functions/src/fortran/rat.lo b/modules/elementary_functions/src/fortran/rat.lo new file mode 100755 index 000000000..3cbdf68e7 --- /dev/null +++ b/modules/elementary_functions/src/fortran/rat.lo @@ -0,0 +1,12 @@ +# src/fortran/rat.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/rat.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/rcopy.f b/modules/elementary_functions/src/fortran/rcopy.f new file mode 100755 index 000000000..a6b49918c --- /dev/null +++ b/modules/elementary_functions/src/fortran/rcopy.f @@ -0,0 +1,57 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine rcopy(n,dx,incx,dy,incy) +c +c copies a vector, x, to a vector, y. +c uses unrolled loops for increments equal to one. +c + real dx(*),dy(*) + integer i,incx,incy,ix,iy,m,mp1,n +c + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + 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) = dx(ix) + ix = ix + incx + iy = iy + incy + 10 continue + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,7) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dy(i) = dx(i) + 30 continue + if( n .lt. 7 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,7 + dy(i) = dx(i) + dy(i + 1) = dx(i + 1) + dy(i + 2) = dx(i + 2) + dy(i + 3) = dx(i + 3) + dy(i + 4) = dx(i + 4) + dy(i + 5) = dx(i + 5) + dy(i + 6) = dx(i + 6) + 50 continue + return + end diff --git a/modules/elementary_functions/src/fortran/rcopy.lo b/modules/elementary_functions/src/fortran/rcopy.lo new file mode 100755 index 000000000..1e7226afa --- /dev/null +++ b/modules/elementary_functions/src/fortran/rcopy.lo @@ -0,0 +1,12 @@ +# src/fortran/rcopy.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/rcopy.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/rcsort.f b/modules/elementary_functions/src/fortran/rcsort.f new file mode 100755 index 000000000..4348cab74 --- /dev/null +++ b/modules/elementary_functions/src/fortran/rcsort.f @@ -0,0 +1,171 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine rcsort(test,isz,iptr,iv,n,index) +c +c!purpose +c rcsort sort a set of integer records ,maintaining an index array +c +c!calling sequence +c subroutine rcsort(test,isz,iptr,iv,n,index) +c integer n,index(n),iv(*),isz(n) +c integer iptr(n+1) +c +c test : external integer function which define formal order for +c records +c test(r1,l1,r2,l2) +c where +c l1 is the length or record r1 +c l2 is the length or record r2 +c returns +c 1 :if record r1 is greater than r2 +c -1 :if record r1 is less than r2 +c 0 :if record r1 is equal to r2 +c isz : vector of records sizes +c iptr : table of records adresses in iv +c iv : table of records values +c n : size of vector of record and index +c index : array containing on return index of sorted array +c +c!method +c quick sort method is used +c!restriction +c n must be less than 2**(50/2) ! due to lengh of work space mark +c + dimension mark(50),index(n) + integer iptr(*),isz(n),iv(*),av,x,it,s,as + integer test + external test +c +c set index array to original order . + do 10 i=1,n + index(i)=i + 10 continue +c check that a trivial case has not been entered . + if(n.eq.1) goto 200 + if(n.ge.1) goto 30 + goto 200 +c 'm' is the length of segment which is short enough to enter +c the final sorting routine. it may be easily changed. + 30 m=12 +c set up initial values. + la=2 + is=1 + if=n + do 190 mloop=1,n +c if segment is short enough sort with final sorting routine . + ifka=if-is + if((ifka+1).gt.m) goto 70 +c*********final sorting *** +c ( a simple bubble sort ) + is1=is+1 + do 60 j=is1,if + i=j + 40 continue + it=test(iv(iptr(i-1)),isz(i-1),iv(iptr(i)),isz(i)) + if(it.eq.1) goto 60 + if(it.eq.-1) goto 50 + if(index(i-1).lt.index(i)) goto 60 + 50 av=iptr(i-1) + iptr(i-1)=iptr(i) + iptr(i)=av +c + as=isz(i-1) + isz(i-1)=isz(i) + isz(i)=as +c + int=index(i-1) + index(i-1)=index(i) + index(i)=int +c + i=i-1 + if(i.gt.is) goto 40 + 60 continue + la=la-2 + goto 170 +c ******* quicksort ******** +c select the number in the central position in the segment as +c the test number.replace it with the number from the segment's +c highest address. + 70 iy=(is+if)/2 + x=iptr(iy) + intest=index(iy) + s=isz(iy) + + iptr(iy)=iptr(if) + isz(iy)=isz(if) + index(iy)=index(if) +c the markers 'i' and 'ifk' are used for the beginning and end +c of the section not so far tested against the present value +c of x . + k=1 + ifk=if +c we alternate between the outer loop that increases i and the +c inner loop that reduces ifk, moving numbers and indices as +c necessary, until they meet . + do 110 i=is,if + it=test(iv(x),s,iv(iptr(i)),isz(i)) + if(it.lt.0) goto 110 + if(it.gt.0) goto 80 + if(intest.gt.index(i)) goto 110 + 80 if(i.ge.ifk) goto 120 + iptr(ifk)=iptr(i) + index(ifk)=index(i) + isz(ifk)=isz(i) + k1=k + do 100 k=k1,ifka + ifk=if-k + it=test(iv(iptr(ifk)),isz(ifk),iv(x),s) + if(it.lt.0) goto 100 + if(it.gt.0) goto 90 + if(intest.le.index(ifk)) goto 100 + 90 if(i.ge.ifk) goto 130 + iptr(i)=iptr(ifk) + index(i)=index(ifk) + isz(i)=isz(ifk) + goto 110 + 100 continue + goto 120 + 110 continue +c return the test number to the position marked by the marker +c which did not move last. it divides the initial segment into +c 2 parts. any element in the first part is less than or equal +c to any element in the second part, and they may now be sorted +c independently . + 120 iptr(ifk)=x + index(ifk)=intest + isz(ifk)=s + ip=ifk + goto 140 + 130 iptr(i)=x + index(i)=intest + isz(i)=s + ip=i +c store the longer subdivision in workspace. + 140 if((ip-is).gt.(if-ip)) goto 150 + mark(la)=if + mark(la-1)=ip+1 + if=ip-1 + goto 160 + 150 mark(la)=ip-1 + mark(la-1)=is + is=ip+1 +c find the length of the shorter subdivision. + 160 lngth=if-is + if(lngth.le.0) goto 180 +c if it contains more than one element supply it with workspace . + la=la+2 + goto 190 + 170 if(la.le.0) goto 200 +c obtain the address of the shortest segment awaiting quicksort + 180 if=mark(la) + is=mark(la-1) + 190 continue + 200 return + end diff --git a/modules/elementary_functions/src/fortran/rcsort.lo b/modules/elementary_functions/src/fortran/rcsort.lo new file mode 100755 index 000000000..4d363d099 --- /dev/null +++ b/modules/elementary_functions/src/fortran/rcsort.lo @@ -0,0 +1,12 @@ +# src/fortran/rcsort.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/rcsort.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/round.f b/modules/elementary_functions/src/fortran/round.f new file mode 100755 index 000000000..47911168e --- /dev/null +++ b/modules/elementary_functions/src/fortran/round.f @@ -0,0 +1,51 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + double precision function sciround(x1) +c + double precision x1,x,y,z,e,h + data h/1.0d+9/ +c + x=x1 + if (x.eq.0d0) then + sciround=x + return + endif + if ((2.0d0*x).eq.dble(int(2.d0*x))) then +c changing the signs gives round(0.5)=0 round(-0.5)=0 + if (x.gt.0.d0) x=x+1.d-10 + if (x.lt.0.d0) x=x-1.d-10 + endif + z = abs(x) +c -----testing Nans + if (isanan(x).eq.1) then + sciround=x + return + endif + y = z + 1.0d+0 + if (y .eq. z) then + sciround=x + return + endif + y = 0.0d+0 + e = h + 10 if (e .ge. z) go to 20 + e = 2.0d+0*e + go to 10 + 20 if (e .le. h) go to 30 + if (e .le. z) y = y + e + if (e .le. z) z = z - e + e = e/2.0d+0 + go to 20 + 30 z = int(z + 0.50d+0) + y = y + z + if (x .lt. 0.0d+0) y = -y + sciround = y + return + end diff --git a/modules/elementary_functions/src/fortran/round.lo b/modules/elementary_functions/src/fortran/round.lo new file mode 100755 index 000000000..995574938 --- /dev/null +++ b/modules/elementary_functions/src/fortran/round.lo @@ -0,0 +1,12 @@ +# src/fortran/round.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/round.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/simple.f b/modules/elementary_functions/src/fortran/simple.f new file mode 100755 index 000000000..226b6e62a --- /dev/null +++ b/modules/elementary_functions/src/fortran/simple.f @@ -0,0 +1,28 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine simple(n,d,s) +c + double precision d(*) + real s(*),rmax,slamch +c +c slamch return wrong value under MacOSX +c slamch('o') <=> HUGE(ZERO) +c http://www.netlib.org/lapack/util/slamch.f + rmax=HUGE(0.0E+0) +c + do 10 i=1,n + if(abs(d(i)).gt.rmax) then + s(i)=real(sign(dble(rmax),d(i))) + else + s(i)=real(d(i)) + endif + 10 continue + return + end diff --git a/modules/elementary_functions/src/fortran/simple.lo b/modules/elementary_functions/src/fortran/simple.lo new file mode 100755 index 000000000..93b8d14be --- /dev/null +++ b/modules/elementary_functions/src/fortran/simple.lo @@ -0,0 +1,12 @@ +# src/fortran/simple.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/simple.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/.deps/.dirstamp b/modules/elementary_functions/src/fortran/slatec/.deps/.dirstamp new file mode 100755 index 000000000..e69de29bb --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.deps/.dirstamp diff --git a/modules/elementary_functions/src/fortran/slatec/.dirstamp b/modules/elementary_functions/src/fortran/slatec/.dirstamp new file mode 100755 index 000000000..e69de29bb --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.dirstamp diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/balanc.o b/modules/elementary_functions/src/fortran/slatec/.libs/balanc.o Binary files differnew file mode 100755 index 000000000..0a4be4531 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/balanc.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/d9b0mp.o b/modules/elementary_functions/src/fortran/slatec/.libs/d9b0mp.o Binary files differnew file mode 100755 index 000000000..e77c09736 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/d9b0mp.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/d9b1mp.o b/modules/elementary_functions/src/fortran/slatec/.libs/d9b1mp.o Binary files differnew file mode 100755 index 000000000..b58fe8f0f --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/d9b1mp.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/d9knus.o b/modules/elementary_functions/src/fortran/slatec/.libs/d9knus.o Binary files differnew file mode 100755 index 000000000..ff8888fa1 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/d9knus.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/d9lgmc.o b/modules/elementary_functions/src/fortran/slatec/.libs/d9lgmc.o Binary files differnew file mode 100755 index 000000000..7340f38df --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/d9lgmc.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dasyik.o b/modules/elementary_functions/src/fortran/slatec/.libs/dasyik.o Binary files differnew file mode 100755 index 000000000..85475f60c --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dasyik.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dasyjy.o b/modules/elementary_functions/src/fortran/slatec/.libs/dasyjy.o Binary files differnew file mode 100755 index 000000000..9a228a517 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dasyjy.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dbdiff.o b/modules/elementary_functions/src/fortran/slatec/.libs/dbdiff.o Binary files differnew file mode 100755 index 000000000..63d641685 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dbdiff.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dbesi.o b/modules/elementary_functions/src/fortran/slatec/.libs/dbesi.o Binary files differnew file mode 100755 index 000000000..b07480970 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dbesi.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dbesi0.o b/modules/elementary_functions/src/fortran/slatec/.libs/dbesi0.o Binary files differnew file mode 100755 index 000000000..0ed867995 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dbesi0.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dbesi1.o b/modules/elementary_functions/src/fortran/slatec/.libs/dbesi1.o Binary files differnew file mode 100755 index 000000000..f2fa05a48 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dbesi1.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dbesj.o b/modules/elementary_functions/src/fortran/slatec/.libs/dbesj.o Binary files differnew file mode 100755 index 000000000..6ad366c93 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dbesj.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dbesj0.o b/modules/elementary_functions/src/fortran/slatec/.libs/dbesj0.o Binary files differnew file mode 100755 index 000000000..691cf23c9 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dbesj0.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dbesj1.o b/modules/elementary_functions/src/fortran/slatec/.libs/dbesj1.o Binary files differnew file mode 100755 index 000000000..bc1c48f3d --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dbesj1.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dbesk.o b/modules/elementary_functions/src/fortran/slatec/.libs/dbesk.o Binary files differnew file mode 100755 index 000000000..76c86cfe7 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dbesk.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dbesk0.o b/modules/elementary_functions/src/fortran/slatec/.libs/dbesk0.o Binary files differnew file mode 100755 index 000000000..b4c49e297 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dbesk0.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dbesk1.o b/modules/elementary_functions/src/fortran/slatec/.libs/dbesk1.o Binary files differnew file mode 100755 index 000000000..44f212e5c --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dbesk1.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dbesy.o b/modules/elementary_functions/src/fortran/slatec/.libs/dbesy.o Binary files differnew file mode 100755 index 000000000..dc8cb7977 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dbesy.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dbesy0.o b/modules/elementary_functions/src/fortran/slatec/.libs/dbesy0.o Binary files differnew file mode 100755 index 000000000..d12e8d37a --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dbesy0.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dbesy1.o b/modules/elementary_functions/src/fortran/slatec/.libs/dbesy1.o Binary files differnew file mode 100755 index 000000000..4b78c5870 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dbesy1.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dbkias.o b/modules/elementary_functions/src/fortran/slatec/.libs/dbkias.o Binary files differnew file mode 100755 index 000000000..9f6d81125 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dbkias.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dbkisr.o b/modules/elementary_functions/src/fortran/slatec/.libs/dbkisr.o Binary files differnew file mode 100755 index 000000000..bb3cee166 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dbkisr.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dbsi0e.o b/modules/elementary_functions/src/fortran/slatec/.libs/dbsi0e.o Binary files differnew file mode 100755 index 000000000..a714f68e2 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dbsi0e.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dbsi1e.o b/modules/elementary_functions/src/fortran/slatec/.libs/dbsi1e.o Binary files differnew file mode 100755 index 000000000..5a7424072 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dbsi1e.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dbsk0e.o b/modules/elementary_functions/src/fortran/slatec/.libs/dbsk0e.o Binary files differnew file mode 100755 index 000000000..a313c0d8e --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dbsk0e.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dbsk1e.o b/modules/elementary_functions/src/fortran/slatec/.libs/dbsk1e.o Binary files differnew file mode 100755 index 000000000..a74e5221f --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dbsk1e.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dbskes.o b/modules/elementary_functions/src/fortran/slatec/.libs/dbskes.o Binary files differnew file mode 100755 index 000000000..e07cad754 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dbskes.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dbskin.o b/modules/elementary_functions/src/fortran/slatec/.libs/dbskin.o Binary files differnew file mode 100755 index 000000000..ba1ac6bde --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dbskin.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dbsknu.o b/modules/elementary_functions/src/fortran/slatec/.libs/dbsknu.o Binary files differnew file mode 100755 index 000000000..8d7927f1e --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dbsknu.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dbsynu.o b/modules/elementary_functions/src/fortran/slatec/.libs/dbsynu.o Binary files differnew file mode 100755 index 000000000..bb265d000 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dbsynu.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dcsevl.o b/modules/elementary_functions/src/fortran/slatec/.libs/dcsevl.o Binary files differnew file mode 100755 index 000000000..2e9a29b21 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dcsevl.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dexint.o b/modules/elementary_functions/src/fortran/slatec/.libs/dexint.o Binary files differnew file mode 100755 index 000000000..07894f740 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dexint.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dgamlm.o b/modules/elementary_functions/src/fortran/slatec/.libs/dgamlm.o Binary files differnew file mode 100755 index 000000000..ff9d0fd71 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dgamlm.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dgamln.o b/modules/elementary_functions/src/fortran/slatec/.libs/dgamln.o Binary files differnew file mode 100755 index 000000000..c36331352 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dgamln.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dgamma.o b/modules/elementary_functions/src/fortran/slatec/.libs/dgamma.o Binary files differnew file mode 100755 index 000000000..313ad7276 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dgamma.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dgamrn.o b/modules/elementary_functions/src/fortran/slatec/.libs/dgamrn.o Binary files differnew file mode 100755 index 000000000..1db96f0f3 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dgamrn.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dhkseq.o b/modules/elementary_functions/src/fortran/slatec/.libs/dhkseq.o Binary files differnew file mode 100755 index 000000000..ca52bbac6 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dhkseq.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/djairy.o b/modules/elementary_functions/src/fortran/slatec/.libs/djairy.o Binary files differnew file mode 100755 index 000000000..80fa75c16 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/djairy.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dlngam.o b/modules/elementary_functions/src/fortran/slatec/.libs/dlngam.o Binary files differnew file mode 100755 index 000000000..d1f706aa5 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dlngam.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dpsixn.o b/modules/elementary_functions/src/fortran/slatec/.libs/dpsixn.o Binary files differnew file mode 100755 index 000000000..fa6f541eb --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dpsixn.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dtensbs.o b/modules/elementary_functions/src/fortran/slatec/.libs/dtensbs.o Binary files differnew file mode 100755 index 000000000..d37f90565 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dtensbs.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dxlegf.o b/modules/elementary_functions/src/fortran/slatec/.libs/dxlegf.o Binary files differnew file mode 100755 index 000000000..a3cda1569 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dxlegf.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/dyairy.o b/modules/elementary_functions/src/fortran/slatec/.libs/dyairy.o Binary files differnew file mode 100755 index 000000000..caf3882d5 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/dyairy.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/fdump.o b/modules/elementary_functions/src/fortran/slatec/.libs/fdump.o Binary files differnew file mode 100755 index 000000000..60390d773 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/fdump.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/gamma.o b/modules/elementary_functions/src/fortran/slatec/.libs/gamma.o Binary files differnew file mode 100755 index 000000000..a6198ad48 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/gamma.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/initds.o b/modules/elementary_functions/src/fortran/slatec/.libs/initds.o Binary files differnew file mode 100755 index 000000000..5beee0fb7 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/initds.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/j4save.o b/modules/elementary_functions/src/fortran/slatec/.libs/j4save.o Binary files differnew file mode 100755 index 000000000..b6974ac57 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/j4save.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/pchim.o b/modules/elementary_functions/src/fortran/slatec/.libs/pchim.o Binary files differnew file mode 100755 index 000000000..2b2da1e5f --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/pchim.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/xercnt.o b/modules/elementary_functions/src/fortran/slatec/.libs/xercnt.o Binary files differnew file mode 100755 index 000000000..d340c24e9 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/xercnt.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/xermsg.o b/modules/elementary_functions/src/fortran/slatec/.libs/xermsg.o Binary files differnew file mode 100755 index 000000000..042cc7349 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/xermsg.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/xerprn.o b/modules/elementary_functions/src/fortran/slatec/.libs/xerprn.o Binary files differnew file mode 100755 index 000000000..6a222e97c --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/xerprn.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/xersve.o b/modules/elementary_functions/src/fortran/slatec/.libs/xersve.o Binary files differnew file mode 100755 index 000000000..4a209c30e --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/xersve.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/xgetua.o b/modules/elementary_functions/src/fortran/slatec/.libs/xgetua.o Binary files differnew file mode 100755 index 000000000..56d59c22e --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/xgetua.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zabs.o b/modules/elementary_functions/src/fortran/slatec/.libs/zabs.o Binary files differnew file mode 100755 index 000000000..3dca450e0 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zabs.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zacai.o b/modules/elementary_functions/src/fortran/slatec/.libs/zacai.o Binary files differnew file mode 100755 index 000000000..688fe911b --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zacai.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zacon.o b/modules/elementary_functions/src/fortran/slatec/.libs/zacon.o Binary files differnew file mode 100755 index 000000000..c4a73ceb9 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zacon.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zairy.o b/modules/elementary_functions/src/fortran/slatec/.libs/zairy.o Binary files differnew file mode 100755 index 000000000..d1468f2bd --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zairy.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zasyi.o b/modules/elementary_functions/src/fortran/slatec/.libs/zasyi.o Binary files differnew file mode 100755 index 000000000..8f87434ba --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zasyi.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zbesh.o b/modules/elementary_functions/src/fortran/slatec/.libs/zbesh.o Binary files differnew file mode 100755 index 000000000..dc9130a83 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zbesh.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zbesi.o b/modules/elementary_functions/src/fortran/slatec/.libs/zbesi.o Binary files differnew file mode 100755 index 000000000..3c34698aa --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zbesi.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zbesj.o b/modules/elementary_functions/src/fortran/slatec/.libs/zbesj.o Binary files differnew file mode 100755 index 000000000..c1de07715 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zbesj.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zbesk.o b/modules/elementary_functions/src/fortran/slatec/.libs/zbesk.o Binary files differnew file mode 100755 index 000000000..cb7408db3 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zbesk.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zbesy.o b/modules/elementary_functions/src/fortran/slatec/.libs/zbesy.o Binary files differnew file mode 100755 index 000000000..a8aa46d10 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zbesy.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zbinu.o b/modules/elementary_functions/src/fortran/slatec/.libs/zbinu.o Binary files differnew file mode 100755 index 000000000..6361b5c32 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zbinu.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zbknu.o b/modules/elementary_functions/src/fortran/slatec/.libs/zbknu.o Binary files differnew file mode 100755 index 000000000..4b31a5fa6 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zbknu.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zbuni.o b/modules/elementary_functions/src/fortran/slatec/.libs/zbuni.o Binary files differnew file mode 100755 index 000000000..dc7316dde --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zbuni.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zbunk.o b/modules/elementary_functions/src/fortran/slatec/.libs/zbunk.o Binary files differnew file mode 100755 index 000000000..303259aa9 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zbunk.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zdiv.o b/modules/elementary_functions/src/fortran/slatec/.libs/zdiv.o Binary files differnew file mode 100755 index 000000000..920f9ba9c --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zdiv.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zexp.o b/modules/elementary_functions/src/fortran/slatec/.libs/zexp.o Binary files differnew file mode 100755 index 000000000..0ba30076f --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zexp.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zkscl.o b/modules/elementary_functions/src/fortran/slatec/.libs/zkscl.o Binary files differnew file mode 100755 index 000000000..a2d8475fa --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zkscl.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zlog.o b/modules/elementary_functions/src/fortran/slatec/.libs/zlog.o Binary files differnew file mode 100755 index 000000000..60e02aa91 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zlog.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zmlri.o b/modules/elementary_functions/src/fortran/slatec/.libs/zmlri.o Binary files differnew file mode 100755 index 000000000..23002cba7 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zmlri.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zmlt.o b/modules/elementary_functions/src/fortran/slatec/.libs/zmlt.o Binary files differnew file mode 100755 index 000000000..b36e19a93 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zmlt.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zrati.o b/modules/elementary_functions/src/fortran/slatec/.libs/zrati.o Binary files differnew file mode 100755 index 000000000..d94a196ec --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zrati.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zs1s2.o b/modules/elementary_functions/src/fortran/slatec/.libs/zs1s2.o Binary files differnew file mode 100755 index 000000000..0caf90e18 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zs1s2.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zseri.o b/modules/elementary_functions/src/fortran/slatec/.libs/zseri.o Binary files differnew file mode 100755 index 000000000..19f512b32 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zseri.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zshch.o b/modules/elementary_functions/src/fortran/slatec/.libs/zshch.o Binary files differnew file mode 100755 index 000000000..f7522fb2a --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zshch.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zsqrt.o b/modules/elementary_functions/src/fortran/slatec/.libs/zsqrt.o Binary files differnew file mode 100755 index 000000000..2576bf6f9 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zsqrt.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zuchk.o b/modules/elementary_functions/src/fortran/slatec/.libs/zuchk.o Binary files differnew file mode 100755 index 000000000..78ccde775 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zuchk.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zunhj.o b/modules/elementary_functions/src/fortran/slatec/.libs/zunhj.o Binary files differnew file mode 100755 index 000000000..f4fe0e815 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zunhj.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zuni1.o b/modules/elementary_functions/src/fortran/slatec/.libs/zuni1.o Binary files differnew file mode 100755 index 000000000..8cf751da0 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zuni1.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zuni2.o b/modules/elementary_functions/src/fortran/slatec/.libs/zuni2.o Binary files differnew file mode 100755 index 000000000..cd6176a6d --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zuni2.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zunik.o b/modules/elementary_functions/src/fortran/slatec/.libs/zunik.o Binary files differnew file mode 100755 index 000000000..0be6792ee --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zunik.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zunk1.o b/modules/elementary_functions/src/fortran/slatec/.libs/zunk1.o Binary files differnew file mode 100755 index 000000000..38f7122a2 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zunk1.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zunk2.o b/modules/elementary_functions/src/fortran/slatec/.libs/zunk2.o Binary files differnew file mode 100755 index 000000000..898a273d6 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zunk2.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zuoik.o b/modules/elementary_functions/src/fortran/slatec/.libs/zuoik.o Binary files differnew file mode 100755 index 000000000..5fbc74889 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zuoik.o diff --git a/modules/elementary_functions/src/fortran/slatec/.libs/zwrsk.o b/modules/elementary_functions/src/fortran/slatec/.libs/zwrsk.o Binary files differnew file mode 100755 index 000000000..0e78ed633 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/.libs/zwrsk.o diff --git a/modules/elementary_functions/src/fortran/slatec/Elementary_functions_Import.def b/modules/elementary_functions/src/fortran/slatec/Elementary_functions_Import.def new file mode 100755 index 000000000..629c35582 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/Elementary_functions_Import.def @@ -0,0 +1,9 @@ + LIBRARY elementary_functions.dll + + +EXPORTS +; +;elementary_functions +xerhlt_ +; +
\ No newline at end of file diff --git a/modules/elementary_functions/src/fortran/slatec/Elementary_functions_f_Import.def b/modules/elementary_functions/src/fortran/slatec/Elementary_functions_f_Import.def new file mode 100755 index 000000000..ab60f1e3f --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/Elementary_functions_f_Import.def @@ -0,0 +1,8 @@ + LIBRARY elementary_functions_f.dll + + +EXPORTS +; +;elementary_functions_f +i1mach_ +d1mach_ diff --git a/modules/elementary_functions/src/fortran/slatec/Output_stream_Import.def b/modules/elementary_functions/src/fortran/slatec/Output_stream_Import.def new file mode 100755 index 000000000..c4cf0de37 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/Output_stream_Import.def @@ -0,0 +1,9 @@ + LIBRARY output_stream.dll + + +EXPORTS +; +;output_stream +basout_ +; +
\ No newline at end of file diff --git a/modules/elementary_functions/src/fortran/slatec/balanc.f b/modules/elementary_functions/src/fortran/slatec/balanc.f new file mode 100755 index 000000000..cee889a6f --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/balanc.f @@ -0,0 +1,174 @@ + subroutine balanc(nm,n,a,low,igh,scale) +c + integer i,j,k,l,m,n,jj,nm,igh,low,iexc + double precision a(nm,n),scale(n) + double precision c,f,g,r,s,b2,radix + logical noconv +c! purpose +c +c this subroutine balances a real matrix and isolates +c eigenvalues whenever possible. +c! calling sequence +c +c subroutine balanc(nm,n,a,low,igh,scale) +c +c +c on input: +c +c nm must be set to the row dimension of two-dimensional +c array parameters as declared in the calling program +c dimension statement; +c +c n is the order of the matrix; +c +c a contains the input matrix to be balanced. +c +c on output: +c +c a contains the balanced matrix; +c +c low and igh are two integers such that a(i,j) +c is equal to zero if +c (1) i is greater than j and +c (2) j=1,...,low-1 or i=igh+1,...,n; +c +c scale contains information determining the +c permutations and scaling factors used. +c +c suppose that the principal submatrix in rows low through igh +c has been balanced, that p(j) denotes the index interchanged +c with j during the permutation step, and that the elements +c of the diagonal matrix used are denoted by d(i,j). then +c scale(j) = p(j), for j = 1,...,low-1 +c = d(j,j), j = low,...,igh +c = p(j) j = igh+1,...,n. +c the order in which the interchanges are made is n to igh+1, +c then 1 to low-1. +c +c note that 1 is returned for igh if igh is zero formally. +c +c the algol procedure exc contained in balance appears in +c balanc in line. (note that the algol roles of identifiers +c k,l have been reversed.) +c +c! originator +c +c this subroutine is a translation of the algol procedure balance, +c num. math. 13, 293-304(1969) by parlett and reinsch. +c handbook for auto. comp., vol.ii-linear algebra, 315-326(1971). +c! +c questions and comments should be directed to b. s. garbow, +c applied mathematics division, argonne national laboratory +c +c ------------------------------------------------------------------ +c +c :::::::::: radix is a machine dependent parameter specifying +c the base of the machine floating point representation. + data radix/2.0d+0/ +c + b2 = radix * radix + k = 1 + l = n + go to 100 +c :::::::::: in-line procedure for row and +c column exchange :::::::::: + 20 scale(m) = j + if (j .eq. m) go to 50 +c + do 30 i = 1, l + f = a(i,j) + a(i,j) = a(i,m) + a(i,m) = f + 30 continue +c + do 40 i = k, n + f = a(j,i) + a(j,i) = a(m,i) + a(m,i) = f + 40 continue +c + 50 go to (80,130), iexc +c :::::::::: search for rows isolating an eigenvalue +c and push them down :::::::::: + 80 if (l .eq. 1) go to 280 + l = l - 1 +c :::::::::: for j=l step -1 until 1 do -- :::::::::: + 100 do 120 jj = 1, l + j = l + 1 - jj +c + do 110 i = 1, l + if (i .eq. j) go to 110 + if (a(j,i) .ne. 0.0d+0) go to 120 + 110 continue +c + m = l + iexc = 1 + go to 20 + 120 continue +c + go to 140 +c :::::::::: search for columns isolating an eigenvalue +c and push them left :::::::::: + 130 k = k + 1 +c + 140 do 170 j = k, l +c + do 150 i = k, l + if (i .eq. j) go to 150 + if (a(i,j) .ne. 0.0d+0) go to 170 + 150 continue +c + m = k + iexc = 2 + go to 20 + 170 continue +c :::::::::: now balance the submatrix in rows k to l :::::::::: + do 180 i = k, l + 180 scale(i) = 1.0d+0 +c :::::::::: iterative loop for norm reduction :::::::::: + 190 noconv = .false. +c + do 270 i = k, l + c = 0.0d+0 + r = 0.0d+0 +c + do 200 j = k, l + if (j .eq. i) go to 200 + c = c + abs(a(j,i)) + r = r + abs(a(i,j)) + 200 continue +c :::::::::: guard against zero c or r due to underflow :::::::::: + if (c .eq. 0.0d+0 .or. r .eq. 0.0d+0) go to 270 + g = r / radix + f = 1.0d+0 + s = c + r + 210 if (c .ge. g) go to 220 + f = f * radix + c = c * b2 + go to 210 + 220 g = r * radix + 230 if (c .lt. g) go to 240 + f = f / radix + c = c / b2 + go to 230 +c :::::::::: now balance :::::::::: + 240 if ((c + r) / f .ge. 0.950d+0 * s) go to 270 + g = 1.0d+0 / f + scale(i) = scale(i) * f + noconv = .true. +c + do 250 j = k, n + 250 a(i,j) = a(i,j) * g +c + do 260 j = 1, l + 260 a(j,i) = a(j,i) * f +c + 270 continue +c + if (noconv) go to 190 +c + 280 low = k + igh = l + return +c :::::::::: last card of balanc :::::::::: + end diff --git a/modules/elementary_functions/src/fortran/slatec/balanc.lo b/modules/elementary_functions/src/fortran/slatec/balanc.lo new file mode 100755 index 000000000..8f2c330bb --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/balanc.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/balanc.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/balanc.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/common_f2c.c b/modules/elementary_functions/src/fortran/slatec/common_f2c.c new file mode 100755 index 000000000..bfbb2992f --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/common_f2c.c @@ -0,0 +1,36 @@ +/* +* Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +* Copyright (C) 2010 - DIGITEO - Allan CORNET +* +* This file must be used under the terms of the CeCILL. +* This source file is licensed as described in the file COPYING, which +* you should have received as part of this distribution. The terms +* are also available at +* http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +* +*/ + +/* ONLY used by F2C with scilab_f2c.sln on Windows */ +/* this modification removes some warning about no defined or redefined COMMON */ +/* We force definition of COMMON only used in current dynamic library */ +/*--------------------------------------------------------------------------*/ +/* see fortran code for definition of these COMMONs */ + +#ifdef _MSC_VER +struct +{ + long int nbitsf; +} dxblk1_; + +struct +{ + double radix, radixl, rad2l, dlg10r; + long int l, l2, kmax; +} dxblk2_; + +struct +{ + long int nlg102, mlg102, lg102[21]; +} dxblk3_; +#endif +/*--------------------------------------------------------------------------*/ diff --git a/modules/elementary_functions/src/fortran/slatec/core_Import.def b/modules/elementary_functions/src/fortran/slatec/core_Import.def new file mode 100755 index 000000000..f5a3e4220 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/core_Import.def @@ -0,0 +1,18 @@ + LIBRARY core.dll + + +EXPORTS +; +;core +iop_ +stack_ +vstk_ +recu_ +errgst_ +com_ +cha1_ +adre_ +intersci_ +returnananfortran_ +; +
\ No newline at end of file diff --git a/modules/elementary_functions/src/fortran/slatec/d9b0mp.f b/modules/elementary_functions/src/fortran/slatec/d9b0mp.f new file mode 100755 index 000000000..e3a3246b6 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/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/modules/elementary_functions/src/fortran/slatec/d9b0mp.lo b/modules/elementary_functions/src/fortran/slatec/d9b0mp.lo new file mode 100755 index 000000000..23951406c --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/d9b0mp.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/d9b0mp.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/d9b0mp.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/d9b1mp.f b/modules/elementary_functions/src/fortran/slatec/d9b1mp.f new file mode 100755 index 000000000..1b87c7f51 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/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/modules/elementary_functions/src/fortran/slatec/d9b1mp.lo b/modules/elementary_functions/src/fortran/slatec/d9b1mp.lo new file mode 100755 index 000000000..e45516890 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/d9b1mp.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/d9b1mp.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/d9b1mp.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/d9knus.f b/modules/elementary_functions/src/fortran/slatec/d9knus.f new file mode 100755 index 000000000..8758849d4 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/d9knus.f @@ -0,0 +1,252 @@ +*DECK D9KNUS + SUBROUTINE D9KNUS (XNU, X, BKNU, BKNU1, ISWTCH) +C***BEGIN PROLOGUE D9KNUS +C***SUBSIDIARY +C***PURPOSE Compute Bessel functions EXP(X)*K-SUB-XNU(X) and EXP(X)* +C K-SUB-XNU+1(X) for 0.0 .LE. XNU .LT. 1.0. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C10B3 +C***TYPE DOUBLE PRECISION (R9KNUS-S, D9KNUS-D) +C***KEYWORDS BESSEL FUNCTION, FNLIB, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C Compute Bessel functions EXP(X) * K-sub-XNU (X) and +C EXP(X) * K-sub-XNU+1 (X) for 0.0 .LE. XNU .LT. 1.0 . +C +C Series for C0K on the interval 0. to 2.50000E-01 +C with weighted error 2.16E-32 +C log weighted error 31.67 +C significant figures required 30.86 +C decimal places required 32.40 +C +C Series for ZNU1 on the interval -7.00000E-01 to 0. +C with weighted error 2.45E-33 +C log weighted error 32.61 +C significant figures required 31.85 +C decimal places required 33.26 +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, DCSEVL, DGAMMA, INITDS, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770601 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 900720 Routine changed from user-callable to subsidiary. (WRB) +C 900727 Added EXTERNAL statement. (WRB) +C 920618 Removed space from variable names. (RWC, WRB) +C***END PROLOGUE D9KNUS + DOUBLE PRECISION XNU, X, BKNU, BKNU1, ALPHA(32), BETA(32), A(32), + 1 C0KCS(29), ZNU1CS(20), ALNZ, ALN2, A0, BKNUD, BKNU0, + 2 B0, C0, EULER, EXPX, P1, P2, P3, QQ, RESULT, SQPI2, SQRTX, V, + 3 VLNZ, XI, XMU, XNUSML, XSML, X2N, X2TOV, Z, ZTOV, ALNSML, + 4 ALNBIG + REAL ALNEPS + DOUBLE PRECISION D1MACH, DCSEVL, DGAMMA + LOGICAL FIRST + EXTERNAL DGAMMA + SAVE C0KCS, ZNU1CS, EULER, SQPI2, ALN2, NTC0K, + 1 NTZNU1, XNUSML, XSML, ALNSML, ALNBIG, ALNEPS, FIRST + DATA C0KCS( 1) / +.6018305724 2626108387 5774451803 29 D-1 / + DATA C0KCS( 2) / -.1536487143 3017286092 9597559431 24 D+0 / + DATA C0KCS( 3) / -.1175117600 8210492040 0682292262 13 D-1 / + DATA C0KCS( 4) / -.8524878889 1979509827 0484015509 87 D-3 / + DATA C0KCS( 5) / -.6132983876 7496791874 0981769221 11 D-4 / + DATA C0KCS( 6) / -.4405228124 5510444562 6798895485 05 D-5 / + DATA C0KCS( 7) / -.3163124672 8384488192 9154458921 99 D-6 / + DATA C0KCS( 8) / -.2271071938 2899588330 6737717933 96 D-7 / + DATA C0KCS( 9) / -.1630564460 8077609552 2746205153 60 D-8 / + DATA C0KCS( 10) / -.1170693929 9414776568 7560440431 30 D-9 / + DATA C0KCS( 11) / -.8405206378 6464437174 5465934137 92 D-11 / + DATA C0KCS( 12) / -.6034667011 8979991487 0960507371 98 D-12 / + DATA C0KCS( 13) / -.4332696033 5681371952 0459973669 03 D-13 / + DATA C0KCS( 14) / -.3110735803 0203546214 6346977722 37 D-14 / + DATA C0KCS( 15) / -.2233407822 6736982254 4861334098 40 D-15 / + DATA C0KCS( 16) / -.1603514671 6864226300 6357915286 10 D-16 / + DATA C0KCS( 17) / -.1151271736 3666556196 0356977053 05 D-17 / + DATA C0KCS( 18) / -.8265759174 6836959105 1694790892 58 D-19 / + DATA C0KCS( 19) / -.5934548080 6383948172 3334366959 84 D-20 / + DATA C0KCS( 20) / -.4260813819 6467143926 4996130239 76 D-21 / + DATA C0KCS( 21) / -.3059126686 4812876299 2636983705 42 D-22 / + DATA C0KCS( 22) / -.2196354142 6734575224 9755018155 16 D-23 / + DATA C0KCS( 23) / -.1576911326 1495836071 1057506847 60 D-24 / + DATA C0KCS( 24) / -.1132171393 5950320948 7577310480 56 D-25 / + DATA C0KCS( 25) / -.8128624883 4598404082 7923497144 33 D-27 / + DATA C0KCS( 26) / -.5836090089 3453226552 8293493159 49 D-28 / + DATA C0KCS( 27) / -.4190124162 3610922519 4523377809 05 D-29 / + DATA C0KCS( 28) / -.3008373796 0206435069 5305042128 62 D-30 / + DATA C0KCS( 29) / -.2159915206 7808647728 3421680898 32 D-31 / + DATA ZNU1CS( 1) / +.2033067569 9419172967 4444001216 911 D+0 / + DATA ZNU1CS( 2) / +.1400779334 1321977106 2943670790 563 D+0 / + DATA ZNU1CS( 3) / +.7916796961 0016135284 0972241972 320 D-2 / + DATA ZNU1CS( 4) / +.3398011825 3210404535 2930092205 750 D-3 / + DATA ZNU1CS( 5) / +.1174197568 8989336666 4507228352 690 D-4 / + DATA ZNU1CS( 6) / +.3393575706 1226168033 3825865475 121 D-6 / + DATA ZNU1CS( 7) / +.8425941769 7621991019 4629891264 803 D-8 / + DATA ZNU1CS( 8) / +.1833366770 2485008918 4748150900 090 D-9 / + DATA ZNU1CS( 9) / +.3549698447 0441631086 3007064469 557 D-11 / + DATA ZNU1CS( 10) / +.6190324964 6988733220 5244342078 407 D-13 / + DATA ZNU1CS( 11) / +.9819645356 8043942496 0346115456 527 D-15 / + DATA ZNU1CS( 12) / +.1428513143 9649047421 1473563005 985 D-16 / + DATA ZNU1CS( 13) / +.1918949218 8782529896 6162467488 436 D-18 / + DATA ZNU1CS( 14) / +.2394309797 3949891416 2313140597 128 D-20 / + DATA ZNU1CS( 15) / +.2788902468 1534735483 5870465474 995 D-22 / + DATA ZNU1CS( 16) / +.3046066506 3303344258 2845214092 865 D-24 / + DATA ZNU1CS( 17) / +.3131732370 4219181577 1564260932 089 D-26 / + DATA ZNU1CS( 18) / +.3041330989 8785495164 5174908005 034 D-28 / + DATA ZNU1CS( 19) / +.2798403846 3683308434 3185097659 733 D-30 / + DATA ZNU1CS( 20) / +.2446371862 7449759648 5238794922 666 D-32 / + DATA EULER / 0.5772156649 0153286060 6512090082 40D0 / + DATA SQPI2 / +1.253314137 3155002512 0788264240 55 D0 / + DATA ALN2 / 0.6931471805 5994530941 7232121458 18D0 / + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT D9KNUS + IF (FIRST) THEN + ETA = 0.1D0*D1MACH(3) + NTC0K = INITDS (C0KCS, 29, ETA) + NTZNU1 = INITDS (ZNU1CS, 20, ETA) +C + XNUSML = SQRT(D1MACH(3)/8.D0) + XSML = 0.1D0*D1MACH(3) + ALNSML = LOG (D1MACH(1)) + ALNBIG = LOG (D1MACH(2)) + ALNEPS = LOG (0.1D0*D1MACH(3)) + ENDIF + FIRST = .FALSE. +C + IF (XNU .LT. 0.D0 .OR. XNU .GE. 1.D0) CALL XERMSG ('SLATEC', + + 'D9KNUS', 'XNU MUST BE GE 0 AND LT 1', 1, 2) + IF (X .LE. 0.) CALL XERMSG ('SLATEC', 'D9KNUS', 'X MUST BE GT 0', + + 2, 2) +C + ISWTCH = 0 + IF (X.GT.2.0D0) GO TO 50 +C +C X IS SMALL. COMPUTE K-SUB-XNU (X) AND THE DERIVATIVE OF K-SUB-XNU (X) +C THEN FIND K-SUB-XNU+1 (X). XNU IS REDUCED TO THE INTERVAL (-.5,+.5) +C THEN TO (0., .5), BECAUSE K OF NEGATIVE ORDER (-NU) = K OF POSITIVE +C ORDER (+NU). +C + V = XNU + IF (XNU.GT.0.5D0) V = 1.0D0 - XNU +C +C CAREFULLY FIND (X/2)**XNU AND Z**XNU WHERE Z = X*X/4. + ALNZ = 2.D0 * (LOG(X) - ALN2) +C + IF (X.GT.XNU) GO TO 20 + IF (-0.5D0*XNU*ALNZ-ALN2-LOG(XNU) .GT. ALNBIG) CALL XERMSG + + ('SLATEC', 'D9KNUS', 'X SO SMALL BESSEL K-SUB-XNU OVERFLOWS', + + 3, 2) +C + 20 VLNZ = V*ALNZ + X2TOV = EXP (0.5D0*VLNZ) + ZTOV = 0.0D0 + IF (VLNZ.GT.ALNSML) ZTOV = X2TOV**2 +C + A0 = 0.5D0*DGAMMA(1.0D0+V) + B0 = 0.5D0*DGAMMA(1.0D0-V) + C0 = -EULER + IF (ZTOV.GT.0.5D0 .AND. V.GT.XNUSML) C0 = -0.75D0 + + 1 DCSEVL ((8.0D0*V)*V-1.0D0, C0KCS, NTC0K) +C + IF (ZTOV.LE.0.5D0) ALPHA(1) = (A0-ZTOV*B0)/V + IF (ZTOV.GT.0.5D0) ALPHA(1) = C0 - ALNZ*(0.75D0 + + 1 DCSEVL (VLNZ/0.35D0+1.0D0, ZNU1CS, NTZNU1))*B0 + BETA(1) = -0.5D0*(A0+ZTOV*B0) +C + Z = 0.0D0 + IF (X.GT.XSML) Z = 0.25D0*X*X + NTERMS = MAX (2.0, 11.0+(8.*REAL(ALNZ)-25.19-ALNEPS) + 1 /(4.28-REAL(ALNZ))) + DO 30 I=2,NTERMS + XI = I - 1 + A0 = A0/(XI*(XI-V)) + B0 = B0/(XI*(XI+V)) + ALPHA(I) = (ALPHA(I-1)+2.0D0*XI*A0)/(XI*(XI+V)) + BETA(I) = (XI-0.5D0*V)*ALPHA(I) - ZTOV*B0 + 30 CONTINUE +C + BKNU = ALPHA(NTERMS) + BKNUD = BETA(NTERMS) + DO 40 II=2,NTERMS + I = NTERMS + 1 - II + BKNU = ALPHA(I) + BKNU*Z + BKNUD = BETA(I) + BKNUD*Z + 40 CONTINUE +C + EXPX = EXP(X) + BKNU = EXPX*BKNU/X2TOV +C + IF (-0.5D0*(XNU+1.D0)*ALNZ-2.0D0*ALN2.GT.ALNBIG) ISWTCH = 1 + IF (ISWTCH.EQ.1) RETURN + BKNUD = EXPX*BKNUD*2.0D0/(X2TOV*X) +C + IF (XNU.LE.0.5D0) BKNU1 = V*BKNU/X - BKNUD + IF (XNU.LE.0.5D0) RETURN +C + BKNU0 = BKNU + BKNU = -V*BKNU/X - BKNUD + BKNU1 = 2.0D0*XNU*BKNU/X + BKNU0 + RETURN +C +C X IS LARGE. FIND K-SUB-XNU (X) AND K-SUB-XNU+1 (X) WITH Y. L. LUKE-S +C RATIONAL EXPANSION. +C + 50 SQRTX = SQRT(X) + IF (X.GT.1.0D0/XSML) GO TO 90 + AN = -0.60 - 1.02/REAL(X) + BN = -0.27 - 0.53/REAL(X) + NTERMS = MIN (32, MAX1 (3.0, AN+BN*ALNEPS)) +C + DO 80 INU=1,2 + XMU = 0.D0 + IF (INU.EQ.1 .AND. XNU.GT.XNUSML) XMU = (4.0D0*XNU)*XNU + IF (INU.EQ.2) XMU = 4.0D0*(ABS(XNU)+1.D0)**2 +C + A(1) = 1.0D0 - XMU + A(2) = 9.0D0 - XMU + A(3) = 25.0D0 - XMU + IF (A(2).EQ.0.D0) RESULT = SQPI2*(16.D0*X+XMU+7.D0) / + 1 (16.D0*X*SQRTX) + IF (A(2).EQ.0.D0) GO TO 70 +C + ALPHA(1) = 1.0D0 + ALPHA(2) = (16.D0*X+A(2))/A(2) + ALPHA(3) = ((768.D0*X+48.D0*A(3))*X + A(2)*A(3))/(A(2)*A(3)) +C + BETA(1) = 1.0D0 + BETA(2) = (16.D0*X+(XMU+7.D0))/A(2) + BETA(3) = ((768.D0*X+48.D0*(XMU+23.D0))*X + + 1 ((XMU+62.D0)*XMU+129.D0))/(A(2)*A(3)) +C + IF (NTERMS.LT.4) GO TO 65 + DO 60 I=4,NTERMS + N = I - 1 + X2N = 2*N - 1 +C + A(I) = (X2N+2.D0)**2 - XMU + QQ = 16.D0*X2N/A(I) + P1 = -X2N*((12*N*N-20*N)-A(1))/((X2N-2.D0)*A(I)) + 1 - QQ*X + P2 = ((12*N*N-28*N+8)-A(1))/A(I) - QQ*X + P3 = -X2N*A(I-3)/((X2N-2.D0)*A(I)) +C + ALPHA(I) = -P1*ALPHA(I-1) - P2*ALPHA(I-2) - P3*ALPHA(I-3) + BETA(I) = -P1*BETA(I-1) - P2*BETA(I-2) - P3*BETA(I-3) + 60 CONTINUE +C + 65 RESULT = SQPI2*BETA(NTERMS)/(SQRTX*ALPHA(NTERMS)) +C + 70 IF (INU.EQ.1) BKNU = RESULT + IF (INU.EQ.2) BKNU1 = RESULT + 80 CONTINUE + RETURN +C + 90 BKNU = SQPI2/SQRTX + BKNU1 = BKNU + RETURN +C + END diff --git a/modules/elementary_functions/src/fortran/slatec/d9knus.lo b/modules/elementary_functions/src/fortran/slatec/d9knus.lo new file mode 100755 index 000000000..6571fd7c6 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/d9knus.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/d9knus.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/d9knus.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/d9lgmc.f b/modules/elementary_functions/src/fortran/slatec/d9lgmc.f new file mode 100755 index 000000000..0b4b32719 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/d9lgmc.f @@ -0,0 +1,76 @@ +*DECK D9LGMC + DOUBLE PRECISION FUNCTION D9LGMC (X) +C***BEGIN PROLOGUE D9LGMC +C***SUBSIDIARY +C***PURPOSE Compute the log Gamma correction factor so that +C LOG(DGAMMA(X)) = LOG(SQRT(2*PI)) + (X-5.)*LOG(X) - X +C + D9LGMC(X). +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C7E +C***TYPE DOUBLE PRECISION (R9LGMC-S, D9LGMC-D, C9LGMC-C) +C***KEYWORDS COMPLETE GAMMA FUNCTION, CORRECTION TERM, FNLIB, +C LOG GAMMA, LOGARITHM, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C Compute the log gamma correction factor for X .GE. 10. so that +C LOG (DGAMMA(X)) = LOG(SQRT(2*PI)) + (X-.5)*LOG(X) - X + D9lGMC(X) +C +C Series for ALGM on the interval 0. to 1.00000E-02 +C with weighted error 1.28E-31 +C log weighted error 30.89 +C significant figures required 29.81 +C decimal places required 31.48 +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770601 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***END PROLOGUE D9LGMC + DOUBLE PRECISION X, ALGMCS(15), XBIG, XMAX, DCSEVL, D1MACH + LOGICAL FIRST + SAVE ALGMCS, NALGM, XBIG, XMAX, FIRST + DATA ALGMCS( 1) / +.1666389480 4518632472 0572965082 2 D+0 / + DATA ALGMCS( 2) / -.1384948176 0675638407 3298605913 5 D-4 / + DATA ALGMCS( 3) / +.9810825646 9247294261 5717154748 7 D-8 / + DATA ALGMCS( 4) / -.1809129475 5724941942 6330626671 9 D-10 / + DATA ALGMCS( 5) / +.6221098041 8926052271 2601554341 6 D-13 / + DATA ALGMCS( 6) / -.3399615005 4177219443 0333059966 6 D-15 / + DATA ALGMCS( 7) / +.2683181998 4826987489 5753884666 6 D-17 / + DATA ALGMCS( 8) / -.2868042435 3346432841 4462239999 9 D-19 / + DATA ALGMCS( 9) / +.3962837061 0464348036 7930666666 6 D-21 / + DATA ALGMCS( 10) / -.6831888753 9857668701 1199999999 9 D-23 / + DATA ALGMCS( 11) / +.1429227355 9424981475 7333333333 3 D-24 / + DATA ALGMCS( 12) / -.3547598158 1010705471 9999999999 9 D-26 / + DATA ALGMCS( 13) / +.1025680058 0104709120 0000000000 0 D-27 / + DATA ALGMCS( 14) / -.3401102254 3167487999 9999999999 9 D-29 / + DATA ALGMCS( 15) / +.1276642195 6300629333 3333333333 3 D-30 / + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT D9LGMC + IF (FIRST) THEN + NALGM = INITDS (ALGMCS, 15, REAL(D1MACH(3)) ) + XBIG = 1.0D0/SQRT(D1MACH(3)) + XMAX = EXP (MIN(LOG(D1MACH(2)/12.D0), -LOG(12.D0*D1MACH(1)))) + ENDIF + FIRST = .FALSE. +C + IF (X .LT. 10.D0) CALL XERMSG ('SLATEC', 'D9LGMC', + + 'X MUST BE GE 10', 1, 2) + IF (X.GE.XMAX) GO TO 20 +C + D9LGMC = 1.D0/(12.D0*X) + IF (X.LT.XBIG) D9LGMC = DCSEVL (2.0D0*(10.D0/X)**2-1.D0, ALGMCS, + 1 NALGM) / X + RETURN +C + 20 D9LGMC = 0.D0 + CALL XERMSG ('SLATEC', 'D9LGMC', 'X SO BIG D9LGMC UNDERFLOWS', 2, + + 1) + RETURN +C + END diff --git a/modules/elementary_functions/src/fortran/slatec/d9lgmc.lo b/modules/elementary_functions/src/fortran/slatec/d9lgmc.lo new file mode 100755 index 000000000..1e566625d --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/d9lgmc.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/d9lgmc.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/d9lgmc.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dasyik.f b/modules/elementary_functions/src/fortran/slatec/dasyik.f new file mode 100755 index 000000000..a999e26dd --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dasyik.f @@ -0,0 +1,145 @@ +*DECK DASYIK + SUBROUTINE DASYIK (X, FNU, KODE, FLGIK, RA, ARG, IN, Y) +C***BEGIN PROLOGUE DASYIK +C***SUBSIDIARY +C***PURPOSE Subsidiary to DBESI and DBESK +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (ASYIK-S, DASYIK-D) +C***AUTHOR Amos, D. E., (SNLA) +C***DESCRIPTION +C +C DASYIK computes Bessel functions I and K +C for arguments X.GT.0.0 and orders FNU.GE.35 +C on FLGIK = 1 and FLGIK = -1 respectively. +C +C INPUT +C +C X - Argument, X.GT.0.0D0 +C FNU - Order of first Bessel function +C KODE - A parameter to indicate the scaling option +C KODE=1 returns Y(I)= I/SUB(FNU+I-1)/(X), I=1,IN +C or Y(I)= K/SUB(FNU+I-1)/(X), I=1,IN +C on FLGIK = 1.0D0 or FLGIK = -1.0D0 +C KODE=2 returns Y(I)=EXP(-X)*I/SUB(FNU+I-1)/(X), I=1,IN +C or Y(I)=EXP( X)*K/SUB(FNU+I-1)/(X), I=1,IN +C on FLGIK = 1.0D0 or FLGIK = -1.0D0 +C FLGIK - Selection parameter for I or K FUNCTION +C FLGIK = 1.0D0 gives the I function +C FLGIK = -1.0D0 gives the K function +C RA - SQRT(1.+Z*Z), Z=X/FNU +C ARG - Argument of the leading exponential +C IN - Number of functions desired, IN=1 or 2 +C +C OUTPUT +C +C Y - A vector whose first IN components contain the sequence +C +C Abstract **** A double precision routine **** +C DASYIK implements the uniform asymptotic expansion of +C the I and K Bessel functions for FNU.GE.35 and real +C X.GT.0.0D0. The forms are identical except for a change +C in sign of some of the terms. This change in sign is +C accomplished by means of the FLAG FLGIK = 1 or -1. +C +C***SEE ALSO DBESI, DBESK +C***ROUTINES CALLED D1MACH +C***REVISION HISTORY (YYMMDD) +C 750101 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890911 Removed unnecessary intrinsics. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 910408 Updated the AUTHOR section. (WRB) +C***END PROLOGUE DASYIK +C + INTEGER IN, J, JN, K, KK, KODE, L + DOUBLE PRECISION AK,AP,ARG,C,COEF,CON,ETX,FLGIK,FN,FNU,GLN,RA, + 1 S1, S2, T, TOL, T2, X, Y, Z + DOUBLE PRECISION D1MACH + DIMENSION Y(*), C(65), CON(2) + SAVE CON, C + DATA CON(1), CON(2) / + 1 3.98942280401432678D-01, 1.25331413731550025D+00/ + DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), + 1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), + 2 C(19), C(20), C(21), C(22), C(23), C(24)/ + 3 -2.08333333333333D-01, 1.25000000000000D-01, + 4 3.34201388888889D-01, -4.01041666666667D-01, + 5 7.03125000000000D-02, -1.02581259645062D+00, + 6 1.84646267361111D+00, -8.91210937500000D-01, + 7 7.32421875000000D-02, 4.66958442342625D+00, + 8 -1.12070026162230D+01, 8.78912353515625D+00, + 9 -2.36408691406250D+00, 1.12152099609375D-01, + 1 -2.82120725582002D+01, 8.46362176746007D+01, + 2 -9.18182415432400D+01, 4.25349987453885D+01, + 3 -7.36879435947963D+00, 2.27108001708984D-01, + 4 2.12570130039217D+02, -7.65252468141182D+02, + 5 1.05999045252800D+03, -6.99579627376133D+02/ + DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), + 1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), + 2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ + 3 2.18190511744212D+02, -2.64914304869516D+01, + 4 5.72501420974731D-01, -1.91945766231841D+03, + 5 8.06172218173731D+03, -1.35865500064341D+04, + 6 1.16553933368645D+04, -5.30564697861340D+03, + 7 1.20090291321635D+03, -1.08090919788395D+02, + 8 1.72772750258446D+00, 2.02042913309661D+04, + 9 -9.69805983886375D+04, 1.92547001232532D+05, + 1 -2.03400177280416D+05, 1.22200464983017D+05, + 2 -4.11926549688976D+04, 7.10951430248936D+03, + 3 -4.93915304773088D+02, 6.07404200127348D+00, + 4 -2.42919187900551D+05, 1.31176361466298D+06, + 5 -2.99801591853811D+06, 3.76327129765640D+06/ + DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), + 1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), + 2 C(65)/ + 3 -2.81356322658653D+06, 1.26836527332162D+06, + 4 -3.31645172484564D+05, 4.52187689813627D+04, + 5 -2.49983048181121D+03, 2.43805296995561D+01, + 6 3.28446985307204D+06, -1.97068191184322D+07, + 7 5.09526024926646D+07, -7.41051482115327D+07, + 8 6.63445122747290D+07, -3.75671766607634D+07, + 9 1.32887671664218D+07, -2.78561812808645D+06, + 1 3.08186404612662D+05, -1.38860897537170D+04, + 2 1.10017140269247D+02/ +C***FIRST EXECUTABLE STATEMENT DASYIK + TOL = D1MACH(3) + TOL = MAX(TOL,1.0D-15) + FN = FNU + Z = (3.0D0-FLGIK)/2.0D0 + KK = INT(Z) + DO 50 JN=1,IN + IF (JN.EQ.1) GO TO 10 + FN = FN - FLGIK + Z = X/FN + RA = SQRT(1.0D0+Z*Z) + GLN = LOG((1.0D0+RA)/Z) + ETX = KODE - 1 + T = RA*(1.0D0-ETX) + ETX/(Z+RA) + ARG = FN*(T-GLN)*FLGIK + 10 COEF = EXP(ARG) + T = 1.0D0/RA + T2 = T*T + T = T/FN + T = SIGN(T,FLGIK) + S2 = 1.0D0 + AP = 1.0D0 + L = 0 + DO 30 K=2,11 + L = L + 1 + S1 = C(L) + DO 20 J=2,K + L = L + 1 + S1 = S1*T2 + C(L) + 20 CONTINUE + AP = AP*T + AK = AP*S1 + S2 = S2 + AK + IF (MAX(ABS(AK),ABS(AP)) .LT.TOL) GO TO 40 + 30 CONTINUE + 40 CONTINUE + T = ABS(T) + Y(JN) = S2*COEF*SQRT(T)*CON(KK) + 50 CONTINUE + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/dasyik.lo b/modules/elementary_functions/src/fortran/slatec/dasyik.lo new file mode 100755 index 000000000..bae101460 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dasyik.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dasyik.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dasyik.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dasyjy.f b/modules/elementary_functions/src/fortran/slatec/dasyjy.f new file mode 100755 index 000000000..f2479077b --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dasyjy.f @@ -0,0 +1,493 @@ +*DECK DASYJY + SUBROUTINE DASYJY (FUNJY, X, FNU, FLGJY, IN, Y, WK, IFLW) +C***BEGIN PROLOGUE DASYJY +C***SUBSIDIARY +C***PURPOSE Subsidiary to DBESJ and DBESY +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (ASYJY-S, DASYJY-D) +C***AUTHOR Amos, D. E., (SNLA) +C***DESCRIPTION +C +C DASYJY computes Bessel functions J and Y +C for arguments X.GT.0.0 and orders FNU .GE. 35.0 +C on FLGJY = 1 and FLGJY = -1 respectively +C +C INPUT +C +C FUNJY - External subroutine JAIRY or YAIRY +C X - Argument, X.GT.0.0D0 +C FNU - Order of the first Bessel function +C FLGJY - Selection flag +C FLGJY = 1.0D0 gives the J function +C FLGJY = -1.0D0 gives the Y function +C IN - Number of functions desired, IN = 1 or 2 +C +C OUTPUT +C +C Y - A vector whose first IN components contain the sequence +C IFLW - A flag indicating underflow or overflow +C return variables for BESJ only +C WK(1) = 1 - (X/FNU)**2 = W**2 +C WK(2) = SQRT(ABS(WK(1))) +C WK(3) = ABS(WK(2) - ATAN(WK(2))) or +C ABS(LN((1 + WK(2))/(X/FNU)) - WK(2)) +C = ABS((2/3)*ZETA**(3/2)) +C WK(4) = FNU*WK(3) +C WK(5) = (1.5*WK(3)*FNU)**(1/3) = SQRT(ZETA)*FNU**(1/3) +C WK(6) = SIGN(1.,W**2)*WK(5)**2 = SIGN(1.,W**2)*ZETA*FNU**(2/3) +C WK(7) = FNU**(1/3) +C +C Abstract **** A Double Precision Routine **** +C DASYJY implements the uniform asymptotic expansion of +C the J and Y Bessel functions for FNU.GE.35 and real +C X.GT.0.0D0. The forms are identical except for a change +C in sign of some of the terms. This change in sign is +C accomplished by means of the flag FLGJY = 1 or -1. On +C FLGJY = 1 the Airy functions AI(X) and DAI(X) are +C supplied by the external function JAIRY, and on +C FLGJY = -1 the Airy functions BI(X) and DBI(X) are +C supplied by the external function YAIRY. +C +C***SEE ALSO DBESJ, DBESY +C***ROUTINES CALLED D1MACH, I1MACH +C***REVISION HISTORY (YYMMDD) +C 750101 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890911 Removed unnecessary intrinsics. (WRB) +C 891004 Correction computation of ELIM. (WRB) +C 891009 Removed unreferenced variable. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 910408 Updated the AUTHOR section. (WRB) +C***END PROLOGUE DASYJY + INTEGER I, IFLW, IN, J, JN,JR,JU,K, KB,KLAST,KMAX,KP1, KS, KSP1, + * KSTEMP, L, LR, LRP1, ISETA, ISETB + INTEGER I1MACH + DOUBLE PRECISION ABW2, AKM, ALFA, ALFA1, ALFA2, AP, AR, ASUM, AZ, + * BETA, BETA1, BETA2, BETA3, BR, BSUM, C, CON1, CON2, + * CON548,CR,CRZ32, DFI,ELIM, DR,FI, FLGJY, FN, FNU, + * FN2, GAMA, PHI, RCZ, RDEN, RELB, RFN2, RTZ, RZDEN, + * SA, SB, SUMA, SUMB, S1, TA, TAU, TB, TFN, TOL, TOLS, T2, UPOL, + * WK, X, XX, Y, Z, Z32 + DOUBLE PRECISION D1MACH + DIMENSION Y(*), WK(*), C(65) + DIMENSION ALFA(26,4), BETA(26,5) + DIMENSION ALFA1(26,2), ALFA2(26,2) + DIMENSION BETA1(26,2), BETA2(26,2), BETA3(26,1) + DIMENSION GAMA(26), KMAX(5), AR(8), BR(10), UPOL(10) + DIMENSION CR(10), DR(10) + EQUIVALENCE (ALFA(1,1),ALFA1(1,1)) + EQUIVALENCE (ALFA(1,3),ALFA2(1,1)) + EQUIVALENCE (BETA(1,1),BETA1(1,1)) + EQUIVALENCE (BETA(1,3),BETA2(1,1)) + EQUIVALENCE (BETA(1,5),BETA3(1,1)) + SAVE TOLS, CON1, CON2, CON548, AR, BR, C, + 1 ALFA1, ALFA2, BETA1, BETA2, BETA3, GAMA + DATA TOLS /-6.90775527898214D+00/ + DATA CON1,CON2,CON548/ + 1 6.66666666666667D-01, 3.33333333333333D-01, 1.04166666666667D-01/ + DATA AR(1), AR(2), AR(3), AR(4), AR(5), AR(6), AR(7), + A AR(8) / 8.35503472222222D-02, 1.28226574556327D-01, + 1 2.91849026464140D-01, 8.81627267443758D-01, 3.32140828186277D+00, + 2 1.49957629868626D+01, 7.89230130115865D+01, 4.74451538868264D+02/ + DATA BR(1), BR(2), BR(3), BR(4), BR(5), BR(6), BR(7), BR(8), + A BR(9), BR(10) /-1.45833333333333D-01,-9.87413194444444D-02, + 1-1.43312053915895D-01,-3.17227202678414D-01,-9.42429147957120D-01, + 2-3.51120304082635D+00,-1.57272636203680D+01,-8.22814390971859D+01, + 3-4.92355370523671D+02,-3.31621856854797D+03/ + DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), + 1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), + 2 C(19), C(20), C(21), C(22), C(23), C(24)/ + 3 -2.08333333333333D-01, 1.25000000000000D-01, + 4 3.34201388888889D-01, -4.01041666666667D-01, + 5 7.03125000000000D-02, -1.02581259645062D+00, + 6 1.84646267361111D+00, -8.91210937500000D-01, + 7 7.32421875000000D-02, 4.66958442342625D+00, + 8 -1.12070026162230D+01, 8.78912353515625D+00, + 9 -2.36408691406250D+00, 1.12152099609375D-01, + A -2.82120725582002D+01, 8.46362176746007D+01, + B -9.18182415432400D+01, 4.25349987453885D+01, + C -7.36879435947963D+00, 2.27108001708984D-01, + D 2.12570130039217D+02, -7.65252468141182D+02, + E 1.05999045252800D+03, -6.99579627376133D+02/ + DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), + 1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), + 2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ + 3 2.18190511744212D+02, -2.64914304869516D+01, + 4 5.72501420974731D-01, -1.91945766231841D+03, + 5 8.06172218173731D+03, -1.35865500064341D+04, + 6 1.16553933368645D+04, -5.30564697861340D+03, + 7 1.20090291321635D+03, -1.08090919788395D+02, + 8 1.72772750258446D+00, 2.02042913309661D+04, + 9 -9.69805983886375D+04, 1.92547001232532D+05, + A -2.03400177280416D+05, 1.22200464983017D+05, + B -4.11926549688976D+04, 7.10951430248936D+03, + C -4.93915304773088D+02, 6.07404200127348D+00, + D -2.42919187900551D+05, 1.31176361466298D+06, + E -2.99801591853811D+06, 3.76327129765640D+06/ + DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), + 1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), + 2 C(65)/ + 3 -2.81356322658653D+06, 1.26836527332162D+06, + 4 -3.31645172484564D+05, 4.52187689813627D+04, + 5 -2.49983048181121D+03, 2.43805296995561D+01, + 6 3.28446985307204D+06, -1.97068191184322D+07, + 7 5.09526024926646D+07, -7.41051482115327D+07, + 8 6.63445122747290D+07, -3.75671766607634D+07, + 9 1.32887671664218D+07, -2.78561812808645D+06, + A 3.08186404612662D+05, -1.38860897537170D+04, + B 1.10017140269247D+02/ + DATA ALFA1(1,1), ALFA1(2,1), ALFA1(3,1), ALFA1(4,1), ALFA1(5,1), + 1 ALFA1(6,1), ALFA1(7,1), ALFA1(8,1), ALFA1(9,1), ALFA1(10,1), + 2 ALFA1(11,1),ALFA1(12,1),ALFA1(13,1),ALFA1(14,1),ALFA1(15,1), + 3 ALFA1(16,1),ALFA1(17,1),ALFA1(18,1),ALFA1(19,1),ALFA1(20,1), + 4 ALFA1(21,1),ALFA1(22,1),ALFA1(23,1),ALFA1(24,1),ALFA1(25,1), + 5 ALFA1(26,1) /-4.44444444444444D-03,-9.22077922077922D-04, + 6-8.84892884892885D-05, 1.65927687832450D-04, 2.46691372741793D-04, + 7 2.65995589346255D-04, 2.61824297061501D-04, 2.48730437344656D-04, + 8 2.32721040083232D-04, 2.16362485712365D-04, 2.00738858762752D-04, + 9 1.86267636637545D-04, 1.73060775917876D-04, 1.61091705929016D-04, + 1 1.50274774160908D-04, 1.40503497391270D-04, 1.31668816545923D-04, + 2 1.23667445598253D-04, 1.16405271474738D-04, 1.09798298372713D-04, + 3 1.03772410422993D-04, 9.82626078369363D-05, 9.32120517249503D-05, + 4 8.85710852478712D-05, 8.42963105715700D-05, 8.03497548407791D-05/ + DATA ALFA1(1,2), ALFA1(2,2), ALFA1(3,2), ALFA1(4,2), ALFA1(5,2), + 1 ALFA1(6,2), ALFA1(7,2), ALFA1(8,2), ALFA1(9,2), ALFA1(10,2), + 2 ALFA1(11,2),ALFA1(12,2),ALFA1(13,2),ALFA1(14,2),ALFA1(15,2), + 3 ALFA1(16,2),ALFA1(17,2),ALFA1(18,2),ALFA1(19,2),ALFA1(20,2), + 4 ALFA1(21,2),ALFA1(22,2),ALFA1(23,2),ALFA1(24,2),ALFA1(25,2), + 5 ALFA1(26,2) / 6.93735541354589D-04, 2.32241745182922D-04, + 6-1.41986273556691D-05,-1.16444931672049D-04,-1.50803558053049D-04, + 7-1.55121924918096D-04,-1.46809756646466D-04,-1.33815503867491D-04, + 8-1.19744975684254D-04,-1.06184319207974D-04,-9.37699549891194D-05, + 9-8.26923045588193D-05,-7.29374348155221D-05,-6.44042357721016D-05, + 1-5.69611566009369D-05,-5.04731044303562D-05,-4.48134868008883D-05, + 2-3.98688727717599D-05,-3.55400532972042D-05,-3.17414256609022D-05, + 3-2.83996793904175D-05,-2.54522720634871D-05,-2.28459297164725D-05, + 4-2.05352753106481D-05,-1.84816217627666D-05,-1.66519330021394D-05/ + DATA ALFA2(1,1), ALFA2(2,1), ALFA2(3,1), ALFA2(4,1), ALFA2(5,1), + 1 ALFA2(6,1), ALFA2(7,1), ALFA2(8,1), ALFA2(9,1), ALFA2(10,1), + 2 ALFA2(11,1),ALFA2(12,1),ALFA2(13,1),ALFA2(14,1),ALFA2(15,1), + 3 ALFA2(16,1),ALFA2(17,1),ALFA2(18,1),ALFA2(19,1),ALFA2(20,1), + 4 ALFA2(21,1),ALFA2(22,1),ALFA2(23,1),ALFA2(24,1),ALFA2(25,1), + 5 ALFA2(26,1) /-3.54211971457744D-04,-1.56161263945159D-04, + 6 3.04465503594936D-05, 1.30198655773243D-04, 1.67471106699712D-04, + 7 1.70222587683593D-04, 1.56501427608595D-04, 1.36339170977445D-04, + 8 1.14886692029825D-04, 9.45869093034688D-05, 7.64498419250898D-05, + 9 6.07570334965197D-05, 4.74394299290509D-05, 3.62757512005344D-05, + 1 2.69939714979225D-05, 1.93210938247939D-05, 1.30056674793963D-05, + 2 7.82620866744497D-06, 3.59257485819352D-06, 1.44040049814252D-07, + 3-2.65396769697939D-06,-4.91346867098486D-06,-6.72739296091248D-06, + 4-8.17269379678658D-06,-9.31304715093561D-06,-1.02011418798016D-05/ + DATA ALFA2(1,2), ALFA2(2,2), ALFA2(3,2), ALFA2(4,2), ALFA2(5,2), + 1 ALFA2(6,2), ALFA2(7,2), ALFA2(8,2), ALFA2(9,2), ALFA2(10,2), + 2 ALFA2(11,2),ALFA2(12,2),ALFA2(13,2),ALFA2(14,2),ALFA2(15,2), + 3 ALFA2(16,2),ALFA2(17,2),ALFA2(18,2),ALFA2(19,2),ALFA2(20,2), + 4 ALFA2(21,2),ALFA2(22,2),ALFA2(23,2),ALFA2(24,2),ALFA2(25,2), + 5 ALFA2(26,2) / 3.78194199201773D-04, 2.02471952761816D-04, + 6-6.37938506318862D-05,-2.38598230603006D-04,-3.10916256027362D-04, + 7-3.13680115247576D-04,-2.78950273791323D-04,-2.28564082619141D-04, + 8-1.75245280340847D-04,-1.25544063060690D-04,-8.22982872820208D-05, + 9-4.62860730588116D-05,-1.72334302366962D-05, 5.60690482304602D-06, + 1 2.31395443148287D-05, 3.62642745856794D-05, 4.58006124490189D-05, + 2 5.24595294959114D-05, 5.68396208545815D-05, 5.94349820393104D-05, + 3 6.06478527578422D-05, 6.08023907788436D-05, 6.01577894539460D-05, + 4 5.89199657344698D-05, 5.72515823777593D-05, 5.52804375585853D-05/ + DATA BETA1(1,1), BETA1(2,1), BETA1(3,1), BETA1(4,1), BETA1(5,1), + 1 BETA1(6,1), BETA1(7,1), BETA1(8,1), BETA1(9,1), BETA1(10,1), + 2 BETA1(11,1),BETA1(12,1),BETA1(13,1),BETA1(14,1),BETA1(15,1), + 3 BETA1(16,1),BETA1(17,1),BETA1(18,1),BETA1(19,1),BETA1(20,1), + 4 BETA1(21,1),BETA1(22,1),BETA1(23,1),BETA1(24,1),BETA1(25,1), + 5 BETA1(26,1) / 1.79988721413553D-02, 5.59964911064388D-03, + 6 2.88501402231133D-03, 1.80096606761054D-03, 1.24753110589199D-03, + 7 9.22878876572938D-04, 7.14430421727287D-04, 5.71787281789705D-04, + 8 4.69431007606482D-04, 3.93232835462917D-04, 3.34818889318298D-04, + 9 2.88952148495752D-04, 2.52211615549573D-04, 2.22280580798883D-04, + 1 1.97541838033063D-04, 1.76836855019718D-04, 1.59316899661821D-04, + 2 1.44347930197334D-04, 1.31448068119965D-04, 1.20245444949303D-04, + 3 1.10449144504599D-04, 1.01828770740567D-04, 9.41998224204238D-05, + 4 8.74130545753834D-05, 8.13466262162801D-05, 7.59002269646219D-05/ + DATA BETA1(1,2), BETA1(2,2), BETA1(3,2), BETA1(4,2), BETA1(5,2), + 1 BETA1(6,2), BETA1(7,2), BETA1(8,2), BETA1(9,2), BETA1(10,2), + 2 BETA1(11,2),BETA1(12,2),BETA1(13,2),BETA1(14,2),BETA1(15,2), + 3 BETA1(16,2),BETA1(17,2),BETA1(18,2),BETA1(19,2),BETA1(20,2), + 4 BETA1(21,2),BETA1(22,2),BETA1(23,2),BETA1(24,2),BETA1(25,2), + 5 BETA1(26,2) /-1.49282953213429D-03,-8.78204709546389D-04, + 6-5.02916549572035D-04,-2.94822138512746D-04,-1.75463996970783D-04, + 7-1.04008550460816D-04,-5.96141953046458D-05,-3.12038929076098D-05, + 8-1.26089735980230D-05,-2.42892608575730D-07, 8.05996165414274D-06, + 9 1.36507009262147D-05, 1.73964125472926D-05, 1.98672978842134D-05, + 1 2.14463263790823D-05, 2.23954659232457D-05, 2.28967783814713D-05, + 2 2.30785389811178D-05, 2.30321976080909D-05, 2.28236073720349D-05, + 3 2.25005881105292D-05, 2.20981015361991D-05, 2.16418427448104D-05, + 4 2.11507649256221D-05, 2.06388749782171D-05, 2.01165241997082D-05/ + DATA BETA2(1,1), BETA2(2,1), BETA2(3,1), BETA2(4,1), BETA2(5,1), + 1 BETA2(6,1), BETA2(7,1), BETA2(8,1), BETA2(9,1), BETA2(10,1), + 2 BETA2(11,1),BETA2(12,1),BETA2(13,1),BETA2(14,1),BETA2(15,1), + 3 BETA2(16,1),BETA2(17,1),BETA2(18,1),BETA2(19,1),BETA2(20,1), + 4 BETA2(21,1),BETA2(22,1),BETA2(23,1),BETA2(24,1),BETA2(25,1), + 5 BETA2(26,1) / 5.52213076721293D-04, 4.47932581552385D-04, + 6 2.79520653992021D-04, 1.52468156198447D-04, 6.93271105657044D-05, + 7 1.76258683069991D-05,-1.35744996343269D-05,-3.17972413350427D-05, + 8-4.18861861696693D-05,-4.69004889379141D-05,-4.87665447413787D-05, + 9-4.87010031186735D-05,-4.74755620890087D-05,-4.55813058138628D-05, + 1-4.33309644511266D-05,-4.09230193157750D-05,-3.84822638603221D-05, + 2-3.60857167535411D-05,-3.37793306123367D-05,-3.15888560772110D-05, + 3-2.95269561750807D-05,-2.75978914828336D-05,-2.58006174666884D-05, + 4-2.41308356761280D-05,-2.25823509518346D-05,-2.11479656768913D-05/ + DATA BETA2(1,2), BETA2(2,2), BETA2(3,2), BETA2(4,2), BETA2(5,2), + 1 BETA2(6,2), BETA2(7,2), BETA2(8,2), BETA2(9,2), BETA2(10,2), + 2 BETA2(11,2),BETA2(12,2),BETA2(13,2),BETA2(14,2),BETA2(15,2), + 3 BETA2(16,2),BETA2(17,2),BETA2(18,2),BETA2(19,2),BETA2(20,2), + 4 BETA2(21,2),BETA2(22,2),BETA2(23,2),BETA2(24,2),BETA2(25,2), + 5 BETA2(26,2) /-4.74617796559960D-04,-4.77864567147321D-04, + 6-3.20390228067038D-04,-1.61105016119962D-04,-4.25778101285435D-05, + 7 3.44571294294968D-05, 7.97092684075675D-05, 1.03138236708272D-04, + 8 1.12466775262204D-04, 1.13103642108481D-04, 1.08651634848774D-04, + 9 1.01437951597662D-04, 9.29298396593364D-05, 8.40293133016090D-05, + 1 7.52727991349134D-05, 6.69632521975731D-05, 5.92564547323195D-05, + 2 5.22169308826976D-05, 4.58539485165361D-05, 4.01445513891487D-05, + 3 3.50481730031328D-05, 3.05157995034347D-05, 2.64956119950516D-05, + 4 2.29363633690998D-05, 1.97893056664022D-05, 1.70091984636413D-05/ + DATA BETA3(1,1), BETA3(2,1), BETA3(3,1), BETA3(4,1), BETA3(5,1), + 1 BETA3(6,1), BETA3(7,1), BETA3(8,1), BETA3(9,1), BETA3(10,1), + 2 BETA3(11,1),BETA3(12,1),BETA3(13,1),BETA3(14,1),BETA3(15,1), + 3 BETA3(16,1),BETA3(17,1),BETA3(18,1),BETA3(19,1),BETA3(20,1), + 4 BETA3(21,1),BETA3(22,1),BETA3(23,1),BETA3(24,1),BETA3(25,1), + 5 BETA3(26,1) / 7.36465810572578D-04, 8.72790805146194D-04, + 6 6.22614862573135D-04, 2.85998154194304D-04, 3.84737672879366D-06, + 7-1.87906003636972D-04,-2.97603646594555D-04,-3.45998126832656D-04, + 8-3.53382470916038D-04,-3.35715635775049D-04,-3.04321124789040D-04, + 9-2.66722723047613D-04,-2.27654214122820D-04,-1.89922611854562D-04, + 1-1.55058918599094D-04,-1.23778240761874D-04,-9.62926147717644D-05, + 2-7.25178327714425D-05,-5.22070028895634D-05,-3.50347750511901D-05, + 3-2.06489761035552D-05,-8.70106096849767D-06, 1.13698686675100D-06, + 4 9.16426474122779D-06, 1.56477785428873D-05, 2.08223629482467D-05/ + DATA GAMA(1), GAMA(2), GAMA(3), GAMA(4), GAMA(5), + 1 GAMA(6), GAMA(7), GAMA(8), GAMA(9), GAMA(10), + 2 GAMA(11), GAMA(12), GAMA(13), GAMA(14), GAMA(15), + 3 GAMA(16), GAMA(17), GAMA(18), GAMA(19), GAMA(20), + 4 GAMA(21), GAMA(22), GAMA(23), GAMA(24), GAMA(25), + 5 GAMA(26) / 6.29960524947437D-01, 2.51984209978975D-01, + 6 1.54790300415656D-01, 1.10713062416159D-01, 8.57309395527395D-02, + 7 6.97161316958684D-02, 5.86085671893714D-02, 5.04698873536311D-02, + 8 4.42600580689155D-02, 3.93720661543510D-02, 3.54283195924455D-02, + 9 3.21818857502098D-02, 2.94646240791158D-02, 2.71581677112934D-02, + 1 2.51768272973862D-02, 2.34570755306079D-02, 2.19508390134907D-02, + 2 2.06210828235646D-02, 1.94388240897881D-02, 1.83810633800683D-02, + 3 1.74293213231963D-02, 1.65685837786612D-02, 1.57865285987918D-02, + 4 1.50729501494096D-02, 1.44193250839955D-02, 1.38184805735342D-02/ +C***FIRST EXECUTABLE STATEMENT DASYJY + TA = D1MACH(3) + TOL = MAX(TA,1.0D-15) + TB = D1MACH(5) + JU = I1MACH(15) + IF(FLGJY.EQ.1.0D0) GO TO 6 + JR = I1MACH(14) + ELIM = -2.303D0*TB*(JU+JR) + GO TO 7 + 6 CONTINUE + ELIM = -2.303D0*(TB*JU+3.0D0) + 7 CONTINUE + FN = FNU + IFLW = 0 + DO 170 JN=1,IN + XX = X/FN + WK(1) = 1.0D0 - XX*XX + ABW2 = ABS(WK(1)) + WK(2) = SQRT(ABW2) + WK(7) = FN**CON2 + IF (ABW2.GT.0.27750D0) GO TO 80 +C +C ASYMPTOTIC EXPANSION +C CASES NEAR X=FN, ABS(1.-(X/FN)**2).LE.0.2775 +C COEFFICIENTS OF ASYMPTOTIC EXPANSION BY SERIES +C +C ZETA AND TRUNCATION FOR A(ZETA) AND B(ZETA) SERIES +C +C KMAX IS TRUNCATION INDEX FOR A(ZETA) AND B(ZETA) SERIES=MAX(2,SA) +C + SA = 0.0D0 + IF (ABW2.EQ.0.0D0) GO TO 10 + SA = TOLS/LOG(ABW2) + 10 SB = SA + DO 20 I=1,5 + AKM = MAX(SA,2.0D0) + KMAX(I) = INT(AKM) + SA = SA + SB + 20 CONTINUE + KB = KMAX(5) + KLAST = KB - 1 + SA = GAMA(KB) + DO 30 K=1,KLAST + KB = KB - 1 + SA = SA*WK(1) + GAMA(KB) + 30 CONTINUE + Z = WK(1)*SA + AZ = ABS(Z) + RTZ = SQRT(AZ) + WK(3) = CON1*AZ*RTZ + WK(4) = WK(3)*FN + WK(5) = RTZ*WK(7) + WK(6) = -WK(5)*WK(5) + IF(Z.LE.0.0D0) GO TO 35 + IF(WK(4).GT.ELIM) GO TO 75 + WK(6) = -WK(6) + 35 CONTINUE + PHI = SQRT(SQRT(SA+SA+SA+SA)) +C +C B(ZETA) FOR S=0 +C + KB = KMAX(5) + KLAST = KB - 1 + SB = BETA(KB,1) + DO 40 K=1,KLAST + KB = KB - 1 + SB = SB*WK(1) + BETA(KB,1) + 40 CONTINUE + KSP1 = 1 + FN2 = FN*FN + RFN2 = 1.0D0/FN2 + RDEN = 1.0D0 + ASUM = 1.0D0 + RELB = TOL*ABS(SB) + BSUM = SB + DO 60 KS=1,4 + KSP1 = KSP1 + 1 + RDEN = RDEN*RFN2 +C +C A(ZETA) AND B(ZETA) FOR S=1,2,3,4 +C + KSTEMP = 5 - KS + KB = KMAX(KSTEMP) + KLAST = KB - 1 + SA = ALFA(KB,KS) + SB = BETA(KB,KSP1) + DO 50 K=1,KLAST + KB = KB - 1 + SA = SA*WK(1) + ALFA(KB,KS) + SB = SB*WK(1) + BETA(KB,KSP1) + 50 CONTINUE + TA = SA*RDEN + TB = SB*RDEN + ASUM = ASUM + TA + BSUM = BSUM + TB + IF (ABS(TA).LE.TOL .AND. ABS(TB).LE.RELB) GO TO 70 + 60 CONTINUE + 70 CONTINUE + BSUM = BSUM/(FN*WK(7)) + GO TO 160 +C + 75 CONTINUE + IFLW = 1 + RETURN +C + 80 CONTINUE + UPOL(1) = 1.0D0 + TAU = 1.0D0/WK(2) + T2 = 1.0D0/WK(1) + IF (WK(1).GE.0.0D0) GO TO 90 +C +C CASES FOR (X/FN).GT.SQRT(1.2775) +C + WK(3) = ABS(WK(2)-ATAN(WK(2))) + WK(4) = WK(3)*FN + RCZ = -CON1/WK(4) + Z32 = 1.5D0*WK(3) + RTZ = Z32**CON2 + WK(5) = RTZ*WK(7) + WK(6) = -WK(5)*WK(5) + GO TO 100 + 90 CONTINUE +C +C CASES FOR (X/FN).LT.SQRT(0.7225) +C + WK(3) = ABS(LOG((1.0D0+WK(2))/XX)-WK(2)) + WK(4) = WK(3)*FN + RCZ = CON1/WK(4) + IF(WK(4).GT.ELIM) GO TO 75 + Z32 = 1.5D0*WK(3) + RTZ = Z32**CON2 + WK(7) = FN**CON2 + WK(5) = RTZ*WK(7) + WK(6) = WK(5)*WK(5) + 100 CONTINUE + PHI = SQRT((RTZ+RTZ)*TAU) + TB = 1.0D0 + ASUM = 1.0D0 + TFN = TAU/FN + RDEN=1.0D0/FN + RFN2=RDEN*RDEN + RDEN=1.0D0 + UPOL(2) = (C(1)*T2+C(2))*TFN + CRZ32 = CON548*RCZ + BSUM = UPOL(2) + CRZ32 + RELB = TOL*ABS(BSUM) + AP = TFN + KS = 0 + KP1 = 2 + RZDEN = RCZ + L = 2 + ISETA=0 + ISETB=0 + DO 140 LR=2,8,2 +C +C COMPUTE TWO U POLYNOMIALS FOR NEXT A(ZETA) AND B(ZETA) +C + LRP1 = LR + 1 + DO 120 K=LR,LRP1 + KS = KS + 1 + KP1 = KP1 + 1 + L = L + 1 + S1 = C(L) + DO 110 J=2,KP1 + L = L + 1 + S1 = S1*T2 + C(L) + 110 CONTINUE + AP = AP*TFN + UPOL(KP1) = AP*S1 + CR(KS) = BR(KS)*RZDEN + RZDEN = RZDEN*RCZ + DR(KS) = AR(KS)*RZDEN + 120 CONTINUE + SUMA = UPOL(LRP1) + SUMB = UPOL(LR+2) + UPOL(LRP1)*CRZ32 + JU = LRP1 + DO 130 JR=1,LR + JU = JU - 1 + SUMA = SUMA + CR(JR)*UPOL(JU) + SUMB = SUMB + DR(JR)*UPOL(JU) + 130 CONTINUE + RDEN=RDEN*RFN2 + TB = -TB + IF (WK(1).GT.0.0D0) TB = ABS(TB) + IF(RDEN.LT.TOL) GO TO 131 + ASUM = ASUM + SUMA*TB + BSUM = BSUM + SUMB*TB + GO TO 140 + 131 IF(ISETA.EQ.1) GO TO 132 + IF(ABS(SUMA).LT.TOL) ISETA=1 + ASUM=ASUM+SUMA*TB + 132 IF(ISETB.EQ.1) GO TO 133 + IF(ABS(SUMB).LT.RELB) ISETB=1 + BSUM=BSUM+SUMB*TB + 133 IF(ISETA.EQ.1 .AND. ISETB.EQ.1) GO TO 150 + 140 CONTINUE + 150 TB = WK(5) + IF (WK(1).GT.0.0D0) TB = -TB + BSUM = BSUM/TB +C + 160 CONTINUE + CALL FUNJY(WK(6), WK(5), WK(4), FI, DFI) + TA=1.0D0/TOL + TB=D1MACH(1)*TA*1.0D+3 + IF(ABS(FI).GT.TB) GO TO 165 + FI=FI*TA + DFI=DFI*TA + PHI=PHI*TOL + 165 CONTINUE + Y(JN) = FLGJY*PHI*(FI*ASUM+DFI*BSUM)/WK(7) + FN = FN - FLGJY + 170 CONTINUE + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/dasyjy.lo b/modules/elementary_functions/src/fortran/slatec/dasyjy.lo new file mode 100755 index 000000000..f326cd3c5 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dasyjy.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dasyjy.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dasyjy.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dbdiff.f b/modules/elementary_functions/src/fortran/slatec/dbdiff.f new file mode 100755 index 000000000..f1fbcba2e --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbdiff.f @@ -0,0 +1,37 @@ +*DECK DBDIFF + SUBROUTINE DBDIFF (L, V) +C***BEGIN PROLOGUE DBDIFF +C***SUBSIDIARY +C***PURPOSE Subsidiary to DBSKIN +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (BDIFF-S, DBDIFF-D) +C***AUTHOR Amos, D. E., (SNLA) +C***DESCRIPTION +C +C DBDIFF computes the sum of B(L,K)*V(K)*(-1)**K where B(L,K) +C are the binomial coefficients. Truncated sums are computed by +C setting last part of the V vector to zero. On return, the binomial +C sum is in V(L). +C +C***SEE ALSO DBSKIN +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 820601 DATE WRITTEN +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C***END PROLOGUE DBDIFF +C + INTEGER I, J, K, L + DOUBLE PRECISION V + DIMENSION V(*) +C***FIRST EXECUTABLE STATEMENT DBDIFF + IF (L.EQ.1) RETURN + DO 20 J=2,L + K = L + DO 10 I=J,L + V(K) = V(K-1) - V(K) + K = K - 1 + 10 CONTINUE + 20 CONTINUE + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/dbdiff.lo b/modules/elementary_functions/src/fortran/slatec/dbdiff.lo new file mode 100755 index 000000000..17927327c --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbdiff.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dbdiff.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dbdiff.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dbesi.f b/modules/elementary_functions/src/fortran/slatec/dbesi.f new file mode 100755 index 000000000..e9ee28681 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbesi.f @@ -0,0 +1,503 @@ +*DECK DBESI + SUBROUTINE DBESI (X, ALPHA, KODE, N, Y, NZ,ierr) +C***BEGIN PROLOGUE DBESI +C***PURPOSE Compute an N member sequence of I Bessel functions +C I/SUB(ALPHA+K-1)/(X), K=1,...,N or scaled Bessel functions +C EXP(-X)*I/SUB(ALPHA+K-1)/(X), K=1,...,N for nonnegative +C ALPHA and X. +C***LIBRARY SLATEC +C***CATEGORY C10B3 +C***TYPE DOUBLE PRECISION (BESI-S, DBESI-D) +C***KEYWORDS I BESSEL FUNCTION, SPECIAL FUNCTIONS +C***AUTHOR Amos, D. E., (SNLA) +C Daniel, S. L., (SNLA) +C***DESCRIPTION +C +C Abstract **** a double precision routine **** +C DBESI computes an N member sequence of I Bessel functions +C I/sub(ALPHA+K-1)/(X), K=1,...,N or scaled Bessel functions +C EXP(-X)*I/sub(ALPHA+K-1)/(X), K=1,...,N for nonnegative ALPHA +C and X. A combination of the power series, the asymptotic +C expansion for X to infinity, and the uniform asymptotic +C expansion for NU to infinity are applied over subdivisions of +C the (NU,X) plane. For values not covered by one of these +C formulae, the order is incremented by an integer so that one +C of these formulae apply. Backward recursion is used to reduce +C orders by integer values. The asymptotic expansion for X to +C infinity is used only when the entire sequence (specifically +C the last member) lies within the region covered by the +C expansion. Leading terms of these expansions are used to test +C for over or underflow where appropriate. If a sequence is +C requested and the last member would underflow, the result is +C set to zero and the next lower order tried, etc., until a +C member comes on scale or all are set to zero. An overflow +C cannot occur with scaling. +C +C The maximum number of significant digits obtainable +C is the smaller of 14 and the number of digits carried in +C double precision arithmetic. +C +C Description of Arguments +C +C Input X,ALPHA are double precision +C X - X .GE. 0.0D0 +C ALPHA - order of first member of the sequence, +C ALPHA .GE. 0.0D0 +C KODE - a parameter to indicate the scaling option +C KODE=1 returns +C Y(K)= I/sub(ALPHA+K-1)/(X), +C K=1,...,N +C KODE=2 returns +C Y(K)=EXP(-X)*I/sub(ALPHA+K-1)/(X), +C K=1,...,N +C N - number of members in the sequence, N .GE. 1 +C +C Output Y is double precision +C Y - a vector whose first N components contain +C values for I/sub(ALPHA+K-1)/(X) or scaled +C values for EXP(-X)*I/sub(ALPHA+K-1)/(X), +C K=1,...,N depending on KODE +C NZ - number of components of Y set to zero due to +C underflow, +C NZ=0 , normal return, computation completed +C NZ .NE. 0, last NZ components of Y set to zero, +C Y(K)=0.0D0, K=N-NZ+1,...,N. +C +C Error Conditions +C Improper input arguments - a fatal error +C Overflow with KODE=1 - a fatal error +C Underflow - a non-fatal error(NZ .NE. 0) +C +C***REFERENCES D. E. Amos, S. L. Daniel and M. K. Weston, CDC 6600 +C subroutines IBESS and JBESS for Bessel functions +C I(NU,X) and J(NU,X), X .GE. 0, NU .GE. 0, ACM +C Transactions on Mathematical Software 3, (1977), +C pp. 76-92. +C F. W. J. Olver, Tables of Bessel Functions of Moderate +C or Large Orders, NPL Mathematical Tables 6, Her +C Majesty's Stationery Office, London, 1962. +C***ROUTINES CALLED D1MACH, DASYIK, DLNGAM, I1MACH, XERMSG +C***REVISION HISTORY (YYMMDD) +C 750101 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 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DBESI +C + INTEGER I, IALP, IN, INLIM, IS, I1, K, KK, KM, KODE, KT, + 1 N, NN, NS, NZ + INTEGER I1MACH + DOUBLE PRECISION AIN,AK,AKM,ALPHA,ANS,AP,ARG,ATOL,TOLLN,DFN, + 1 DTM, DX, EARG, ELIM, ETX, FLGIK,FN, FNF, FNI,FNP1,FNU,GLN,RA, + 2 RTTPI, S, SX, SXO2, S1, S2, T, TA, TB, TEMP, TFN, TM, TOL, + 3 TRX, T2, X, XO2, XO2L, Y, Z + DOUBLE PRECISION D1MACH, DLNGAM + DIMENSION Y(*), TEMP(3) + SAVE RTTPI, INLIM + DATA RTTPI / 3.98942280401433D-01/ + DATA INLIM / 80 / +C***FIRST EXECUTABLE STATEMENT DBESI + ierr=0 + NZ = 0 + KT = 1 +C I1MACH(15) REPLACES I1MACH(12) IN A DOUBLE PRECISION CODE +C I1MACH(14) REPLACES I1MACH(11) IN A DOUBLE PRECISION CODE + RA = D1MACH(3) + TOL = MAX(RA,1.0D-15) + I1 = -I1MACH(15) + GLN = D1MACH(5) + ELIM = 2.303D0*(I1*GLN-3.0D0) +C TOLLN = -LN(TOL) + I1 = I1MACH(14)+1 + TOLLN = 2.303D0*GLN*I1 + TOLLN = MIN(TOLLN,34.5388D0) + if ((N-1) .lt. 0) then + goto 590 + elseif ((N-1) .eq. 0) then + goto 10 + else + goto 20 + endif + 10 KT = 2 + 20 NN = N + IF (KODE.LT.1 .OR. KODE.GT.2) GO TO 570 + if (X .lt. 0) then + goto 600 + elseif (X .eq. 0) then + goto 30 + else + goto 80 + endif + 30 if (ALPHA .lt. 0) then + goto 580 + elseif (ALPHA .eq. 0) then + goto 40 + else + goto 50 + endif + 40 Y(1) = 1.0D0 + IF (N.EQ.1) RETURN + I1 = 2 + GO TO 60 + 50 I1 = 1 + 60 DO 70 I=I1,N + Y(I) = 0.0D0 + 70 CONTINUE + RETURN + 80 CONTINUE + IF (ALPHA.LT.0.0D0) GO TO 580 +C + IALP = INT(ALPHA) + FNI = IALP + N - 1 + FNF = ALPHA - IALP + DFN = FNI + FNF + FNU = DFN + IN = 0 + XO2 = X*0.5D0 + SXO2 = XO2*XO2 + ETX = KODE - 1 + SX = ETX*X +C +C DECISION TREE FOR REGION WHERE SERIES, ASYMPTOTIC EXPANSION FOR X +C TO INFINITY AND ASYMPTOTIC EXPANSION FOR NU TO INFINITY ARE +C APPLIED. +C + IF (SXO2.LE.(FNU+1.0D0)) GO TO 90 + IF (X.LE.12.0D0) GO TO 110 + FN = 0.55D0*FNU*FNU + FN = MAX(17.0D0,FN) + IF (X.GE.FN) GO TO 430 + ANS = MAX(36.0D0-FNU,0.0D0) + NS = INT(ANS) + FNI = FNI + NS + DFN = FNI + FNF + FN = DFN + IS = KT + KM = N - 1 + NS + IF (KM.GT.0) IS = 3 + GO TO 120 + 90 FN = FNU + FNP1 = FN + 1.0D0 + XO2L = LOG(XO2) + IS = KT + IF (X.LE.0.5D0) GO TO 230 + NS = 0 + 100 FNI = FNI + NS + DFN = FNI + FNF + FN = DFN + FNP1 = FN + 1.0D0 + IS = KT + IF (N-1+NS.GT.0) IS = 3 + GO TO 230 + 110 XO2L = LOG(XO2) + NS = INT(SXO2-FNU) + GO TO 100 + 120 CONTINUE +C +C OVERFLOW TEST ON UNIFORM ASYMPTOTIC EXPANSION +C + IF (KODE.EQ.2) GO TO 130 + IF (ALPHA.LT.1.0D0) GO TO 150 + Z = X/ALPHA + RA = SQRT(1.0D0+Z*Z) + GLN = LOG((1.0D0+RA)/Z) + T = RA*(1.0D0-ETX) + ETX/(Z+RA) + ARG = ALPHA*(T-GLN) + IF (ARG.GT.ELIM) GO TO 610 + IF (KM.EQ.0) GO TO 140 + 130 CONTINUE +C +C UNDERFLOW TEST ON UNIFORM ASYMPTOTIC EXPANSION +C + Z = X/FN + RA = SQRT(1.0D0+Z*Z) + GLN = LOG((1.0D0+RA)/Z) + T = RA*(1.0D0-ETX) + ETX/(Z+RA) + ARG = FN*(T-GLN) + 140 IF (ARG.LT.(-ELIM)) GO TO 280 + GO TO 190 + 150 IF (X.GT.ELIM) GO TO 610 + GO TO 130 +C +C UNIFORM ASYMPTOTIC EXPANSION FOR NU TO INFINITY +C + 160 IF (KM.NE.0) GO TO 170 + Y(1) = TEMP(3) + RETURN + 170 TEMP(1) = TEMP(3) + IN = NS + KT = 1 + I1 = 0 + 180 CONTINUE + IS = 2 + FNI = FNI - 1.0D0 + DFN = FNI + FNF + FN = DFN + IF(I1.EQ.2) GO TO 350 + Z = X/FN + RA = SQRT(1.0D0+Z*Z) + GLN = LOG((1.0D0+RA)/Z) + T = RA*(1.0D0-ETX) + ETX/(Z+RA) + ARG = FN*(T-GLN) + 190 CONTINUE + I1 = ABS(3-IS) + I1 = MAX(I1,1) + FLGIK = 1.0D0 + CALL DASYIK(X,FN,KODE,FLGIK,RA,ARG,I1,TEMP(IS)) + GO TO (180, 350, 510), IS +C +C SERIES FOR (X/2)**2.LE.NU+1 +C + 230 CONTINUE + GLN = DLNGAM(FNP1) + ARG = FN*XO2L - GLN - SX + IF (ARG.LT.(-ELIM)) GO TO 300 + EARG = EXP(ARG) + 240 CONTINUE + S = 1.0D0 + IF (X.LT.TOL) GO TO 260 + AK = 3.0D0 + T2 = 1.0D0 + T = 1.0D0 + S1 = FN + DO 250 K=1,17 + S2 = T2 + S1 + T = T*SXO2/S2 + S = S + T + IF (ABS(T).LT.TOL) GO TO 260 + T2 = T2 + AK + AK = AK + 2.0D0 + S1 = S1 + FN + 250 CONTINUE + 260 CONTINUE + TEMP(IS) = S*EARG + GO TO (270, 350, 500), IS + 270 EARG = EARG*FN/XO2 + FNI = FNI - 1.0D0 + DFN = FNI + FNF + FN = DFN + IS = 2 + GO TO 240 +C +C SET UNDERFLOW VALUE AND UPDATE PARAMETERS +C + 280 Y(NN) = 0.0D0 + NN = NN - 1 + FNI = FNI - 1.0D0 + DFN = FNI + FNF + FN = DFN + if ((NN-1) .lt. 0) then + goto 340 + elseif ((NN-1) .eq. 0) then + goto 290 + else + goto 130 + endif + 290 KT = 2 + IS = 2 + GO TO 130 + 300 Y(NN) = 0.0D0 + NN = NN - 1 + FNP1 = FN + FNI = FNI - 1.0D0 + DFN = FNI + FNF + FN = DFN + if ((NN-1) .lt. 0) then + goto 340 + elseif ((NN-1) .eq. 0) then + goto 310 + else + goto 320 + endif + 310 KT = 2 + IS = 2 + 320 IF (SXO2.LE.FNP1) GO TO 330 + GO TO 130 + 330 ARG = ARG - XO2L + LOG(FNP1) + IF (ARG.LT.(-ELIM)) GO TO 300 + GO TO 230 + 340 NZ = N - NN + RETURN +C +C BACKWARD RECURSION SECTION +C + 350 CONTINUE + NZ = N - NN + 360 CONTINUE + IF(KT.EQ.2) GO TO 420 + S1 = TEMP(1) + S2 = TEMP(2) + TRX = 2.0D0/X + DTM = FNI + TM = (DTM+FNF)*TRX + IF (IN.EQ.0) GO TO 390 +C BACKWARD RECUR TO INDEX ALPHA+NN-1 + DO 380 I=1,IN + S = S2 + S2 = TM*S2 + S1 + S1 = S + DTM = DTM - 1.0D0 + TM = (DTM+FNF)*TRX + 380 CONTINUE + Y(NN) = S1 + IF (NN.EQ.1) RETURN + Y(NN-1) = S2 + IF (NN.EQ.2) RETURN + GO TO 400 + 390 CONTINUE +C BACKWARD RECUR FROM INDEX ALPHA+NN-1 TO ALPHA + Y(NN) = S1 + Y(NN-1) = S2 + IF (NN.EQ.2) RETURN + 400 K = NN + 1 + DO 410 I=3,NN + K = K - 1 + Y(K-2) = TM*Y(K-1) + Y(K) + DTM = DTM - 1.0D0 + TM = (DTM+FNF)*TRX + 410 CONTINUE + RETURN + 420 Y(1) = TEMP(2) + RETURN +C +C ASYMPTOTIC EXPANSION FOR X TO INFINITY +C + 430 CONTINUE + EARG = RTTPI/SQRT(X) + IF (KODE.EQ.2) GO TO 440 + IF (X.GT.ELIM) GO TO 610 + EARG = EARG*EXP(X) + 440 ETX = 8.0D0*X + IS = KT + IN = 0 + FN = FNU + 450 DX = FNI + FNI + TM = 0.0D0 + IF (FNI.EQ.0.0D0 .AND. ABS(FNF).LT.TOL) GO TO 460 + TM = 4.0D0*FNF*(FNI+FNI+FNF) + 460 CONTINUE + DTM = DX*DX + S1 = ETX + TRX = DTM - 1.0D0 + DX = -(TRX+TM)/ETX + T = DX + S = 1.0D0 + DX + ATOL = TOL*ABS(S) + S2 = 1.0D0 + AK = 8.0D0 + DO 470 K=1,25 + S1 = S1 + ETX + S2 = S2 + AK + DX = DTM - S2 + AP = DX + TM + T = -T*AP/S1 + S = S + T + IF (ABS(T).LE.ATOL) GO TO 480 + AK = AK + 8.0D0 + 470 CONTINUE + 480 TEMP(IS) = S*EARG + IF(IS.EQ.2) GO TO 360 + IS = 2 + FNI = FNI - 1.0D0 + DFN = FNI + FNF + FN = DFN + GO TO 450 +C +C BACKWARD RECURSION WITH NORMALIZATION BY +C ASYMPTOTIC EXPANSION FOR NU TO INFINITY OR POWER SERIES. +C + 500 CONTINUE +C COMPUTATION OF LAST ORDER FOR SERIES NORMALIZATION + AKM = MAX(3.0D0-FN,0.0D0) + KM = INT(AKM) + TFN = FN + KM + TA = (GLN+TFN-0.9189385332D0-0.0833333333D0/TFN)/(TFN+0.5D0) + TA = XO2L - TA + TB = -(1.0D0-1.0D0/TFN)/TFN + AIN = TOLLN/(-TA+SQRT(TA*TA-TOLLN*TB)) + 1.5D0 + IN = INT(AIN) + IN = IN + KM + GO TO 520 + 510 CONTINUE +C COMPUTATION OF LAST ORDER FOR ASYMPTOTIC EXPANSION NORMALIZATION + T = 1.0D0/(FN*RA) + AIN = TOLLN/(GLN+SQRT(GLN*GLN+T*TOLLN)) + 1.5D0 + IN = INT(AIN) + IF (IN.GT.INLIM) GO TO 160 + 520 CONTINUE + TRX = 2.0D0/X + DTM = FNI + IN + TM = (DTM+FNF)*TRX + TA = 0.0D0 + TB = TOL + KK = 1 + 530 CONTINUE +C +C BACKWARD RECUR UNINDEXED +C + DO 540 I=1,IN + S = TB + TB = TM*TB + TA + TA = S + DTM = DTM - 1.0D0 + TM = (DTM+FNF)*TRX + 540 CONTINUE +C NORMALIZATION + IF (KK.NE.1) GO TO 550 + TA = (TA/TB)*TEMP(3) + TB = TEMP(3) + KK = 2 + IN = NS + IF (NS.NE.0) GO TO 530 + 550 Y(NN) = TB + NZ = N - NN + IF (NN.EQ.1) RETURN + TB = TM*TB + TA + K = NN - 1 + Y(K) = TB + IF (NN.EQ.2) RETURN + DTM = DTM - 1.0D0 + TM = (DTM+FNF)*TRX + KM = K - 1 +C +C BACKWARD RECUR INDEXED +C + DO 560 I=1,KM + Y(K-1) = TM*Y(K) + Y(K+1) + DTM = DTM - 1.0D0 + TM = (DTM+FNF)*TRX + K = K - 1 + 560 CONTINUE + RETURN +C +C +C + 570 CONTINUE +C CALL XERMSG ('SLATEC', 'DBESI', +C + 'SCALING OPTION, KODE, NOT 1 OR 2.', 2, 1) + ierr=1 + RETURN + 580 CONTINUE +C CALL XERMSG ('SLATEC', 'DBESI', 'ORDER, ALPHA, LESS THAN ZERO.', +C + 2, 1) + ierr=1 + RETURN + 590 CONTINUE +C CALL XERMSG ('SLATEC', 'DBESI', 'N LESS THAN ONE.', 2, 1) + ierr=1 + RETURN + 600 CONTINUE +C CALL XERMSG ('SLATEC', 'DBESI', 'X LESS THAN ZERO.', 2, 1) + ierr=1 + RETURN + 610 CONTINUE +C CALL XERMSG ('SLATEC', 'DBESI', +C + 'OVERFLOW, X TOO LARGE FOR KODE = 1.', 6, 1) + ierr=2 + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/dbesi.lo b/modules/elementary_functions/src/fortran/slatec/dbesi.lo new file mode 100755 index 000000000..db72eb7f9 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbesi.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dbesi.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dbesi.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dbesi0.f b/modules/elementary_functions/src/fortran/slatec/dbesi0.f new file mode 100755 index 000000000..ef4e2c4ce --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/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/modules/elementary_functions/src/fortran/slatec/dbesi0.lo b/modules/elementary_functions/src/fortran/slatec/dbesi0.lo new file mode 100755 index 000000000..cdc317562 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbesi0.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dbesi0.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dbesi0.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dbesi1.f b/modules/elementary_functions/src/fortran/slatec/dbesi1.f new file mode 100755 index 000000000..0306c065e --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbesi1.f @@ -0,0 +1,83 @@ +*DECK DBESI1 + DOUBLE PRECISION FUNCTION DBESI1 (X) +C***BEGIN PROLOGUE DBESI1 +C***PURPOSE Compute the modified (hyperbolic) Bessel function of the +C first kind of order one. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C10B1 +C***TYPE DOUBLE PRECISION (BESI1-S, DBESI1-D) +C***KEYWORDS FIRST KIND, FNLIB, HYPERBOLIC BESSEL FUNCTION, +C MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C DBESI1(X) calculates the double precision modified (hyperbolic) +C Bessel function of the first kind of order one and double precision +C argument X. +C +C Series for BI1 on the interval 0. to 9.00000E+00 +C with weighted error 1.44E-32 +C log weighted error 31.84 +C significant figures required 31.45 +C decimal places required 32.46 +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, DBSI1E, 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 DBESI1 + DOUBLE PRECISION X, BI1CS(17), XMAX, XMIN, XSML, Y, D1MACH, + 1 DCSEVL, DBSI1E + LOGICAL FIRST + SAVE BI1CS, NTI1, XMIN, XSML, XMAX, FIRST + DATA BI1CS( 1) / -.1971713261 0998597316 1385032181 49 D-2 / + DATA BI1CS( 2) / +.4073488766 7546480608 1553936520 14 D+0 / + DATA BI1CS( 3) / +.3483899429 9959455866 2450377837 87 D-1 / + DATA BI1CS( 4) / +.1545394556 3001236038 5984010584 89 D-2 / + DATA BI1CS( 5) / +.4188852109 8377784129 4588320041 20 D-4 / + DATA BI1CS( 6) / +.7649026764 8362114741 9597039660 69 D-6 / + DATA BI1CS( 7) / +.1004249392 4741178689 1798080372 38 D-7 / + DATA BI1CS( 8) / +.9932207791 9238106481 3712980548 63 D-10 / + DATA BI1CS( 9) / +.7663801791 8447637275 2001716813 49 D-12 / + DATA BI1CS( 10) / +.4741418923 8167394980 3880919481 60 D-14 / + DATA BI1CS( 11) / +.2404114404 0745181799 8631720320 00 D-16 / + DATA BI1CS( 12) / +.1017150500 7093713649 1211007999 99 D-18 / + DATA BI1CS( 13) / +.3645093565 7866949458 4917333333 33 D-21 / + DATA BI1CS( 14) / +.1120574950 2562039344 8106666666 66 D-23 / + DATA BI1CS( 15) / +.2987544193 4468088832 0000000000 00 D-26 / + DATA BI1CS( 16) / +.6973231093 9194709333 3333333333 33 D-29 / + DATA BI1CS( 17) / +.1436794822 0620800000 0000000000 00 D-31 / + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DBESI1 + IF (FIRST) THEN + NTI1 = INITDS (BI1CS, 17, 0.1*REAL(D1MACH(3))) + XMIN = 2.0D0*D1MACH(1) + 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 + DBESI1 = 0.D0 + IF (Y.EQ.0.D0) RETURN +C + IF (Y .LE. XMIN) CALL XERMSG ('SLATEC', 'DBESI1', + + 'ABS(X) SO SMALL I1 UNDERFLOWS', 1, 1) + IF (Y.GT.XMIN) DBESI1 = 0.5D0*X + IF (Y.GT.XSML) DBESI1 = X*(0.875D0 + DCSEVL (Y*Y/4.5D0-1.D0, + 1 BI1CS, NTI1)) + RETURN +C + 20 IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'DBESI1', + + 'ABS(X) SO BIG I1 OVERFLOWS', 2, 2) +C + DBESI1 = EXP(Y) * DBSI1E(X) +C + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/dbesi1.lo b/modules/elementary_functions/src/fortran/slatec/dbesi1.lo new file mode 100755 index 000000000..43899a558 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbesi1.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dbesi1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dbesi1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dbesj.f b/modules/elementary_functions/src/fortran/slatec/dbesj.f new file mode 100755 index 000000000..75048c80c --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbesj.f @@ -0,0 +1,542 @@ +*DECK DBESJ + SUBROUTINE DBESJ (X, ALPHA, N, Y, NZ,ierr) +C***BEGIN PROLOGUE DBESJ +C***PURPOSE Compute an N member sequence of J Bessel functions +C J/SUB(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA +C and X. +C***LIBRARY SLATEC +C***CATEGORY C10A3 +C***TYPE DOUBLE PRECISION (BESJ-S, DBESJ-D) +C***KEYWORDS J BESSEL FUNCTION, SPECIAL FUNCTIONS +C***AUTHOR Amos, D. E., (SNLA) +C Daniel, S. L., (SNLA) +C Weston, M. K., (SNLA) +C***DESCRIPTION +C +C Abstract **** a double precision routine **** +C DBESJ computes an N member sequence of J Bessel functions +C J/sub(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA and X. +C A combination of the power series, the asymptotic expansion +C for X to infinity and the uniform asymptotic expansion for +C NU to infinity are applied over subdivisions of the (NU,X) +C plane. For values of (NU,X) not covered by one of these +C formulae, the order is incremented or decremented by integer +C values into a region where one of the formulae apply. Backward +C recursion is applied to reduce orders by integer values except +C where the entire sequence lies in the oscillatory region. In +C this case forward recursion is stable and values from the +C asymptotic expansion for X to infinity start the recursion +C when it is efficient to do so. Leading terms of the series and +C uniform expansion are tested for underflow. If a sequence is +C requested and the last member would underflow, the result is +C set to zero and the next lower order tried, etc., until a +C member comes on scale or all members are set to zero. +C Overflow cannot occur. +C +C The maximum number of significant digits obtainable +C is the smaller of 14 and the number of digits carried in +C double precision arithmetic. +C +C Description of Arguments +C +C Input X,ALPHA are double precision +C X - X .GE. 0.0D0 +C ALPHA - order of first member of the sequence, +C ALPHA .GE. 0.0D0 +C N - number of members in the sequence, N .GE. 1 +C +C Output Y is double precision +C Y - a vector whose first N components contain +C values for J/sub(ALPHA+K-1)/(X), K=1,...,N +C NZ - number of components of Y set to zero due to +C underflow, +C NZ=0 , normal return, computation completed +C NZ .NE. 0, last NZ components of Y set to zero, +C Y(K)=0.0D0, K=N-NZ+1,...,N. +C +C Error Conditions +C Improper input arguments - a fatal error +C Underflow - a non-fatal error (NZ .NE. 0) +C +C***REFERENCES D. E. Amos, S. L. Daniel and M. K. Weston, CDC 6600 +C subroutines IBESS and JBESS for Bessel functions +C I(NU,X) and J(NU,X), X .GE. 0, NU .GE. 0, ACM +C Transactions on Mathematical Software 3, (1977), +C pp. 76-92. +C F. W. J. Olver, Tables of Bessel Functions of Moderate +C or Large Orders, NPL Mathematical Tables 6, Her +C Majesty's Stationery Office, London, 1962. +C***ROUTINES CALLED D1MACH, DASYJY, DJAIRY, DLNGAM, I1MACH, XERMSG +C***REVISION HISTORY (YYMMDD) +C 750101 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 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DBESJ + EXTERNAL DJAIRY + INTEGER I,IALP,IDALP,IFLW,IN,INLIM,IS,I1,I2,K,KK,KM,KT,N,NN, + 1 NS,NZ + INTEGER I1MACH + DOUBLE PRECISION AK,AKM,ALPHA,ANS,AP,ARG,COEF,DALPHA,DFN,DTM, + 1 EARG,ELIM1,ETX,FIDAL,FLGJY,FN,FNF,FNI,FNP1,FNU, + 2 FNULIM,GLN,PDF,PIDT,PP,RDEN,RELB,RTTP,RTWO,RTX,RZDEN, + 3 S,SA,SB,SXO2,S1,S2,T,TA,TAU,TB,TEMP,TFN,TM,TOL, + 4 TOLLN,TRX,TX,T1,T2,WK,X,XO2,XO2L,Y,SLIM,RTOL + SAVE RTWO, PDF, RTTP, PIDT, PP, INLIM, FNULIM + DOUBLE PRECISION D1MACH, DLNGAM + DIMENSION Y(*), TEMP(3), FNULIM(2), PP(4), WK(7) + DATA RTWO,PDF,RTTP,PIDT / 1.34839972492648D+00, + 1 7.85398163397448D-01, 7.97884560802865D-01, 1.57079632679490D+00/ + DATA PP(1), PP(2), PP(3), PP(4) / 8.72909153935547D+00, + 1 2.65693932265030D-01, 1.24578576865586D-01, 7.70133747430388D-04/ + DATA INLIM / 150 / + DATA FNULIM(1), FNULIM(2) / 100.0D0, 60.0D0 / +C***FIRST EXECUTABLE STATEMENT DBESJ + ierr=0 + NZ = 0 + KT = 1 + NS=0 +C I1MACH(14) REPLACES I1MACH(11) IN A DOUBLE PRECISION CODE +C I1MACH(15) REPLACES I1MACH(12) IN A DOUBLE PRECISION CODE + TA = D1MACH(3) + TOL = MAX(TA,1.0D-15) + I1 = I1MACH(14) + 1 + I2 = I1MACH(15) + TB = D1MACH(5) + ELIM1 = -2.303D0*(I2*TB+3.0D0) + RTOL=1.0D0/TOL + SLIM=D1MACH(1)*RTOL*1.0D+3 +C TOLLN = -LN(TOL) + TOLLN = 2.303D0*TB*I1 + TOLLN = MIN(TOLLN,34.5388D0) + if ((N-1) .lt. 0) then + goto 720 + elseif ((N-1) .eq. 0) then + goto 10 + else + goto 20 + endif + 10 KT = 2 + 20 NN = N + if (X .lt. 0) then + goto 730 + elseif (X .eq. 0) then + goto 30 + else + goto 80 + endif + 30 if (ALPHA .lt. 0) then + goto 710 + elseif (ALPHA .eq. 0) then + goto 40 + else + goto 50 + endif + 40 Y(1) = 1.0D0 + IF (N.EQ.1) RETURN + I1 = 2 + GO TO 60 + 50 I1 = 1 + 60 DO 70 I=I1,N + Y(I) = 0.0D0 + 70 CONTINUE + RETURN + 80 CONTINUE + IF (ALPHA.LT.0.0D0) GO TO 710 +C + IALP = INT(ALPHA) + FNI = IALP + N - 1 + FNF = ALPHA - IALP + DFN = FNI + FNF + FNU = DFN + XO2 = X*0.5D0 + SXO2 = XO2*XO2 +C +C DECISION TREE FOR REGION WHERE SERIES, ASYMPTOTIC EXPANSION FOR X +C TO INFINITY AND ASYMPTOTIC EXPANSION FOR NU TO INFINITY ARE +C APPLIED. +C + IF (SXO2.LE.(FNU+1.0D0)) GO TO 90 + TA = MAX(20.0D0,FNU) + IF (X.GT.TA) GO TO 120 + IF (X.GT.12.0D0) GO TO 110 + XO2L = LOG(XO2) + NS = INT(SXO2-FNU) + 1 + GO TO 100 + 90 FN = FNU + FNP1 = FN + 1.0D0 + XO2L = LOG(XO2) + IS = KT + IF (X.LE.0.50D0) GO TO 330 + NS = 0 + 100 FNI = FNI + NS + DFN = FNI + FNF + FN = DFN + FNP1 = FN + 1.0D0 + IS = KT + IF (N-1+NS.GT.0) IS = 3 + GO TO 330 + 110 ANS = MAX(36.0D0-FNU,0.0D0) + NS = INT(ANS) + FNI = FNI + NS + DFN = FNI + FNF + FN = DFN + IS = KT + IF (N-1+NS.GT.0) IS = 3 + GO TO 130 + 120 CONTINUE + RTX = SQRT(X) + TAU = RTWO*RTX + TA = TAU + FNULIM(KT) + IF (FNU.LE.TA) GO TO 480 + FN = FNU + IS = KT +C +C UNIFORM ASYMPTOTIC EXPANSION FOR NU TO INFINITY +C + 130 CONTINUE + I1 = ABS(3-IS) + I1 = MAX(I1,1) + FLGJY = 1.0D0 + CALL DASYJY(DJAIRY,X,FN,FLGJY,I1,TEMP(IS),WK,IFLW) + IF(IFLW.NE.0) GO TO 380 + GO TO (320, 450, 620), IS + 310 TEMP(1) = TEMP(3) + KT = 1 + 320 IS = 2 + FNI = FNI - 1.0D0 + DFN = FNI + FNF + FN = DFN + IF(I1.EQ.2) GO TO 450 + GO TO 130 +C +C SERIES FOR (X/2)**2.LE.NU+1 +C + 330 CONTINUE + GLN = DLNGAM(FNP1) + ARG = FN*XO2L - GLN + IF (ARG.LT.(-ELIM1)) GO TO 400 + EARG = EXP(ARG) + 340 CONTINUE + S = 1.0D0 + IF (X.LT.TOL) GO TO 360 + AK = 3.0D0 + T2 = 1.0D0 + T = 1.0D0 + S1 = FN + DO 350 K=1,17 + S2 = T2 + S1 + T = -T*SXO2/S2 + S = S + T + IF (ABS(T).LT.TOL) GO TO 360 + T2 = T2 + AK + AK = AK + 2.0D0 + S1 = S1 + FN + 350 CONTINUE + 360 CONTINUE + TEMP(IS) = S*EARG + GO TO (370, 450, 610), IS + 370 EARG = EARG*FN/XO2 + FNI = FNI - 1.0D0 + DFN = FNI + FNF + FN = DFN + IS = 2 + GO TO 340 +C +C SET UNDERFLOW VALUE AND UPDATE PARAMETERS +C UNDERFLOW CAN ONLY OCCUR FOR NS=0 SINCE THE ORDER MUST BE LARGER +C THAN 36. THEREFORE, NS NEE NOT BE TESTED. +C + 380 Y(NN) = 0.0D0 + NN = NN - 1 + FNI = FNI - 1.0D0 + DFN = FNI + FNF + FN = DFN + if ((NN-1) .lt. 0) then + goto 440 + elseif ((NN-1) .eq. 0) then + goto 390 + else + goto 130 + endif + 390 KT = 2 + IS = 2 + GO TO 130 + 400 Y(NN) = 0.0D0 + NN = NN - 1 + FNP1 = FN + FNI = FNI - 1.0D0 + DFN = FNI + FNF + FN = DFN + if ((NN-1) .lt. 0) then + goto 440 + elseif ((NN-1) .eq. 0) then + goto 410 + else + goto 420 + endif + 410 KT = 2 + IS = 2 + 420 IF (SXO2.LE.FNP1) GO TO 430 + GO TO 130 + 430 ARG = ARG - XO2L + LOG(FNP1) + IF (ARG.LT.(-ELIM1)) GO TO 400 + GO TO 330 + 440 NZ = N - NN + RETURN +C +C BACKWARD RECURSION SECTION +C + 450 CONTINUE + IF(NS.NE.0) GO TO 451 + NZ = N - NN + IF (KT.EQ.2) GO TO 470 +C BACKWARD RECUR FROM INDEX ALPHA+NN-1 TO ALPHA + Y(NN) = TEMP(1) + Y(NN-1) = TEMP(2) + IF (NN.EQ.2) RETURN + 451 CONTINUE + TRX = 2.0D0/X + DTM = FNI + TM = (DTM+FNF)*TRX + AK=1.0D0 + TA=TEMP(1) + TB=TEMP(2) + IF(ABS(TA).GT.SLIM) GO TO 455 + TA=TA*RTOL + TB=TB*RTOL + AK=TOL + 455 CONTINUE + KK=2 + IN=NS-1 + IF(IN.EQ.0) GO TO 690 + IF(NS.NE.0) GO TO 670 + K=NN-2 + DO 460 I=3,NN + S=TB + TB = TM*TB - TA + TA=S + Y(K)=TB*AK + DTM = DTM - 1.0D0 + TM = (DTM+FNF)*TRX + K = K - 1 + 460 CONTINUE + RETURN + 470 Y(1) = TEMP(2) + RETURN +C +C ASYMPTOTIC EXPANSION FOR X TO INFINITY WITH FORWARD RECURSION IN +C OSCILLATORY REGION X.GT.MAX(20, NU), PROVIDED THE LAST MEMBER +C OF THE SEQUENCE IS ALSO IN THE REGION. +C + 480 CONTINUE + IN = INT(ALPHA-TAU+2.0D0) + IF (IN.LE.0) GO TO 490 + IDALP = IALP - IN - 1 + KT = 1 + GO TO 500 + 490 CONTINUE + IDALP = IALP + IN = 0 + 500 IS = KT + FIDAL = IDALP + DALPHA = FIDAL + FNF + ARG = X - PIDT*DALPHA - PDF + SA = SIN(ARG) + SB = COS(ARG) + COEF = RTTP/RTX + ETX = 8.0D0*X + 510 CONTINUE + DTM = FIDAL + FIDAL + DTM = DTM*DTM + TM = 0.0D0 + IF (FIDAL.EQ.0.0D0 .AND. ABS(FNF).LT.TOL) GO TO 520 + TM = 4.0D0*FNF*(FIDAL+FIDAL+FNF) + 520 CONTINUE + TRX = DTM - 1.0D0 + T2 = (TRX+TM)/ETX + S2 = T2 + RELB = TOL*ABS(T2) + T1 = ETX + S1 = 1.0D0 + FN = 1.0D0 + AK = 8.0D0 + DO 530 K=1,13 + T1 = T1 + ETX + FN = FN + AK + TRX = DTM - FN + AP = TRX + TM + T2 = -T2*AP/T1 + S1 = S1 + T2 + T1 = T1 + ETX + AK = AK + 8.0D0 + FN = FN + AK + TRX = DTM - FN + AP = TRX + TM + T2 = T2*AP/T1 + S2 = S2 + T2 + IF (ABS(T2).LE.RELB) GO TO 540 + AK = AK + 8.0D0 + 530 CONTINUE + 540 TEMP(IS) = COEF*(S1*SB-S2*SA) + IF(IS.EQ.2) GO TO 560 + FIDAL = FIDAL + 1.0D0 + DALPHA = FIDAL + FNF + IS = 2 + TB = SA + SA = -SB + SB = TB + GO TO 510 +C +C FORWARD RECURSION SECTION +C + 560 IF (KT.EQ.2) GO TO 470 + S1 = TEMP(1) + S2 = TEMP(2) + TX = 2.0D0/X + TM = DALPHA*TX + IF (IN.EQ.0) GO TO 580 +C +C FORWARD RECUR TO INDEX ALPHA +C + DO 570 I=1,IN + S = S2 + S2 = TM*S2 - S1 + TM = TM + TX + S1 = S + 570 CONTINUE + IF (NN.EQ.1) GO TO 600 + S = S2 + S2 = TM*S2 - S1 + TM = TM + TX + S1 = S + 580 CONTINUE +C +C FORWARD RECUR FROM INDEX ALPHA TO ALPHA+N-1 +C + Y(1) = S1 + Y(2) = S2 + IF (NN.EQ.2) RETURN + DO 590 I=3,NN + Y(I) = TM*Y(I-1) - Y(I-2) + TM = TM + TX + 590 CONTINUE + RETURN + 600 Y(1) = S2 + RETURN +C +C BACKWARD RECURSION WITH NORMALIZATION BY +C ASYMPTOTIC EXPANSION FOR NU TO INFINITY OR POWER SERIES. +C + 610 CONTINUE +C COMPUTATION OF LAST ORDER FOR SERIES NORMALIZATION + AKM = MAX(3.0D0-FN,0.0D0) + KM = INT(AKM) + TFN = FN + KM + TA = (GLN+TFN-0.9189385332D0-0.0833333333D0/TFN)/(TFN+0.5D0) + TA = XO2L - TA + TB = -(1.0D0-1.5D0/TFN)/TFN + AKM = TOLLN/(-TA+SQRT(TA*TA-TOLLN*TB)) + 1.5D0 + IN = KM + INT(AKM) + GO TO 660 + 620 CONTINUE +C COMPUTATION OF LAST ORDER FOR ASYMPTOTIC EXPANSION NORMALIZATION + GLN = WK(3) + WK(2) + IF (WK(6).GT.30.0D0) GO TO 640 + RDEN = (PP(4)*WK(6)+PP(3))*WK(6) + 1.0D0 + RZDEN = PP(1) + PP(2)*WK(6) + TA = RZDEN/RDEN + IF (WK(1).LT.0.10D0) GO TO 630 + TB = GLN/WK(5) + GO TO 650 + 630 TB=(1.259921049D0+(0.1679894730D0+0.0887944358D0*WK(1))*WK(1)) + 1 /WK(7) + GO TO 650 + 640 CONTINUE + TA = 0.5D0*TOLLN/WK(4) + TA=((0.0493827160D0*TA-0.1111111111D0)*TA+0.6666666667D0)*TA*WK(6) + IF (WK(1).LT.0.10D0) GO TO 630 + TB = GLN/WK(5) + 650 IN = INT(TA/TB+1.5D0) + IF (IN.GT.INLIM) GO TO 310 + 660 CONTINUE + DTM = FNI + IN + TRX = 2.0D0/X + TM = (DTM+FNF)*TRX + TA = 0.0D0 + TB = TOL + KK = 1 + AK=1.0D0 + 670 CONTINUE +C +C BACKWARD RECUR UNINDEXED +C + DO 680 I=1,IN + S = TB + TB = TM*TB - TA + TA = S + DTM = DTM - 1.0D0 + TM = (DTM+FNF)*TRX + 680 CONTINUE +C NORMALIZATION + IF (KK.NE.1) GO TO 690 + S=TEMP(3) + SA=TA/TB + TA=S + TB=S + IF(ABS(S).GT.SLIM) GO TO 685 + TA=TA*RTOL + TB=TB*RTOL + AK=TOL + 685 CONTINUE + TA=TA*SA + KK = 2 + IN = NS + IF (NS.NE.0) GO TO 670 + 690 Y(NN) = TB*AK + NZ = N - NN + IF (NN.EQ.1) RETURN + K = NN - 1 + S=TB + TB = TM*TB - TA + TA=S + Y(K)=TB*AK + IF (NN.EQ.2) RETURN + DTM = DTM - 1.0D0 + TM = (DTM+FNF)*TRX + K=NN-2 +C +C BACKWARD RECUR INDEXED +C + DO 700 I=3,NN + S=TB + TB = TM*TB - TA + TA=S + Y(K)=TB*AK + DTM = DTM - 1.0D0 + TM = (DTM+FNF)*TRX + K = K - 1 + 700 CONTINUE + RETURN +C +C +C + 710 CONTINUE + ierr=1 +c CALL XERMSG ('SLATEC', 'DBESJ', 'ORDER, ALPHA, LESS THAN ZERO.', +c + 2, 1) + RETURN + 720 CONTINUE + ierr=1 +c CALL XERMSG ('SLATEC', 'DBESJ', 'N LESS THAN ONE.', 2, 1) + RETURN + 730 CONTINUE + ierr=1 +c CALL XERMSG ('SLATEC', 'DBESJ', 'X LESS THAN ZERO.', 2, 1) + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/dbesj.lo b/modules/elementary_functions/src/fortran/slatec/dbesj.lo new file mode 100755 index 000000000..fc7c05960 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbesj.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dbesj.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dbesj.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dbesj0.f b/modules/elementary_functions/src/fortran/slatec/dbesj0.f new file mode 100755 index 000000000..4d4a0077f --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/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/modules/elementary_functions/src/fortran/slatec/dbesj0.lo b/modules/elementary_functions/src/fortran/slatec/dbesj0.lo new file mode 100755 index 000000000..5a8e085ad --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbesj0.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dbesj0.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dbesj0.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dbesj1.f b/modules/elementary_functions/src/fortran/slatec/dbesj1.f new file mode 100755 index 000000000..c6ef17f45 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/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/modules/elementary_functions/src/fortran/slatec/dbesj1.lo b/modules/elementary_functions/src/fortran/slatec/dbesj1.lo new file mode 100755 index 000000000..0e05c2c3a --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbesj1.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dbesj1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dbesj1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dbesk.f b/modules/elementary_functions/src/fortran/slatec/dbesk.f new file mode 100755 index 000000000..cb70207c3 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbesk.f @@ -0,0 +1,286 @@ +*DECK DBESK + SUBROUTINE DBESK (X, FNU, KODE, N, Y, NZ,ierr) +C***BEGIN PROLOGUE DBESK +C***PURPOSE Implement forward recursion on the three term recursion +C relation for a sequence of non-negative order Bessel +C functions K/SUB(FNU+I-1)/(X), or scaled Bessel functions +C EXP(X)*K/SUB(FNU+I-1)/(X), I=1,...,N for real, positive +C X and non-negative orders FNU. +C***LIBRARY SLATEC +C***CATEGORY C10B3 +C***TYPE DOUBLE PRECISION (BESK-S, DBESK-D) +C***KEYWORDS K BESSEL FUNCTION, SPECIAL FUNCTIONS +C***AUTHOR Amos, D. E., (SNLA) +C***DESCRIPTION +C +C Abstract **** a double precision routine **** +C DBESK implements forward recursion on the three term +C recursion relation for a sequence of non-negative order Bessel +C functions K/sub(FNU+I-1)/(X), or scaled Bessel functions +C EXP(X)*K/sub(FNU+I-1)/(X), I=1,..,N for real X .GT. 0.0D0 and +C non-negative orders FNU. If FNU .LT. NULIM, orders FNU and +C FNU+1 are obtained from DBSKNU to start the recursion. If +C FNU .GE. NULIM, the uniform asymptotic expansion is used for +C orders FNU and FNU+1 to start the recursion. NULIM is 35 or +C 70 depending on whether N=1 or N .GE. 2. Under and overflow +C tests are made on the leading term of the asymptotic expansion +C before any extensive computation is done. +C +C The maximum number of significant digits obtainable +C is the smaller of 14 and the number of digits carried in +C double precision arithmetic. +C +C Description of Arguments +C +C Input X,FNU are double precision +C X - X .GT. 0.0D0 +C FNU - order of the initial K function, FNU .GE. 0.0D0 +C KODE - a parameter to indicate the scaling option +C KODE=1 returns Y(I)= K/sub(FNU+I-1)/(X), +C I=1,...,N +C KODE=2 returns Y(I)=EXP(X)*K/sub(FNU+I-1)/(X), +C I=1,...,N +C N - number of members in the sequence, N .GE. 1 +C +C Output Y is double precision +C Y - a vector whose first N components contain values +C for the sequence +C Y(I)= k/sub(FNU+I-1)/(X), I=1,...,N or +C Y(I)=EXP(X)*K/sub(FNU+I-1)/(X), I=1,...,N +C depending on KODE +C NZ - number of components of Y set to zero due to +C underflow with KODE=1, +C NZ=0 , normal return, computation completed +C NZ .NE. 0, first NZ components of Y set to zero +C due to underflow, Y(I)=0.0D0, I=1,...,NZ +C +C Error Conditions +C Improper input arguments - a fatal error +C Overflow - a fatal error +C Underflow with KODE=1 - a non-fatal error (NZ .NE. 0) +C +C***REFERENCES F. W. J. Olver, Tables of Bessel Functions of Moderate +C or Large Orders, NPL Mathematical Tables 6, Her +C Majesty's Stationery Office, London, 1962. +C N. M. Temme, On the numerical evaluation of the modified +C Bessel function of the third kind, Journal of +C Computational Physics 19, (1975), pp. 324-337. +C***ROUTINES CALLED D1MACH, DASYIK, DBESK0, DBESK1, DBSK0E, DBSK1E, +C DBSKNU, I1MACH, XERMSG +C***REVISION HISTORY (YYMMDD) +C 790201 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 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DBESK +C + INTEGER I, J, K, KODE, MZ, N, NB, ND, NN, NUD, NULIM, NZ + INTEGER I1MACH + DOUBLE PRECISION CN,DNU,ELIM,ETX,FLGIK,FN,FNN,FNU,GLN,GNU,RTZ, + 1 S, S1, S2, T, TM, TRX, W, X, XLIM, Y, ZN + DOUBLE PRECISION DBESK0, DBESK1, DBSK1E, DBSK0E, D1MACH + DIMENSION W(2), NULIM(2), Y(*) + SAVE NULIM + DATA NULIM(1),NULIM(2) / 35 , 70 / +C***FIRST EXECUTABLE STATEMENT DBESK + ierr=0 + NN = -I1MACH(15) + ELIM = 2.303D0*(NN*D1MACH(5)-3.0D0) + XLIM = D1MACH(1)*1.0D+3 + IF (KODE.LT.1 .OR. KODE.GT.2) GO TO 280 + IF (FNU.LT.0.0D0) GO TO 290 + IF (X.LE.0.0D0) GO TO 300 + IF (X.LT.XLIM) GO TO 320 + IF (N.LT.1) GO TO 310 + ETX = KODE - 1 +C +C ND IS A DUMMY VARIABLE FOR N +C GNU IS A DUMMY VARIABLE FOR FNU +C NZ = NUMBER OF UNDERFLOWS ON KODE=1 +C + ND = N + NZ = 0 + NUD = INT(FNU) + DNU = FNU - NUD + GNU = FNU + NN = MIN(2,ND) + FN = FNU + N - 1 + FNN = FN + IF (FN.LT.2.0D0) GO TO 150 +C +C OVERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION) +C FOR THE LAST ORDER, FNU+N-1.GE.NULIM +C + ZN = X/FN + IF (ZN.EQ.0.0D0) GO TO 320 + RTZ = SQRT(1.0D0+ZN*ZN) + GLN = LOG((1.0D0+RTZ)/ZN) + T = RTZ*(1.0D0-ETX) + ETX/(ZN+RTZ) + CN = -FN*(T-GLN) + IF (CN.GT.ELIM) GO TO 320 + IF (NUD.LT.NULIM(NN)) GO TO 30 + IF (NN.EQ.1) GO TO 20 + 10 CONTINUE +C +C UNDERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION) +C FOR THE FIRST ORDER, FNU.GE.NULIM +C + FN = GNU + ZN = X/FN + RTZ = SQRT(1.0D0+ZN*ZN) + GLN = LOG((1.0D0+RTZ)/ZN) + T = RTZ*(1.0D0-ETX) + ETX/(ZN+RTZ) + CN = -FN*(T-GLN) + 20 CONTINUE + IF (CN.LT.-ELIM) GO TO 230 +C +C ASYMPTOTIC EXPANSION FOR ORDERS FNU AND FNU+1.GE.NULIM +C + FLGIK = -1.0D0 + CALL DASYIK(X,GNU,KODE,FLGIK,RTZ,CN,NN,Y) + IF (NN.EQ.1) GO TO 240 + TRX = 2.0D0/X + TM = (GNU+GNU+2.0D0)/X + GO TO 130 +C + 30 CONTINUE + IF (KODE.EQ.2) GO TO 40 +C +C UNDERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION IN X) +C FOR ORDER DNU +C + IF (X.GT.ELIM) GO TO 230 + 40 CONTINUE + IF (DNU.NE.0.0D0) GO TO 80 + IF (KODE.EQ.2) GO TO 50 + S1 = DBESK0(X) + GO TO 60 + 50 S1 = DBSK0E(X) + 60 CONTINUE + IF (NUD.EQ.0 .AND. ND.EQ.1) GO TO 120 + IF (KODE.EQ.2) GO TO 70 + S2 = DBESK1(X) + GO TO 90 + 70 S2 = DBSK1E(X) + GO TO 90 + 80 CONTINUE + NB = 2 + IF (NUD.EQ.0 .AND. ND.EQ.1) NB = 1 + CALL DBSKNU(X, DNU, KODE, NB, W, NZ) + S1 = W(1) + IF (NB.EQ.1) GO TO 120 + S2 = W(2) + 90 CONTINUE + TRX = 2.0D0/X + TM = (DNU+DNU+2.0D0)/X +C FORWARD RECUR FROM DNU TO FNU+1 TO GET Y(1) AND Y(2) + IF (ND.EQ.1) NUD = NUD - 1 + IF (NUD.GT.0) GO TO 100 + IF (ND.GT.1) GO TO 120 + S1 = S2 + GO TO 120 + 100 CONTINUE + DO 110 I=1,NUD + S = S2 + S2 = TM*S2 + S1 + S1 = S + TM = TM + TRX + 110 CONTINUE + IF (ND.EQ.1) S1 = S2 + 120 CONTINUE + Y(1) = S1 + IF (ND.EQ.1) GO TO 240 + Y(2) = S2 + 130 CONTINUE + IF (ND.EQ.2) GO TO 240 +C FORWARD RECUR FROM FNU+2 TO FNU+N-1 + DO 140 I=3,ND + Y(I) = TM*Y(I-1) + Y(I-2) + TM = TM + TRX + 140 CONTINUE + GO TO 240 +C + 150 CONTINUE +C UNDERFLOW TEST FOR KODE=1 + IF (KODE.EQ.2) GO TO 160 + IF (X.GT.ELIM) GO TO 230 + 160 CONTINUE +C OVERFLOW TEST + IF (FN.LE.1.0D0) GO TO 170 + IF (-FN*(LOG(X)-0.693D0).GT.ELIM) GO TO 320 + 170 CONTINUE + IF (DNU.EQ.0.0D0) GO TO 180 + CALL DBSKNU(X, FNU, KODE, ND, Y, MZ) + GO TO 240 + 180 CONTINUE + J = NUD + IF (J.EQ.1) GO TO 210 + J = J + 1 + IF (KODE.EQ.2) GO TO 190 + Y(J) = DBESK0(X) + GO TO 200 + 190 Y(J) = DBSK0E(X) + 200 IF (ND.EQ.1) GO TO 240 + J = J + 1 + 210 IF (KODE.EQ.2) GO TO 220 + Y(J) = DBESK1(X) + GO TO 240 + 220 Y(J) = DBSK1E(X) + GO TO 240 +C +C UPDATE PARAMETERS ON UNDERFLOW +C + 230 CONTINUE + NUD = NUD + 1 + ND = ND - 1 + IF (ND.EQ.0) GO TO 240 + NN = MIN(2,ND) + GNU = GNU + 1.0D0 + IF (FNN.LT.2.0D0) GO TO 230 + IF (NUD.LT.NULIM(NN)) GO TO 230 + GO TO 10 + 240 CONTINUE + NZ = N - ND + IF (NZ.EQ.0) RETURN + IF (ND.EQ.0) GO TO 260 + DO 250 I=1,ND + J = N - I + 1 + K = ND - I + 1 + Y(J) = Y(K) + 250 CONTINUE + 260 CONTINUE + DO 270 I=1,NZ + Y(I) = 0.0D0 + 270 CONTINUE + RETURN +C +C +C + 280 CONTINUE +C CALL XERMSG ('SLATEC', 'DBESK', +C + 'SCALING OPTION, KODE, NOT 1 OR 2', 2, 1) + ierr=1 + RETURN + 290 CONTINUE +C CALL XERMSG ('SLATEC', 'DBESK', 'ORDER, FNU, LESS THAN ZERO', 2, +C + 1) + ierr=1 + RETURN + 300 CONTINUE +C CALL XERMSG ('SLATEC', 'DBESK', 'X LESS THAN OR EQUAL TO ZERO', +C + 2, 1) + ierr=1 + RETURN + 310 CONTINUE +C CALL XERMSG ('SLATEC', 'DBESK', 'N LESS THAN ONE', 2, 1) + ierr=1 + RETURN + 320 CONTINUE +C CALL XERMSG ('SLATEC', 'DBESK', +C + 'OVERFLOW, FNU OR N TOO LARGE OR X TOO SMALL', 6, 1) + ierr=2 + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/dbesk.lo b/modules/elementary_functions/src/fortran/slatec/dbesk.lo new file mode 100755 index 000000000..f2f108848 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbesk.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dbesk.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dbesk.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dbesk0.f b/modules/elementary_functions/src/fortran/slatec/dbesk0.f new file mode 100755 index 000000000..99d61e8c3 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/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/modules/elementary_functions/src/fortran/slatec/dbesk0.lo b/modules/elementary_functions/src/fortran/slatec/dbesk0.lo new file mode 100755 index 000000000..f6d40e224 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbesk0.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dbesk0.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dbesk0.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dbesk1.f b/modules/elementary_functions/src/fortran/slatec/dbesk1.f new file mode 100755 index 000000000..262abe3c4 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbesk1.f @@ -0,0 +1,86 @@ +*DECK DBESK1 + DOUBLE PRECISION FUNCTION DBESK1 (X) +C***BEGIN PROLOGUE DBESK1 +C***PURPOSE Compute the modified (hyperbolic) Bessel function of the +C third kind of order one. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C10B1 +C***TYPE DOUBLE PRECISION (BESK1-S, DBESK1-D) +C***KEYWORDS FNLIB, HYPERBOLIC BESSEL FUNCTION, +C MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS, +C THIRD KIND +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C DBESK1(X) calculates the double precision modified (hyperbolic) +C Bessel function of the third kind of order one for double precision +C argument X. The argument must be large enough that the result does +C not overflow and small enough that the result does not underflow. +C +C Series for BK1 on the interval 0. to 4.00000E+00 +C with weighted error 9.16E-32 +C log weighted error 31.04 +C significant figures required 30.61 +C decimal places required 31.64 +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, DBESI1, DBSK1E, 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 DBESK1 + DOUBLE PRECISION X, BK1CS(16), XMAX, XMAXT, XMIN, XSML, Y, + 1 D1MACH, DCSEVL, DBESI1, DBSK1E + LOGICAL FIRST + SAVE BK1CS, NTK1, XMIN, XSML, XMAX, FIRST + DATA BK1CS( 1) / +.2530022733 8947770532 5311208685 33 D-1 / + DATA BK1CS( 2) / -.3531559607 7654487566 7238316918 01 D+0 / + DATA BK1CS( 3) / -.1226111808 2265714823 4790679300 42 D+0 / + DATA BK1CS( 4) / -.6975723859 6398643501 8129202960 83 D-2 / + DATA BK1CS( 5) / -.1730288957 5130520630 1765073689 79 D-3 / + DATA BK1CS( 6) / -.2433406141 5659682349 6007350301 64 D-5 / + DATA BK1CS( 7) / -.2213387630 7347258558 3152525451 26 D-7 / + DATA BK1CS( 8) / -.1411488392 6335277610 9583302126 08 D-9 / + DATA BK1CS( 9) / -.6666901694 1993290060 8537512643 73 D-12 / + DATA BK1CS( 10) / -.2427449850 5193659339 2631968648 53 D-14 / + DATA BK1CS( 11) / -.7023863479 3862875971 7837971200 00 D-17 / + DATA BK1CS( 12) / -.1654327515 5100994675 4910293333 33 D-19 / + DATA BK1CS( 13) / -.3233834745 9944491991 8933333333 33 D-22 / + DATA BK1CS( 14) / -.5331275052 9265274999 4666666666 66 D-25 / + DATA BK1CS( 15) / -.7513040716 2157226666 6666666666 66 D-28 / + DATA BK1CS( 16) / -.9155085717 6541866666 6666666666 66 D-31 / + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DBESK1 + IF (FIRST) THEN + NTK1 = INITDS (BK1CS, 16, 0.1*REAL(D1MACH(3))) + XMIN = EXP(MAX(LOG(D1MACH(1)), -LOG(D1MACH(2))) + 0.01D0) + 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', 'DBESK1', + + 'X IS ZERO OR NEGATIVE', 2, 2) + IF (X.GT.2.0D0) GO TO 20 +C + IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'DBESK1', + + 'X SO SMALL K1 OVERFLOWS', 3, 2) + Y = 0.D0 + IF (X.GT.XSML) Y = X*X + DBESK1 = LOG(0.5D0*X)*DBESI1(X) + (0.75D0 + DCSEVL (.5D0*Y-1.D0, + 1 BK1CS, NTK1))/X + RETURN +C + 20 DBESK1 = 0.D0 + IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'DBESK1', + + 'X SO BIG K1 UNDERFLOWS', 1, 1) + IF (X.GT.XMAX) RETURN +C + DBESK1 = EXP(-X) * DBSK1E(X) +C + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/dbesk1.lo b/modules/elementary_functions/src/fortran/slatec/dbesk1.lo new file mode 100755 index 000000000..ed2c246c0 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbesk1.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dbesk1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dbesk1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dbesy.f b/modules/elementary_functions/src/fortran/slatec/dbesy.f new file mode 100755 index 000000000..2f223cb8f --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbesy.f @@ -0,0 +1,208 @@ +*DECK DBESY + SUBROUTINE DBESY (X, FNU, N, Y,ierr) +C***BEGIN PROLOGUE DBESY +C***PURPOSE Implement forward recursion on the three term recursion +C relation for a sequence of non-negative order Bessel +C functions Y/SUB(FNU+I-1)/(X), I=1,...,N for real, positive +C X and non-negative orders FNU. +C***LIBRARY SLATEC +C***CATEGORY C10A3 +C***TYPE DOUBLE PRECISION (BESY-S, DBESY-D) +C***KEYWORDS SPECIAL FUNCTIONS, Y BESSEL FUNCTION +C***AUTHOR Amos, D. E., (SNLA) +C***DESCRIPTION +C +C Abstract **** a double precision routine **** +C DBESY implements forward recursion on the three term +C recursion relation for a sequence of non-negative order Bessel +C functions Y/sub(FNU+I-1)/(X), I=1,N for real X .GT. 0.0D0 and +C non-negative orders FNU. If FNU .LT. NULIM, orders FNU and +C FNU+1 are obtained from DBSYNU which computes by a power +C series for X .LE. 2, the K Bessel function of an imaginary +C argument for 2 .LT. X .LE. 20 and the asymptotic expansion for +C X .GT. 20. +C +C If FNU .GE. NULIM, the uniform asymptotic expansion is coded +C in DASYJY for orders FNU and FNU+1 to start the recursion. +C NULIM is 70 or 100 depending on whether N=1 or N .GE. 2. An +C overflow test is made on the leading term of the asymptotic +C expansion before any extensive computation is done. +C +C The maximum number of significant digits obtainable +C is the smaller of 14 and the number of digits carried in +C double precision arithmetic. +C +C Description of Arguments +C +C Input +C X - X .GT. 0.0D0 +C FNU - order of the initial Y function, FNU .GE. 0.0D0 +C N - number of members in the sequence, N .GE. 1 +C +C Output +C Y - a vector whose first N components contain values +C for the sequence Y(I)=Y/sub(FNU+I-1)/(X), I=1,N. +C +C Error Conditions +C Improper input arguments - a fatal error +C Overflow - a fatal error +C +C***REFERENCES F. W. J. Olver, Tables of Bessel Functions of Moderate +C or Large Orders, NPL Mathematical Tables 6, Her +C Majesty's Stationery Office, London, 1962. +C N. M. Temme, On the numerical evaluation of the modified +C Bessel function of the third kind, Journal of +C Computational Physics 19, (1975), pp. 324-337. +C N. M. Temme, On the numerical evaluation of the ordinary +C Bessel function of the second kind, Journal of +C Computational Physics 21, (1976), pp. 343-350. +C***ROUTINES CALLED D1MACH, DASYJY, DBESY0, DBESY1, DBSYNU, DYAIRY, +C XERMSG +C***REVISION HISTORY (YYMMDD) +C 800501 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 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DBESY +C + EXTERNAL DYAIRY + INTEGER I, IFLW, J, N, NB, ND, NN, NUD, NULIM + INTEGER I1MACH + DOUBLE PRECISION AZN,CN,DNU,ELIM,FLGJY,FN,FNU,RAN,S,S1,S2,TM,TRX, + 1 W,WK,W2N,X,XLIM,XXN,Y + DOUBLE PRECISION DBESY0, DBESY1, D1MACH + DIMENSION W(2), NULIM(2), Y(*), WK(7) + SAVE NULIM + DATA NULIM(1),NULIM(2) / 70 , 100 / +C***FIRST EXECUTABLE STATEMENT DBESY + ierr=0 + NN = -I1MACH(15) + ELIM = 2.303D0*(NN*D1MACH(5)-3.0D0) + XLIM = D1MACH(1)*1.0D+3 + IF (FNU.LT.0.0D0) GO TO 140 + IF (X.LE.0.0D0) GO TO 150 + IF (X.LT.XLIM) GO TO 170 + IF (N.LT.1) GO TO 160 +C +C ND IS A DUMMY VARIABLE FOR N +C + ND = N + NUD = INT(FNU) + DNU = FNU - NUD + NN = MIN(2,ND) + FN = FNU + N - 1 + IF (FN.LT.2.0D0) GO TO 100 +C +C OVERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION) +C FOR THE LAST ORDER, FNU+N-1.GE.NULIM +C + XXN = X/FN + W2N = 1.0D0-XXN*XXN + IF(W2N.LE.0.0D0) GO TO 10 + RAN = SQRT(W2N) + AZN = LOG((1.0D0+RAN)/XXN) - RAN + CN = FN*AZN + IF(CN.GT.ELIM) GO TO 170 + 10 CONTINUE + IF (NUD.LT.NULIM(NN)) GO TO 20 +C +C ASYMPTOTIC EXPANSION FOR ORDERS FNU AND FNU+1.GE.NULIM +C + FLGJY = -1.0D0 + CALL DASYJY(DYAIRY,X,FNU,FLGJY,NN,Y,WK,IFLW) + IF(IFLW.NE.0) GO TO 170 + IF (NN.EQ.1) RETURN + TRX = 2.0D0/X + TM = (FNU+FNU+2.0D0)/X + GO TO 80 +C + 20 CONTINUE + IF (DNU.NE.0.0D0) GO TO 30 + S1 = DBESY0(X) + IF (NUD.EQ.0 .AND. ND.EQ.1) GO TO 70 + S2 = DBESY1(X) + GO TO 40 + 30 CONTINUE + NB = 2 + IF (NUD.EQ.0 .AND. ND.EQ.1) NB = 1 + CALL DBSYNU(X, DNU, NB, W) + S1 = W(1) + IF (NB.EQ.1) GO TO 70 + S2 = W(2) + 40 CONTINUE + TRX = 2.0D0/X + TM = (DNU+DNU+2.0D0)/X +C FORWARD RECUR FROM DNU TO FNU+1 TO GET Y(1) AND Y(2) + IF (ND.EQ.1) NUD = NUD - 1 + IF (NUD.GT.0) GO TO 50 + IF (ND.GT.1) GO TO 70 + S1 = S2 + GO TO 70 + 50 CONTINUE + DO 60 I=1,NUD + S = S2 + S2 = TM*S2 - S1 + S1 = S + TM = TM + TRX + 60 CONTINUE + IF (ND.EQ.1) S1 = S2 + 70 CONTINUE + Y(1) = S1 + IF (ND.EQ.1) RETURN + Y(2) = S2 + 80 CONTINUE + IF (ND.EQ.2) RETURN +C FORWARD RECUR FROM FNU+2 TO FNU+N-1 + DO 90 I=3,ND + Y(I) = TM*Y(I-1) - Y(I-2) + TM = TM + TRX + 90 CONTINUE + RETURN +C + 100 CONTINUE +C OVERFLOW TEST + IF (FN.LE.1.0D0) GO TO 110 + IF (-FN*(LOG(X)-0.693D0).GT.ELIM) GO TO 170 + 110 CONTINUE + IF (DNU.EQ.0.0D0) GO TO 120 + CALL DBSYNU(X, FNU, ND, Y) + RETURN + 120 CONTINUE + J = NUD + IF (J.EQ.1) GO TO 130 + J = J + 1 + Y(J) = DBESY0(X) + IF (ND.EQ.1) RETURN + J = J + 1 + 130 CONTINUE + Y(J) = DBESY1(X) + IF (ND.EQ.1) RETURN + TRX = 2.0D0/X + TM = TRX + GO TO 80 +C +C +C + 140 CONTINUE + ierr=1 +c CALL XERMSG ('SLATEC', 'DBESY', 'ORDER, FNU, LESS THAN ZERO', 2, +c + 1) + RETURN + 150 CONTINUE + ierr=1 +c CALL XERMSG ('SLATEC', 'DBESY', 'X LESS THAN OR EQUAL TO ZERO', +c + 2, 1) + RETURN + 160 CONTINUE + ierr=1 +c CALL XERMSG ('SLATEC', 'DBESY', 'N LESS THAN ONE', 2, 1) + RETURN + 170 CONTINUE + ierr=2 +c CALL XERMSG ('SLATEC', 'DBESY', +c + 'OVERFLOW, FNU OR N TOO LARGE OR X TOO SMALL', 6, 1) + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/dbesy.lo b/modules/elementary_functions/src/fortran/slatec/dbesy.lo new file mode 100755 index 000000000..60afd4a98 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbesy.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dbesy.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dbesy.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dbesy0.f b/modules/elementary_functions/src/fortran/slatec/dbesy0.f new file mode 100755 index 000000000..57c10421b --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbesy0.f @@ -0,0 +1,78 @@ +*DECK DBESY0 + DOUBLE PRECISION FUNCTION DBESY0 (X) +C***BEGIN PROLOGUE DBESY0 +C***PURPOSE Compute the Bessel function of the second kind of order +C zero. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C10A1 +C***TYPE DOUBLE PRECISION (BESY0-S, DBESY0-D) +C***KEYWORDS BESSEL FUNCTION, FNLIB, ORDER ZERO, SECOND KIND, +C SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C DBESY0(X) calculates the double precision Bessel function of the +C second kind of order zero for double precision argument X. +C +C Series for BY0 on the interval 0. to 1.60000E+01 +C with weighted error 8.14E-32 +C log weighted error 31.09 +C significant figures required 30.31 +C decimal places required 31.73 +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, D9B0MP, DBESJ0, 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 DBESY0 + DOUBLE PRECISION X, BY0CS(19), AMPL, THETA, TWODPI, XSML, + 1 Y, D1MACH, DCSEVL, DBESJ0 + LOGICAL FIRST + SAVE BY0CS, TWODPI, NTY0, XSML, FIRST + DATA BY0CS( 1) / -.1127783939 2865573217 9398054602 8 D-1 / + DATA BY0CS( 2) / -.1283452375 6042034604 8088453183 8 D+0 / + DATA BY0CS( 3) / -.1043788479 9794249365 8176227661 8 D+0 / + DATA BY0CS( 4) / +.2366274918 3969695409 2415926461 3 D-1 / + DATA BY0CS( 5) / -.2090391647 7004862391 9622395034 2 D-2 / + DATA BY0CS( 6) / +.1039754539 3905725209 9924657638 1 D-3 / + DATA BY0CS( 7) / -.3369747162 4239720967 1877534503 7 D-5 / + DATA BY0CS( 8) / +.7729384267 6706671585 2136721637 1 D-7 / + DATA BY0CS( 9) / -.1324976772 6642595914 4347606896 4 D-8 / + DATA BY0CS( 10) / +.1764823261 5404527921 0038936315 8 D-10 / + DATA BY0CS( 11) / -.1881055071 5801962006 0282301206 9 D-12 / + DATA BY0CS( 12) / +.1641865485 3661495027 9223718574 9 D-14 / + DATA BY0CS( 13) / -.1195659438 6046060857 4599100672 0 D-16 / + DATA BY0CS( 14) / +.7377296297 4401858424 9411242666 6 D-19 / + DATA BY0CS( 15) / -.3906843476 7104373307 4090666666 6 D-21 / + DATA BY0CS( 16) / +.1795503664 4361579498 2912000000 0 D-23 / + DATA BY0CS( 17) / -.7229627125 4480104789 3333333333 3 D-26 / + DATA BY0CS( 18) / +.2571727931 6351685973 3333333333 3 D-28 / + DATA BY0CS( 19) / -.8141268814 1636949333 3333333333 3 D-31 / + DATA TWODPI / 0.6366197723 6758134307 5535053490 057 D0 / + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DBESY0 + IF (FIRST) THEN + NTY0 = INITDS (BY0CS, 19, 0.1*REAL(D1MACH(3))) + XSML = SQRT(4.0D0*D1MACH(3)) + ENDIF + FIRST = .FALSE. +C + IF (X .LE. 0.D0) CALL XERMSG ('SLATEC', 'DBESY0', + + 'X IS ZERO OR NEGATIVE', 1, 2) + IF (X.GT.4.0D0) GO TO 20 +C + Y = 0.D0 + IF (X.GT.XSML) Y = X*X + DBESY0 = TWODPI*LOG(0.5D0*X)*DBESJ0(X) + .375D0 + DCSEVL ( + 1 .125D0*Y-1.D0, BY0CS, NTY0) + RETURN +C + 20 CALL D9B0MP (X, AMPL, THETA) + DBESY0 = AMPL * SIN(THETA) + RETURN +C + END diff --git a/modules/elementary_functions/src/fortran/slatec/dbesy0.lo b/modules/elementary_functions/src/fortran/slatec/dbesy0.lo new file mode 100755 index 000000000..5c855cfc0 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbesy0.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dbesy0.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dbesy0.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dbesy1.f b/modules/elementary_functions/src/fortran/slatec/dbesy1.f new file mode 100755 index 000000000..c26c73280 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbesy1.f @@ -0,0 +1,84 @@ +*DECK DBESY1 + DOUBLE PRECISION FUNCTION DBESY1 (X) +C***BEGIN PROLOGUE DBESY1 +C***PURPOSE Compute the Bessel function of the second kind of order +C one. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C10A1 +C***TYPE DOUBLE PRECISION (BESY1-S, DBESY1-D) +C***KEYWORDS BESSEL FUNCTION, FNLIB, ORDER ONE, SECOND KIND, +C SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C DBESY1(X) calculates the double precision Bessel function of the +C second kind of order for double precision argument X. +C +C Series for BY1 on the interval 0. to 1.60000E+01 +C with weighted error 8.65E-33 +C log weighted error 32.06 +C significant figures required 32.17 +C decimal places required 32.71 +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, D9B1MP, DBESJ1, 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 DBESY1 + DOUBLE PRECISION X, BY1CS(20), AMPL, THETA, TWODPI, XMIN, XSML, + 1 Y, D1MACH, DCSEVL, DBESJ1 + LOGICAL FIRST + SAVE BY1CS, TWODPI, NTY1, XMIN, XSML, FIRST + DATA BY1CS( 1) / +.3208047100 6119086293 2352018628 015 D-1 / + DATA BY1CS( 2) / +.1262707897 4335004495 3431725999 727 D+1 / + DATA BY1CS( 3) / +.6499961899 9231750009 7490637314 144 D-2 / + DATA BY1CS( 4) / -.8936164528 8605041165 3144160009 712 D-1 / + DATA BY1CS( 5) / +.1325088122 1757095451 2375510370 043 D-1 / + DATA BY1CS( 6) / -.8979059119 6483523775 3039508298 105 D-3 / + DATA BY1CS( 7) / +.3647361487 9583067824 2287368165 349 D-4 / + DATA BY1CS( 8) / -.1001374381 6660005554 9075523845 295 D-5 / + DATA BY1CS( 9) / +.1994539657 3901739703 1159372421 243 D-7 / + DATA BY1CS( 10) / -.3023065601 8033816728 4799332520 743 D-9 / + DATA BY1CS( 11) / +.3609878156 9478119611 6252914242 474 D-11 / + DATA BY1CS( 12) / -.3487488297 2875824241 4552947409 066 D-13 / + DATA BY1CS( 13) / +.2783878971 5591766581 3507698517 333 D-15 / + DATA BY1CS( 14) / -.1867870968 6194876876 6825352533 333 D-17 / + DATA BY1CS( 15) / +.1068531533 9116825975 7070336000 000 D-19 / + DATA BY1CS( 16) / -.5274721956 6844822894 3872000000 000 D-22 / + DATA BY1CS( 17) / +.2270199403 1556641437 0133333333 333 D-24 / + DATA BY1CS( 18) / -.8595390353 9452310869 3333333333 333 D-27 / + DATA BY1CS( 19) / +.2885404379 8337945600 0000000000 000 D-29 / + DATA BY1CS( 20) / -.8647541138 9371733333 3333333333 333 D-32 / + DATA TWODPI / 0.6366197723 6758134307 5535053490 057 D0 / + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DBESY1 + IF (FIRST) THEN + NTY1 = INITDS (BY1CS, 20, 0.1*REAL(D1MACH(3))) +C + XMIN = 1.571D0 * EXP (MAX(LOG(D1MACH(1)), -LOG(D1MACH(2))) + + 1 0.01D0) + XSML = SQRT(4.0D0*D1MACH(3)) + ENDIF + FIRST = .FALSE. +C + IF (X .LE. 0.D0) CALL XERMSG ('SLATEC', 'DBESY1', + + 'X IS ZERO OR NEGATIVE', 1, 2) + IF (X.GT.4.0D0) GO TO 20 +C + IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'DBESY1', + + 'X SO SMALL Y1 OVERFLOWS', 3, 2) + Y = 0.D0 + IF (X.GT.XSML) Y = X*X + DBESY1 = TWODPI * LOG(0.5D0*X)*DBESJ1(X) + (0.5D0 + + 1 DCSEVL (.125D0*Y-1.D0, BY1CS, NTY1))/X + RETURN +C + 20 CALL D9B1MP (X, AMPL, THETA) + DBESY1 = AMPL * SIN(THETA) + RETURN +C + END diff --git a/modules/elementary_functions/src/fortran/slatec/dbesy1.lo b/modules/elementary_functions/src/fortran/slatec/dbesy1.lo new file mode 100755 index 000000000..d14c7057b --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbesy1.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dbesy1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dbesy1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dbkias.f b/modules/elementary_functions/src/fortran/slatec/dbkias.f new file mode 100755 index 000000000..6e276e526 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbkias.f @@ -0,0 +1,261 @@ +*DECK DBKIAS + SUBROUTINE DBKIAS (X, N, KTRMS, T, ANS, IND, MS, GMRN, H, IERR) +C***BEGIN PROLOGUE DBKIAS +C***SUBSIDIARY +C***PURPOSE Subsidiary to DBSKIN +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (BKIAS-S, DBKIAS-D) +C***AUTHOR Amos, D. E., (SNLA) +C***DESCRIPTION +C +C DBKIAS computes repeated integrals of the K0 Bessel function +C by the asymptotic expansion +C +C***SEE ALSO DBSKIN +C***ROUTINES CALLED D1MACH, DBDIFF, DGAMRN, DHKSEQ +C***REVISION HISTORY (YYMMDD) +C 820601 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890911 Removed unnecessary intrinsics. (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 DBKIAS + INTEGER I, II, IND, J, JMI, JN, K, KK, KM, KTRMS, MM, MP, MS, N, + * IERR + DOUBLE PRECISION ANS, B, BND, DEN1, DEN2, DEN3, ER, ERR, FJ, FK, + * FLN, FM1, GMRN, G1, GS, H, HN, HRTPI, RAT, RG1, RXP, RZ, RZX, S, + * SS, SUMI, SUMJ, T, TOL, V, W, X, XP, Z + DOUBLE PRECISION DGAMRN, D1MACH + DIMENSION B(120), XP(16), S(31), H(*), V(52), W(52), T(50), + * BND(15) + SAVE B, BND, HRTPI +C----------------------------------------------------------------------- +C COEFFICIENTS OF POLYNOMIAL P(J-1,X), J=1,15 +C----------------------------------------------------------------------- + DATA B(1), B(2), B(3), B(4), B(5), B(6), B(7), B(8), B(9), B(10), + * B(11), B(12), B(13), B(14), B(15), B(16), B(17), B(18), B(19), + * B(20), B(21), B(22), B(23), B(24) /1.00000000000000000D+00, + * 1.00000000000000000D+00,-2.00000000000000000D+00, + * 1.00000000000000000D+00,-8.00000000000000000D+00, + * 6.00000000000000000D+00,1.00000000000000000D+00, + * -2.20000000000000000D+01,5.80000000000000000D+01, + * -2.40000000000000000D+01,1.00000000000000000D+00, + * -5.20000000000000000D+01,3.28000000000000000D+02, + * -4.44000000000000000D+02,1.20000000000000000D+02, + * 1.00000000000000000D+00,-1.14000000000000000D+02, + * 1.45200000000000000D+03,-4.40000000000000000D+03, + * 3.70800000000000000D+03,-7.20000000000000000D+02, + * 1.00000000000000000D+00,-2.40000000000000000D+02, + * 5.61000000000000000D+03/ + DATA B(25), B(26), B(27), B(28), B(29), B(30), B(31), B(32), + * B(33), B(34), B(35), B(36), B(37), B(38), B(39), B(40), B(41), + * B(42), B(43), B(44), B(45), B(46), B(47), B(48) + * /-3.21200000000000000D+04,5.81400000000000000D+04, + * -3.39840000000000000D+04,5.04000000000000000D+03, + * 1.00000000000000000D+00,-4.94000000000000000D+02, + * 1.99500000000000000D+04,-1.95800000000000000D+05, + * 6.44020000000000000D+05,-7.85304000000000000D+05, + * 3.41136000000000000D+05,-4.03200000000000000D+04, + * 1.00000000000000000D+00,-1.00400000000000000D+03, + * 6.72600000000000000D+04,-1.06250000000000000D+06, + * 5.76550000000000000D+06,-1.24400640000000000D+07, + * 1.10262960000000000D+07,-3.73392000000000000D+06, + * 3.62880000000000000D+05,1.00000000000000000D+00, + * -2.02600000000000000D+03,2.18848000000000000D+05/ + DATA B(49), B(50), B(51), B(52), B(53), B(54), B(55), B(56), + * B(57), B(58), B(59), B(60), B(61), B(62), B(63), B(64), B(65), + * B(66), B(67), B(68), B(69), B(70), B(71), B(72) + * /-5.32616000000000000D+06,4.47650000000000000D+07, + * -1.55357384000000000D+08,2.38904904000000000D+08, + * -1.62186912000000000D+08,4.43390400000000000D+07, + * -3.62880000000000000D+06,1.00000000000000000D+00, + * -4.07200000000000000D+03,6.95038000000000000D+05, + * -2.52439040000000000D+07,3.14369720000000000D+08, + * -1.64838430400000000D+09,4.00269508800000000D+09, + * -4.64216395200000000D+09,2.50748121600000000D+09, + * -5.68356480000000000D+08,3.99168000000000000D+07, + * 1.00000000000000000D+00,-8.16600000000000000D+03, + * 2.17062600000000000D+06,-1.14876376000000000D+08, + * 2.05148277600000000D+09,-1.55489607840000000D+10/ + DATA B(73), B(74), B(75), B(76), B(77), B(78), B(79), B(80), + * B(81), B(82), B(83), B(84), B(85), B(86), B(87), B(88), B(89), + * B(90), B(91), B(92), B(93), B(94), B(95), B(96) + * /5.60413987840000000D+10,-1.01180433024000000D+11, + * 9.21997902240000000D+10,-4.07883018240000000D+10, + * 7.82771904000000000D+09,-4.79001600000000000D+08, + * 1.00000000000000000D+00,-1.63560000000000000D+04, + * 6.69969600000000000D+06,-5.07259276000000000D+08, + * 1.26698177760000000D+10,-1.34323420224000000D+11, + * 6.87720046384000000D+11,-1.81818864230400000D+12, + * 2.54986547342400000D+12,-1.88307966182400000D+12, + * 6.97929436800000000D+11,-1.15336085760000000D+11, + * 6.22702080000000000D+09,1.00000000000000000D+00, + * -3.27380000000000000D+04,2.05079880000000000D+07, + * -2.18982980800000000D+09,7.50160522280000000D+10/ + DATA B(97), B(98), B(99), B(100), B(101), B(102), B(103), B(104), + * B(105), B(106), B(107), B(108), B(109), B(110), B(111), B(112), + * B(113), B(114), B(115), B(116), B(117), B(118) + * /-1.08467651241600000D+12,7.63483214939200000D+12, + * -2.82999100661120000D+13,5.74943734645920000D+13, + * -6.47283751398720000D+13,3.96895780558080000D+13, + * -1.25509040179200000D+13,1.81099255680000000D+12, + * -8.71782912000000000D+10,1.00000000000000000D+00, + * -6.55040000000000000D+04,6.24078900000000000D+07, + * -9.29252692000000000D+09,4.29826006340000000D+11, + * -8.30844432796800000D+12,7.83913848313120000D+13, + * -3.94365587815520000D+14,1.11174747256968000D+15, + * -1.79717122069056000D+15,1.66642448627145600D+15, + * -8.65023253219584000D+14,2.36908271543040000D+14/ + DATA B(119), B(120) /-3.01963769856000000D+13, + * 1.30767436800000000D+12/ +C----------------------------------------------------------------------- +C BOUNDS B(M,K) , K=M-3 +C----------------------------------------------------------------------- + DATA BND(1), BND(2), BND(3), BND(4), BND(5), BND(6), BND(7), + * BND(8), BND(9), BND(10), BND(11), BND(12), BND(13), BND(14), + * BND(15) /1.0D0,1.0D0,1.0D0,1.0D0,3.10D0,5.18D0,11.7D0,29.8D0, + * 90.4D0,297.0D0,1070.0D0,4290.0D0,18100.0D0,84700.0D0,408000.0D0/ + DATA HRTPI /8.86226925452758014D-01/ +C +C***FIRST EXECUTABLE STATEMENT DBKIAS + IERR=0 + TOL = MAX(D1MACH(4),1.0D-18) + FLN = N + RZ = 1.0D0/(X+FLN) + RZX = X*RZ + Z = 0.5D0*(X+FLN) + IF (IND.GT.1) GO TO 10 + GMRN = DGAMRN(Z) + 10 CONTINUE + GS = HRTPI*GMRN + G1 = GS + GS + RG1 = 1.0D0/G1 + GMRN = (RZ+RZ)/GMRN + IF (IND.GT.1) GO TO 70 +C----------------------------------------------------------------------- +C EVALUATE ERROR FOR M=MS +C----------------------------------------------------------------------- + HN = 0.5D0*FLN + DEN2 = KTRMS + KTRMS + N + DEN3 = DEN2 - 2.0D0 + DEN1 = X + DEN2 + ERR = RG1*(X+X)/(DEN1-1.0D0) + IF (N.EQ.0) GO TO 20 + RAT = 1.0D0/(FLN*FLN) + 20 CONTINUE + IF (KTRMS.EQ.0) GO TO 30 + FJ = KTRMS + RAT = 0.25D0/(HRTPI*DEN3*SQRT(FJ)) + 30 CONTINUE + ERR = ERR*RAT + FJ = -3.0D0 + DO 50 J=1,15 + IF (J.LE.5) ERR = ERR/DEN1 + FM1 = MAX(1.0D0,FJ) + FJ = FJ + 1.0D0 + ER = BND(J)*ERR + IF (KTRMS.EQ.0) GO TO 40 + ER = ER/FM1 + IF (ER.LT.TOL) GO TO 60 + IF (J.GE.5) ERR = ERR/DEN3 + GO TO 50 + 40 CONTINUE + ER = ER*(1.0D0+HN/FM1) + IF (ER.LT.TOL) GO TO 60 + IF (J.GE.5) ERR = ERR/FLN + 50 CONTINUE + GO TO 200 + 60 CONTINUE + MS = J + 70 CONTINUE + MM = MS + MS + MP = MM + 1 +C----------------------------------------------------------------------- +C H(K)=(-Z)**(K)*(PSI(K-1,Z)-PSI(K-1,Z+0.5))/GAMMA(K) , K=1,2,...,MM +C----------------------------------------------------------------------- + IF (IND.GT.1) GO TO 80 + CALL DHKSEQ(Z, MM, H, IERR) + GO TO 100 + 80 CONTINUE + RAT = Z/(Z-0.5D0) + RXP = RAT + DO 90 I=1,MM + H(I) = RXP*(1.0D0-H(I)) + RXP = RXP*RAT + 90 CONTINUE + 100 CONTINUE +C----------------------------------------------------------------------- +C SCALED S SEQUENCE +C----------------------------------------------------------------------- + S(1) = 1.0D0 + FK = 1.0D0 + DO 120 K=2,MP + SS = 0.0D0 + KM = K - 1 + I = KM + DO 110 J=1,KM + SS = SS + S(J)*H(I) + I = I - 1 + 110 CONTINUE + S(K) = SS/FK + FK = FK + 1.0D0 + 120 CONTINUE +C----------------------------------------------------------------------- +C SCALED S-TILDA SEQUENCE +C----------------------------------------------------------------------- + IF (KTRMS.EQ.0) GO TO 160 + FK = 0.0D0 + SS = 0.0D0 + RG1 = RG1/Z + DO 130 K=1,KTRMS + V(K) = Z/(Z+FK) + W(K) = T(K)*V(K) + SS = SS + W(K) + FK = FK + 1.0D0 + 130 CONTINUE + S(1) = S(1) - SS*RG1 + DO 150 I=2,MP + SS = 0.0D0 + DO 140 K=1,KTRMS + W(K) = W(K)*V(K) + SS = SS + W(K) + 140 CONTINUE + S(I) = S(I) - SS*RG1 + 150 CONTINUE + 160 CONTINUE +C----------------------------------------------------------------------- +C SUM ON J +C----------------------------------------------------------------------- + SUMJ = 0.0D0 + JN = 1 + RXP = 1.0D0 + XP(1) = 1.0D0 + DO 190 J=1,MS + JN = JN + J - 1 + XP(J+1) = XP(J)*RZX + RXP = RXP*RZ +C----------------------------------------------------------------------- +C SUM ON I +C----------------------------------------------------------------------- + SUMI = 0.0D0 + II = JN + DO 180 I=1,J + JMI = J - I + 1 + KK = J + I + 1 + DO 170 K=1,JMI + V(K) = S(KK)*XP(K) + KK = KK + 1 + 170 CONTINUE + CALL DBDIFF(JMI, V) + SUMI = SUMI + B(II)*V(JMI)*XP(I+1) + II = II + 1 + 180 CONTINUE + SUMJ = SUMJ + SUMI*RXP + 190 CONTINUE + ANS = GS*(S(1)-SUMJ) + RETURN + 200 CONTINUE + IERR=2 + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/dbkias.lo b/modules/elementary_functions/src/fortran/slatec/dbkias.lo new file mode 100755 index 000000000..00f151151 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbkias.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dbkias.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dbkias.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dbkisr.f b/modules/elementary_functions/src/fortran/slatec/dbkisr.f new file mode 100755 index 000000000..5c57b2390 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbkisr.f @@ -0,0 +1,87 @@ +*DECK DBKISR + SUBROUTINE DBKISR (X, N, SUM, IERR) +C***BEGIN PROLOGUE DBKISR +C***SUBSIDIARY +C***PURPOSE Subsidiary to DBSKIN +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (BKISR-S, DBKISR-D) +C***AUTHOR Amos, D. E., (SNLA) +C***DESCRIPTION +C +C DBKISR computes repeated integrals of the K0 Bessel function +C by the series for N=0,1, and 2. +C +C***SEE ALSO DBSKIN +C***ROUTINES CALLED D1MACH, DPSIXN +C***REVISION HISTORY (YYMMDD) +C 820601 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890911 Removed unnecessary intrinsics. (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 DBKISR + INTEGER I, IERR, K, KK, KKN, K1, N, NP + DOUBLE PRECISION AK, ATOL, BK, C, FK, FN, HX, HXS, POL, PR, SUM, + * TKP, TOL, TRM, X, XLN + DOUBLE PRECISION DPSIXN, D1MACH + DIMENSION C(2) + SAVE C +C + DATA C(1), C(2) /1.57079632679489662D+00,1.0D0/ +C***FIRST EXECUTABLE STATEMENT DBKISR + IERR=0 + TOL = MAX(D1MACH(4),1.0D-18) + IF (X.LT.TOL) GO TO 50 + PR = 1.0D0 + POL = 0.0D0 + IF (N.EQ.0) GO TO 20 + DO 10 I=1,N + POL = -POL*X + C(I) + PR = PR*X/I + 10 CONTINUE + 20 CONTINUE + HX = X*0.5D0 + HXS = HX*HX + XLN = LOG(HX) + NP = N + 1 + TKP = 3.0D0 + FK = 2.0D0 + FN = N + BK = 4.0D0 + AK = 2.0D0/((FN+1.0D0)*(FN+2.0D0)) + SUM = AK*(DPSIXN(N+3)-DPSIXN(3)+DPSIXN(2)-XLN) + ATOL = SUM*TOL*0.75D0 + DO 30 K=2,20 + AK = AK*(HXS/BK)*((TKP+1.0D0)/(TKP+FN+1.0D0))*(TKP/(TKP+FN)) + K1 = K + 1 + KK = K1 + K + KKN = KK + N + TRM = (DPSIXN(K1)+DPSIXN(KKN)-DPSIXN(KK)-XLN)*AK + SUM = SUM + TRM + IF (ABS(TRM).LE.ATOL) GO TO 40 + TKP = TKP + 2.0D0 + BK = BK + TKP + FK = FK + 1.0D0 + 30 CONTINUE + GO TO 80 + 40 CONTINUE + SUM = (SUM*HXS+DPSIXN(NP)-XLN)*PR + IF (N.EQ.1) SUM = -SUM + SUM = POL + SUM + RETURN +C----------------------------------------------------------------------- +C SMALL X CASE, X.LT.WORD TOLERANCE +C----------------------------------------------------------------------- + 50 CONTINUE + IF (N.GT.0) GO TO 60 + HX = X*0.5D0 + SUM = DPSIXN(1) - LOG(HX) + RETURN + 60 CONTINUE + SUM = C(N) + RETURN + 80 CONTINUE + IERR=2 + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/dbkisr.lo b/modules/elementary_functions/src/fortran/slatec/dbkisr.lo new file mode 100755 index 000000000..dd670f25d --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbkisr.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dbkisr.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dbkisr.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dbsi0e.f b/modules/elementary_functions/src/fortran/slatec/dbsi0e.f new file mode 100755 index 000000000..441f9333d --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/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/modules/elementary_functions/src/fortran/slatec/dbsi0e.lo b/modules/elementary_functions/src/fortran/slatec/dbsi0e.lo new file mode 100755 index 000000000..0e2c0d318 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbsi0e.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dbsi0e.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dbsi0e.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dbsi1e.f b/modules/elementary_functions/src/fortran/slatec/dbsi1e.f new file mode 100755 index 000000000..e3d573996 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbsi1e.f @@ -0,0 +1,218 @@ +*DECK DBSI1E + DOUBLE PRECISION FUNCTION DBSI1E (X) +C***BEGIN PROLOGUE DBSI1E +C***PURPOSE Compute the exponentially scaled modified (hyperbolic) +C Bessel function of the first kind of order one. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C10B1 +C***TYPE DOUBLE PRECISION (BESI1E-S, DBSI1E-D) +C***KEYWORDS EXPONENTIALLY SCALED, FIRST KIND, FNLIB, +C HYPERBOLIC BESSEL FUNCTION, MODIFIED BESSEL FUNCTION, +C ORDER ONE, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C DBSI1E(X) calculates the double precision exponentially scaled +C modified (hyperbolic) Bessel function of the first kind of order +C one for double precision argument X. The result is I1(X) +C multiplied by EXP(-ABS(X)). +C +C Series for BI1 on the interval 0. to 9.00000E+00 +C with weighted error 1.44E-32 +C log weighted error 31.84 +C significant figures required 31.45 +C decimal places required 32.46 +C +C Series for AI1 on the interval 1.25000E-01 to 3.33333E-01 +C with weighted error 2.81E-32 +C log weighted error 31.55 +C significant figures required 29.93 +C decimal places required 32.38 +C +C Series for AI12 on the interval 0. to 1.25000E-01 +C with weighted error 1.83E-32 +C log weighted error 31.74 +C significant figures required 29.97 +C decimal places required 32.66 +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***END PROLOGUE DBSI1E + DOUBLE PRECISION X, BI1CS(17), AI1CS(46), AI12CS(69), XMIN, + 1 XSML, Y, D1MACH, DCSEVL + LOGICAL FIRST + SAVE BI1CS, AI1CS, AI12CS, NTI1, NTAI1, NTAI12, XMIN, XSML, + 1 FIRST + DATA BI1CS( 1) / -.1971713261 0998597316 1385032181 49 D-2 / + DATA BI1CS( 2) / +.4073488766 7546480608 1553936520 14 D+0 / + DATA BI1CS( 3) / +.3483899429 9959455866 2450377837 87 D-1 / + DATA BI1CS( 4) / +.1545394556 3001236038 5984010584 89 D-2 / + DATA BI1CS( 5) / +.4188852109 8377784129 4588320041 20 D-4 / + DATA BI1CS( 6) / +.7649026764 8362114741 9597039660 69 D-6 / + DATA BI1CS( 7) / +.1004249392 4741178689 1798080372 38 D-7 / + DATA BI1CS( 8) / +.9932207791 9238106481 3712980548 63 D-10 / + DATA BI1CS( 9) / +.7663801791 8447637275 2001716813 49 D-12 / + DATA BI1CS( 10) / +.4741418923 8167394980 3880919481 60 D-14 / + DATA BI1CS( 11) / +.2404114404 0745181799 8631720320 00 D-16 / + DATA BI1CS( 12) / +.1017150500 7093713649 1211007999 99 D-18 / + DATA BI1CS( 13) / +.3645093565 7866949458 4917333333 33 D-21 / + DATA BI1CS( 14) / +.1120574950 2562039344 8106666666 66 D-23 / + DATA BI1CS( 15) / +.2987544193 4468088832 0000000000 00 D-26 / + DATA BI1CS( 16) / +.6973231093 9194709333 3333333333 33 D-29 / + DATA BI1CS( 17) / +.1436794822 0620800000 0000000000 00 D-31 / + DATA AI1CS( 1) / -.2846744181 8814786741 0037246830 7 D-1 / + DATA AI1CS( 2) / -.1922953231 4432206510 4444877497 9 D-1 / + DATA AI1CS( 3) / -.6115185857 9437889822 5624991778 5 D-3 / + DATA AI1CS( 4) / -.2069971253 3502277088 8282377797 9 D-4 / + DATA AI1CS( 5) / +.8585619145 8107255655 3694467313 8 D-5 / + DATA AI1CS( 6) / +.1049498246 7115908625 1745399786 0 D-5 / + DATA AI1CS( 7) / -.2918338918 4479022020 9343232669 7 D-6 / + DATA AI1CS( 8) / -.1559378146 6317390001 6068096907 7 D-7 / + DATA AI1CS( 9) / +.1318012367 1449447055 2530287390 9 D-7 / + DATA AI1CS( 10) / -.1448423418 1830783176 3913446781 5 D-8 / + DATA AI1CS( 11) / -.2908512243 9931420948 2504099301 0 D-9 / + DATA AI1CS( 12) / +.1266388917 8753823873 1115969040 3 D-9 / + DATA AI1CS( 13) / -.1664947772 9192206706 2417839858 0 D-10 / + DATA AI1CS( 14) / -.1666653644 6094329760 9593715499 9 D-11 / + DATA AI1CS( 15) / +.1242602414 2907682652 3216847201 7 D-11 / + DATA AI1CS( 16) / -.2731549379 6724323972 5146142863 3 D-12 / + DATA AI1CS( 17) / +.2023947881 6458037807 0026268898 1 D-13 / + DATA AI1CS( 18) / +.7307950018 1168836361 9869812612 3 D-14 / + DATA AI1CS( 19) / -.3332905634 4046749438 1377861713 3 D-14 / + DATA AI1CS( 20) / +.7175346558 5129537435 4225466567 0 D-15 / + DATA AI1CS( 21) / -.6982530324 7962563558 5062922365 6 D-16 / + DATA AI1CS( 22) / -.1299944201 5627607600 6044608058 7 D-16 / + DATA AI1CS( 23) / +.8120942864 2427988920 5467834286 0 D-17 / + DATA AI1CS( 24) / -.2194016207 4107368981 5626664378 3 D-17 / + DATA AI1CS( 25) / +.3630516170 0296548482 7986093233 4 D-18 / + DATA AI1CS( 26) / -.1695139772 4391041663 0686679039 9 D-19 / + DATA AI1CS( 27) / -.1288184829 8979078071 1688253822 2 D-19 / + DATA AI1CS( 28) / +.5694428604 9670527801 0999107310 9 D-20 / + DATA AI1CS( 29) / -.1459597009 0904800565 4550990028 7 D-20 / + DATA AI1CS( 30) / +.2514546010 6757173140 8469133448 5 D-21 / + DATA AI1CS( 31) / -.1844758883 1391248181 6040002901 3 D-22 / + DATA AI1CS( 32) / -.6339760596 2279486419 2860979199 9 D-23 / + DATA AI1CS( 33) / +.3461441102 0310111111 0814662656 0 D-23 / + DATA AI1CS( 34) / -.1017062335 3713935475 9654102357 3 D-23 / + DATA AI1CS( 35) / +.2149877147 0904314459 6250077866 6 D-24 / + DATA AI1CS( 36) / -.3045252425 2386764017 4620617386 6 D-25 / + DATA AI1CS( 37) / +.5238082144 7212859821 7763498666 6 D-27 / + DATA AI1CS( 38) / +.1443583107 0893824464 1678950399 9 D-26 / + DATA AI1CS( 39) / -.6121302074 8900427332 0067071999 9 D-27 / + DATA AI1CS( 40) / +.1700011117 4678184183 4918980266 6 D-27 / + DATA AI1CS( 41) / -.3596589107 9842441585 3521578666 6 D-28 / + DATA AI1CS( 42) / +.5448178578 9484185766 5051306666 6 D-29 / + DATA AI1CS( 43) / -.2731831789 6890849891 6256426666 6 D-30 / + DATA AI1CS( 44) / -.1858905021 7086007157 7190399999 9 D-30 / + DATA AI1CS( 45) / +.9212682974 5139334411 2776533333 3 D-31 / + DATA AI1CS( 46) / -.2813835155 6535611063 7083306666 6 D-31 / + DATA AI12CS( 1) / +.2857623501 8280120474 4984594846 9 D-1 / + DATA AI12CS( 2) / -.9761097491 3614684077 6516445730 2 D-2 / + DATA AI12CS( 3) / -.1105889387 6262371629 1256921277 5 D-3 / + DATA AI12CS( 4) / -.3882564808 8776903934 5654477627 4 D-5 / + DATA AI12CS( 5) / -.2512236237 8702089252 9452002212 1 D-6 / + DATA AI12CS( 6) / -.2631468846 8895195068 3705236523 2 D-7 / + DATA AI12CS( 7) / -.3835380385 9642370220 4500678796 8 D-8 / + DATA AI12CS( 8) / -.5589743462 1965838068 6811252222 9 D-9 / + DATA AI12CS( 9) / -.1897495812 3505412344 9892503323 8 D-10 / + DATA AI12CS( 10) / +.3252603583 0154882385 5508067994 9 D-10 / + DATA AI12CS( 11) / +.1412580743 6613781331 6336633284 6 D-10 / + DATA AI12CS( 12) / +.2035628544 1470895072 2452613684 0 D-11 / + DATA AI12CS( 13) / -.7198551776 2459085120 9258989044 6 D-12 / + DATA AI12CS( 14) / -.4083551111 0921973182 2849963969 1 D-12 / + DATA AI12CS( 15) / -.2101541842 7726643130 1984572746 2 D-13 / + DATA AI12CS( 16) / +.4272440016 7119513542 9778833699 7 D-13 / + DATA AI12CS( 17) / +.1042027698 4128802764 1741449994 8 D-13 / + DATA AI12CS( 18) / -.3814403072 4370078047 6707253539 6 D-14 / + DATA AI12CS( 19) / -.1880354775 5107824485 1273453396 3 D-14 / + DATA AI12CS( 20) / +.3308202310 9209282827 3190335240 5 D-15 / + DATA AI12CS( 21) / +.2962628997 6459501390 6854654205 2 D-15 / + DATA AI12CS( 22) / -.3209525921 9934239587 7837353288 7 D-16 / + DATA AI12CS( 23) / -.4650305368 4893583255 7128281897 9 D-16 / + DATA AI12CS( 24) / +.4414348323 0717079499 4611375964 1 D-17 / + DATA AI12CS( 25) / +.7517296310 8421048054 2545808029 5 D-17 / + DATA AI12CS( 26) / -.9314178867 3268833756 8484784515 7 D-18 / + DATA AI12CS( 27) / -.1242193275 1948909561 1678448869 7 D-17 / + DATA AI12CS( 28) / +.2414276719 4548484690 0515390217 6 D-18 / + DATA AI12CS( 29) / +.2026944384 0532851789 7192286069 2 D-18 / + DATA AI12CS( 30) / -.6394267188 2690977870 4391988681 1 D-19 / + DATA AI12CS( 31) / -.3049812452 3730958960 8488450357 1 D-19 / + DATA AI12CS( 32) / +.1612841851 6514802251 3462230769 1 D-19 / + DATA AI12CS( 33) / +.3560913964 3099250545 1027090462 0 D-20 / + DATA AI12CS( 34) / -.3752017947 9364390796 6682800324 6 D-20 / + DATA AI12CS( 35) / -.5787037427 0747993459 5198231074 1 D-22 / + DATA AI12CS( 36) / +.7759997511 6481619619 8236963209 2 D-21 / + DATA AI12CS( 37) / -.1452790897 2022333940 6445987408 5 D-21 / + DATA AI12CS( 38) / -.1318225286 7390367021 2192275337 4 D-21 / + DATA AI12CS( 39) / +.6116654862 9030707018 7999133171 7 D-22 / + DATA AI12CS( 40) / +.1376279762 4271264277 3024338363 4 D-22 / + DATA AI12CS( 41) / -.1690837689 9593478849 1983938230 6 D-22 / + DATA AI12CS( 42) / +.1430596088 5954331539 8720108538 5 D-23 / + DATA AI12CS( 43) / +.3409557828 0905940204 0536772990 2 D-23 / + DATA AI12CS( 44) / -.1309457666 2707602278 4573872642 4 D-23 / + DATA AI12CS( 45) / -.3940706411 2402574360 9352141755 7 D-24 / + DATA AI12CS( 46) / +.4277137426 9808765808 0616679735 2 D-24 / + DATA AI12CS( 47) / -.4424634830 9826068819 0028312302 9 D-25 / + DATA AI12CS( 48) / -.8734113196 2307149721 1530978874 7 D-25 / + DATA AI12CS( 49) / +.4045401335 6835333921 4340414242 8 D-25 / + DATA AI12CS( 50) / +.7067100658 0946894656 5160771780 6 D-26 / + DATA AI12CS( 51) / -.1249463344 5651052230 0286451860 5 D-25 / + DATA AI12CS( 52) / +.2867392244 4034370329 7948339142 6 D-26 / + DATA AI12CS( 53) / +.2044292892 5042926702 8177957421 0 D-26 / + DATA AI12CS( 54) / -.1518636633 8204625683 7134680291 1 D-26 / + DATA AI12CS( 55) / +.8110181098 1875758861 3227910703 7 D-28 / + DATA AI12CS( 56) / +.3580379354 7735860911 2717370327 0 D-27 / + DATA AI12CS( 57) / -.1692929018 9279025095 9305717544 8 D-27 / + DATA AI12CS( 58) / -.2222902499 7024276390 6775852777 4 D-28 / + DATA AI12CS( 59) / +.5424535127 1459696550 4860040112 8 D-28 / + DATA AI12CS( 60) / -.1787068401 5780186887 6491299330 4 D-28 / + DATA AI12CS( 61) / -.6565479068 7228149388 2392943788 0 D-29 / + DATA AI12CS( 62) / +.7807013165 0611452809 2206770683 9 D-29 / + DATA AI12CS( 63) / -.1816595260 6689797173 7933315222 1 D-29 / + DATA AI12CS( 64) / -.1287704952 6600848203 7687559895 9 D-29 / + DATA AI12CS( 65) / +.1114548172 9881645474 1370927369 4 D-29 / + DATA AI12CS( 66) / -.1808343145 0393369391 5936887668 7 D-30 / + DATA AI12CS( 67) / -.2231677718 2037719522 3244822893 9 D-30 / + DATA AI12CS( 68) / +.1619029596 0803415106 1790980361 4 D-30 / + DATA AI12CS( 69) / -.1834079908 8049414139 0130843921 0 D-31 / + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DBSI1E + IF (FIRST) THEN + ETA = 0.1*REAL(D1MACH(3)) + NTI1 = INITDS (BI1CS, 17, ETA) + NTAI1 = INITDS (AI1CS, 46, ETA) + NTAI12 = INITDS (AI12CS, 69, ETA) +C + XMIN = 2.0D0*D1MACH(1) + XSML = SQRT(4.5D0*D1MACH(3)) + ENDIF + FIRST = .FALSE. +C + Y = ABS(X) + IF (Y.GT.3.0D0) GO TO 20 +C + DBSI1E = 0.0D0 + IF (Y.EQ.0.D0) RETURN +C + IF (Y .LE. XMIN) CALL XERMSG ('SLATEC', 'DBSI1E', + + 'ABS(X) SO SMALL I1 UNDERFLOWS', 1, 1) + IF (Y.GT.XMIN) DBSI1E = 0.5D0*X + IF (Y.GT.XSML) DBSI1E = X*(0.875D0 + DCSEVL (Y*Y/4.5D0-1.D0, + 1 BI1CS, NTI1) ) + DBSI1E = EXP(-Y) * DBSI1E + RETURN +C + 20 IF (Y.LE.8.D0) DBSI1E = (0.375D0 + DCSEVL ((48.D0/Y-11.D0)/5.D0, + 1 AI1CS, NTAI1))/SQRT(Y) + IF (Y.GT.8.D0) DBSI1E = (0.375D0 + DCSEVL (16.D0/Y-1.D0, AI12CS, + 1 NTAI12))/SQRT(Y) + DBSI1E = SIGN (DBSI1E, X) +C + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/dbsi1e.lo b/modules/elementary_functions/src/fortran/slatec/dbsi1e.lo new file mode 100755 index 000000000..b80190418 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbsi1e.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dbsi1e.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dbsi1e.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dbsk0e.f b/modules/elementary_functions/src/fortran/slatec/dbsk0e.f new file mode 100755 index 000000000..28dc5f1a4 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/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/modules/elementary_functions/src/fortran/slatec/dbsk0e.lo b/modules/elementary_functions/src/fortran/slatec/dbsk0e.lo new file mode 100755 index 000000000..ffed74b65 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbsk0e.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dbsk0e.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dbsk0e.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dbsk1e.f b/modules/elementary_functions/src/fortran/slatec/dbsk1e.f new file mode 100755 index 000000000..46060a580 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbsk1e.f @@ -0,0 +1,169 @@ +*DECK DBSK1E + DOUBLE PRECISION FUNCTION DBSK1E (X) +C***BEGIN PROLOGUE DBSK1E +C***PURPOSE Compute the exponentially scaled modified (hyperbolic) +C Bessel function of the third kind of order one. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C10B1 +C***TYPE DOUBLE PRECISION (BESK1E-S, DBSK1E-D) +C***KEYWORDS EXPONENTIALLY SCALED, FNLIB, HYPERBOLIC BESSEL FUNCTION, +C MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS, +C THIRD KIND +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C DBSK1E(S) computes the double precision exponentially scaled +C modified (hyperbolic) Bessel function of the third kind of order +C one for positive double precision argument X. +C +C Series for BK1 on the interval 0. to 4.00000E+00 +C with weighted error 9.16E-32 +C log weighted error 31.04 +C significant figures required 30.61 +C decimal places required 31.64 +C +C Series for AK1 on the interval 1.25000E-01 to 5.00000E-01 +C with weighted error 3.07E-32 +C log weighted error 31.51 +C significant figures required 30.71 +C decimal places required 32.30 +C +C Series for AK12 on the interval 0. to 1.25000E-01 +C with weighted error 2.41E-32 +C log weighted error 31.62 +C significant figures required 30.25 +C decimal places required 32.38 +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, DBESI1, 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 DBSK1E + DOUBLE PRECISION X, BK1CS(16), AK1CS(38), AK12CS(33), XMIN, + 1 XSML, Y, D1MACH, DCSEVL, DBESI1 + LOGICAL FIRST + SAVE BK1CS, AK1CS, AK12CS, NTK1, NTAK1, NTAK12, XMIN, XSML, + 1 FIRST + DATA BK1CS( 1) / +.2530022733 8947770532 5311208685 33 D-1 / + DATA BK1CS( 2) / -.3531559607 7654487566 7238316918 01 D+0 / + DATA BK1CS( 3) / -.1226111808 2265714823 4790679300 42 D+0 / + DATA BK1CS( 4) / -.6975723859 6398643501 8129202960 83 D-2 / + DATA BK1CS( 5) / -.1730288957 5130520630 1765073689 79 D-3 / + DATA BK1CS( 6) / -.2433406141 5659682349 6007350301 64 D-5 / + DATA BK1CS( 7) / -.2213387630 7347258558 3152525451 26 D-7 / + DATA BK1CS( 8) / -.1411488392 6335277610 9583302126 08 D-9 / + DATA BK1CS( 9) / -.6666901694 1993290060 8537512643 73 D-12 / + DATA BK1CS( 10) / -.2427449850 5193659339 2631968648 53 D-14 / + DATA BK1CS( 11) / -.7023863479 3862875971 7837971200 00 D-17 / + DATA BK1CS( 12) / -.1654327515 5100994675 4910293333 33 D-19 / + DATA BK1CS( 13) / -.3233834745 9944491991 8933333333 33 D-22 / + DATA BK1CS( 14) / -.5331275052 9265274999 4666666666 66 D-25 / + DATA BK1CS( 15) / -.7513040716 2157226666 6666666666 66 D-28 / + DATA BK1CS( 16) / -.9155085717 6541866666 6666666666 66 D-31 / + DATA AK1CS( 1) / +.2744313406 9738829695 2576662272 66 D+0 / + DATA AK1CS( 2) / +.7571989953 1993678170 8923781492 90 D-1 / + DATA AK1CS( 3) / -.1441051556 4754061229 8531161756 25 D-2 / + DATA AK1CS( 4) / +.6650116955 1257479394 2513854770 36 D-4 / + DATA AK1CS( 5) / -.4369984709 5201407660 5808450891 67 D-5 / + DATA AK1CS( 6) / +.3540277499 7630526799 4171390085 34 D-6 / + DATA AK1CS( 7) / -.3311163779 2932920208 9826882457 04 D-7 / + DATA AK1CS( 8) / +.3445977581 9010534532 3114997709 92 D-8 / + DATA AK1CS( 9) / -.3898932347 4754271048 9819374927 58 D-9 / + DATA AK1CS( 10) / +.4720819750 4658356400 9474493390 05 D-10 / + DATA AK1CS( 11) / -.6047835662 8753562345 3735915628 90 D-11 / + DATA AK1CS( 12) / +.8128494874 8658747888 1938379856 63 D-12 / + DATA AK1CS( 13) / -.1138694574 7147891428 9239159510 42 D-12 / + DATA AK1CS( 14) / +.1654035840 8462282325 9729482050 90 D-13 / + DATA AK1CS( 15) / -.2480902567 7068848221 5160104405 33 D-14 / + DATA AK1CS( 16) / +.3829237890 7024096948 4292272991 57 D-15 / + DATA AK1CS( 17) / -.6064734104 0012418187 7682103773 86 D-16 / + DATA AK1CS( 18) / +.9832425623 2648616038 1940046506 66 D-17 / + DATA AK1CS( 19) / -.1628416873 8284380035 6666201156 26 D-17 / + DATA AK1CS( 20) / +.2750153649 6752623718 2841203370 66 D-18 / + DATA AK1CS( 21) / -.4728966646 3953250924 2810695680 00 D-19 / + DATA AK1CS( 22) / +.8268150002 8109932722 3920503466 66 D-20 / + DATA AK1CS( 23) / -.1468140513 6624956337 1939648853 33 D-20 / + DATA AK1CS( 24) / +.2644763926 9208245978 0858948266 66 D-21 / + DATA AK1CS( 25) / -.4829015756 4856387897 9698688000 00 D-22 / + DATA AK1CS( 26) / +.8929302074 3610130180 6563327999 99 D-23 / + DATA AK1CS( 27) / -.1670839716 8972517176 9977514666 66 D-23 / + DATA AK1CS( 28) / +.3161645603 4040694931 3686186666 66 D-24 / + DATA AK1CS( 29) / -.6046205531 2274989106 5064106666 66 D-25 / + DATA AK1CS( 30) / +.1167879894 2042732700 7184213333 33 D-25 / + DATA AK1CS( 31) / -.2277374158 2653996232 8678400000 00 D-26 / + DATA AK1CS( 32) / +.4481109730 0773675795 3058133333 33 D-27 / + DATA AK1CS( 33) / -.8893288476 9020194062 3360000000 00 D-28 / + DATA AK1CS( 34) / +.1779468001 8850275131 3920000000 00 D-28 / + DATA AK1CS( 35) / -.3588455596 7329095821 9946666666 66 D-29 / + DATA AK1CS( 36) / +.7290629049 2694257991 6799999999 99 D-30 / + DATA AK1CS( 37) / -.1491844984 5546227073 0240000000 00 D-30 / + DATA AK1CS( 38) / +.3073657387 2934276300 7999999999 99 D-31 / + DATA AK12CS( 1) / +.6379308343 7390010366 0048853410 2 D-1 / + DATA AK12CS( 2) / +.2832887813 0497209358 3503028470 8 D-1 / + DATA AK12CS( 3) / -.2475370673 9052503454 1454556673 2 D-3 / + DATA AK12CS( 4) / +.5771972451 6072488204 7097662576 3 D-5 / + DATA AK12CS( 5) / -.2068939219 5365483027 4553319655 2 D-6 / + DATA AK12CS( 6) / +.9739983441 3818041803 0921309788 7 D-8 / + DATA AK12CS( 7) / -.5585336140 3806249846 8889551112 9 D-9 / + DATA AK12CS( 8) / +.3732996634 0461852402 2121285473 1 D-10 / + DATA AK12CS( 9) / -.2825051961 0232254451 3506575492 8 D-11 / + DATA AK12CS( 10) / +.2372019002 4841441736 4349695548 6 D-12 / + DATA AK12CS( 11) / -.2176677387 9917539792 6830166793 8 D-13 / + DATA AK12CS( 12) / +.2157914161 6160324539 3956268970 6 D-14 / + DATA AK12CS( 13) / -.2290196930 7182692759 9155133815 4 D-15 / + DATA AK12CS( 14) / +.2582885729 8232749619 1993956522 6 D-16 / + DATA AK12CS( 15) / -.3076752641 2684631876 2109817344 0 D-17 / + DATA AK12CS( 16) / +.3851487721 2804915970 9489684479 9 D-18 / + DATA AK12CS( 17) / -.5044794897 6415289771 1728250880 0 D-19 / + DATA AK12CS( 18) / +.6888673850 4185442370 1829222399 9 D-20 / + DATA AK12CS( 19) / -.9775041541 9501183030 0213248000 0 D-21 / + DATA AK12CS( 20) / +.1437416218 5238364610 0165973333 3 D-21 / + DATA AK12CS( 21) / -.2185059497 3443473734 9973333333 3 D-22 / + DATA AK12CS( 22) / +.3426245621 8092206316 4538880000 0 D-23 / + DATA AK12CS( 23) / -.5531064394 2464082325 0124800000 0 D-24 / + DATA AK12CS( 24) / +.9176601505 6859954037 8282666666 6 D-25 / + DATA AK12CS( 25) / -.1562287203 6180249114 4874666666 6 D-25 / + DATA AK12CS( 26) / +.2725419375 4843331323 4943999999 9 D-26 / + DATA AK12CS( 27) / -.4865674910 0748279923 7802666666 6 D-27 / + DATA AK12CS( 28) / +.8879388552 7235025873 5786666666 6 D-28 / + DATA AK12CS( 29) / -.1654585918 0392575489 3653333333 3 D-28 / + DATA AK12CS( 30) / +.3145111321 3578486743 0399999999 9 D-29 / + DATA AK12CS( 31) / -.6092998312 1931276124 1600000000 0 D-30 / + DATA AK12CS( 32) / +.1202021939 3698158346 2399999999 9 D-30 / + DATA AK12CS( 33) / -.2412930801 4594088413 8666666666 6 D-31 / + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DBSK1E + IF (FIRST) THEN + ETA = 0.1*REAL(D1MACH(3)) + NTK1 = INITDS (BK1CS, 16, ETA) + NTAK1 = INITDS (AK1CS, 38, ETA) + NTAK12 = INITDS (AK12CS, 33, ETA) +C + XMIN = EXP (MAX(LOG(D1MACH(1)), -LOG(D1MACH(2))) + 0.01D0) + XSML = SQRT(4.0D0*D1MACH(3)) + ENDIF + FIRST = .FALSE. +C + IF (X .LE. 0.D0) CALL XERMSG ('SLATEC', 'DBSK1E', + + 'X IS ZERO OR NEGATIVE', 2, 2) + IF (X.GT.2.0D0) GO TO 20 +C + IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'DBSK1E', + + 'X SO SMALL K1 OVERFLOWS', 3, 2) + Y = 0.D0 + IF (X.GT.XSML) Y = X*X + DBSK1E = EXP(X)*(LOG(0.5D0*X)*DBESI1(X) + (0.75D0 + + 1 DCSEVL (0.5D0*Y-1.D0, BK1CS, NTK1))/X ) + RETURN +C + 20 IF (X.LE.8.D0) DBSK1E = (1.25D0 + DCSEVL ((16.D0/X-5.D0)/3.D0, + 1 AK1CS, NTAK1))/SQRT(X) + IF (X.GT.8.D0) DBSK1E = (1.25D0 + + 1 DCSEVL (16.D0/X-1.D0, AK12CS, NTAK12))/SQRT(X) +C + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/dbsk1e.lo b/modules/elementary_functions/src/fortran/slatec/dbsk1e.lo new file mode 100755 index 000000000..a6c463846 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbsk1e.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dbsk1e.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dbsk1e.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dbskes.f b/modules/elementary_functions/src/fortran/slatec/dbskes.f new file mode 100755 index 000000000..221234396 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbskes.f @@ -0,0 +1,77 @@ +*DECK DBSKES + SUBROUTINE DBSKES (XNU, X, NIN, BKE) +C***BEGIN PROLOGUE DBSKES +C***PURPOSE Compute a sequence of exponentially scaled modified Bessel +C functions of the third kind of fractional order. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C10B3 +C***TYPE DOUBLE PRECISION (BESKES-S, DBSKES-D) +C***KEYWORDS EXPONENTIALLY SCALED, FNLIB, FRACTIONAL ORDER, +C MODIFIED BESSEL FUNCTION, SEQUENCE OF BESSEL FUNCTIONS, +C SPECIAL FUNCTIONS, THIRD KIND +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C DBSKES(XNU,X,NIN,BKE) computes a double precision sequence +C of exponentially scaled modified Bessel functions +C of the third kind of order XNU + I at X, where X .GT. 0, +C XNU lies in (-1,1), and I = 0, 1, ... , NIN - 1, if NIN is positive +C and I = 0, -1, ... , NIN + 1, if NIN is negative. On return, the +C vector BKE(.) contains the results at X for order starting at XNU. +C XNU, X, and BKE are double precision. NIN is integer. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, D9KNUS, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770601 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***END PROLOGUE DBSKES + DOUBLE PRECISION XNU, X, BKE(*), BKNU1, V, VINCR, VEND, ALNBIG, + 1 D1MACH, DIRECT + SAVE ALNBIG + DATA ALNBIG / 0.D0 / +C***FIRST EXECUTABLE STATEMENT DBSKES + IF (ALNBIG.EQ.0.D0) ALNBIG = LOG (D1MACH(2)) +C + V = ABS(XNU) + N = ABS(NIN) +C + IF (V .GE. 1.D0) CALL XERMSG ('SLATEC', 'DBSKES', + + 'ABS(XNU) MUST BE LT 1', 2, 2) + IF (X .LE. 0.D0) CALL XERMSG ('SLATEC', 'DBSKES', 'X IS LE 0', 3, + + 2) + IF (N .EQ. 0) CALL XERMSG ('SLATEC', 'DBSKES', + + 'N THE NUMBER IN THE SEQUENCE IS 0', 4, 2) +C + CALL D9KNUS (V, X, BKE(1), BKNU1, ISWTCH) + IF (N.EQ.1) RETURN +C + VINCR = SIGN (1.0, REAL(NIN)) + DIRECT = VINCR + IF (XNU.NE.0.D0) DIRECT = VINCR*SIGN(1.D0, XNU) + IF (ISWTCH .EQ. 1 .AND. DIRECT .GT. 0.) CALL XERMSG ('SLATEC', + + 'DBSKES', 'X SO SMALL BESSEL K-SUB-XNU+1 OVERFLOWS', 5, 2) + BKE(2) = BKNU1 +C + IF (DIRECT.LT.0.) CALL D9KNUS (ABS(XNU+VINCR), X, BKE(2), BKNU1, + 1 ISWTCH) + IF (N.EQ.2) RETURN +C + VEND = ABS (XNU+NIN) - 1.0D0 + IF ((VEND-.5D0)*LOG(VEND)+0.27D0-VEND*(LOG(X)-.694D0) .GT. + + ALNBIG) CALL XERMSG ('SLATEC', 'DBSKES', + + 'X SO SMALL OR ABS(NU) SO BIG THAT BESSEL K-SUB-NU ' // + + 'OVERFLOWS', 5, 2) +C + V = XNU + DO 10 I=3,N + V = V + VINCR + BKE(I) = 2.0D0*V*BKE(I-1)/X + BKE(I-2) + 10 CONTINUE +C + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/dbskes.lo b/modules/elementary_functions/src/fortran/slatec/dbskes.lo new file mode 100755 index 000000000..eba72d0d6 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbskes.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dbskes.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dbskes.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dbskin.f b/modules/elementary_functions/src/fortran/slatec/dbskin.f new file mode 100755 index 000000000..f055b9238 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbskin.f @@ -0,0 +1,353 @@ +*DECK DBSKIN + SUBROUTINE DBSKIN (X, N, KODE, M, Y, NZ, IERR) +C***BEGIN PROLOGUE DBSKIN +C***PURPOSE Compute repeated integrals of the K-zero Bessel function. +C***LIBRARY SLATEC +C***CATEGORY C10F +C***TYPE DOUBLE PRECISION (BSKIN-S, DBSKIN-D) +C***KEYWORDS BICKLEY FUNCTIONS, EXPONENTIAL INTEGRAL, +C INTEGRALS OF BESSEL FUNCTIONS, K-ZERO BESSEL FUNCTION +C***AUTHOR Amos, D. E., (SNLA) +C***DESCRIPTION +C +C The following definitions are used in DBSKIN: +C +C Definition 1 +C KI(0,X) = K-zero Bessel function. +C +C Definition 2 +C KI(N,X) = Bickley Function +C = integral from X to infinity of KI(N-1,t)dt +C for X .ge. 0 and N = 1,2,... +C _____________________________________________________________________ +C DBSKIN computes a sequence of Bickley functions (repeated integrals +C of the K0 Bessel function); i.e. for fixed X and N and for K=1,..., +C DBSKIN computes the sequence +C +C Y(K) = KI(N+K-1,X) for KODE=1 +C or +C Y(K) = EXP(X)*KI(N+K-1,X) for KODE=2, +C +C for N.ge.0 and X.ge.0 (N and X cannot be zero simultaneously). +C +C INPUT X is DOUBLE PRECISION +C X - Argument, X .ge. 0.0D0 +C N - Order of first member of the sequence N .ge. 0 +C KODE - Selection parameter +C KODE = 1 returns Y(K)= KI(N+K-1,X), K=1,M +C = 2 returns Y(K)=EXP(X)*KI(N+K-1,X), K=1,M +C M - Number of members in the sequence, M.ge.1 +C +C OUTPUT Y is a DOUBLE PRECISION VECTOR +C Y - A vector of dimension at least M containing the +C sequence selected by KODE. +C NZ - Underflow flag +C NZ = 0 means computation completed +C = 1 means an exponential underflow occurred on +C KODE=1. Y(K)=0.0D0, K=1,...,M is returned +C KODE=1 AND Y(K)=0.0E0, K=1,...,M IS RETURNED +C IERR - Error flag +C IERR=0, Normal return, computation completed +C IERR=1, Input error, no computation +C IERR=2, Error, no computation +C Algorithm termination condition not met +C +C The nominal computational accuracy is the maximum of unit +C roundoff (=D1MACH(4)) and 1.0D-18 since critical constants +C are given to only 18 digits. +C +C BSKIN is the single precision version of DBSKIN. +C +C *Long Description: +C +C Numerical recurrence on +C +C (L-1)*KI(L,X) = X(KI(L-3,X) - KI(L-1,X)) + (L-2)*KI(L-2,X) +C +C is stable where recurrence is carried forward or backward +C away from INT(X+0.5). The power series for indices 0,1 and 2 +C on 0.le.X.le.2 starts a stable recurrence for indices +C greater than 2. If N is sufficiently large (N.gt.NLIM), the +C uniform asymptotic expansion for N to INFINITY is more +C economical. On X.gt.2 the recursion is started by evaluating +C the uniform expansion for the three members whose indices are +C closest to INT(X+0.5) within the set N,...,N+M-1. Forward +C recurrence, backward recurrence or both complete the +C sequence depending on the relation of INT(X+0.5) to the +C indices N,...,N+M-1. +C +C***REFERENCES D. E. Amos, Uniform asymptotic expansions for +C exponential integrals E(N,X) and Bickley functions +C KI(N,X), ACM Transactions on Mathematical Software, +C 1983. +C D. E. Amos, A portable Fortran subroutine for the +C Bickley functions KI(N,X), Algorithm 609, ACM +C Transactions on Mathematical Software, 1983. +C***ROUTINES CALLED D1MACH, DBKIAS, DBKISR, DEXINT, DGAMRN, I1MACH +C***REVISION HISTORY (YYMMDD) +C 820601 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890911 Removed unnecessary intrinsics. (WRB) +C 891006 Cosmetic changes to prologue. (WRB) +C 891009 Removed unreferenced statement label. (WRB) +C 891009 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 DBSKIN + INTEGER I, ICASE, IERR, IL, I1M, K, KK, KODE, KTRMS, M, + * M3, N, NE, NFLG, NL, NLIM, NN, NP, NS, NT, NZ + INTEGER I1MACH + DOUBLE PRECISION A, ENLIM, EXI, FN, GR, H, HN, HRTPI, SS, TOL, + * T1, T2, W, X, XLIM, XNLIM, XP, Y, YS, YSS + DOUBLE PRECISION DGAMRN, D1MACH + DIMENSION EXI(102), A(50), YS(3), YSS(3), H(31), Y(*) + SAVE A, HRTPI +C----------------------------------------------------------------------- +C COEFFICIENTS IN SERIES OF EXPONENTIAL INTEGRALS +C----------------------------------------------------------------------- + DATA A(1), A(2), A(3), A(4), A(5), A(6), A(7), A(8), A(9), A(10), + * A(11), A(12), A(13), A(14), A(15), A(16), A(17), A(18), A(19), + * A(20), A(21), A(22), A(23), A(24) /1.00000000000000000D+00, + * 5.00000000000000000D-01,3.75000000000000000D-01, + * 3.12500000000000000D-01,2.73437500000000000D-01, + * 2.46093750000000000D-01,2.25585937500000000D-01, + * 2.09472656250000000D-01,1.96380615234375000D-01, + * 1.85470581054687500D-01,1.76197052001953125D-01, + * 1.68188095092773438D-01,1.61180257797241211D-01, + * 1.54981017112731934D-01,1.49445980787277222D-01, + * 1.44464448094367981D-01,1.39949934091418982D-01, + * 1.35833759559318423D-01,1.32060599571559578D-01, + * 1.28585320635465905D-01,1.25370687619579257D-01, + * 1.22385671247684513D-01,1.19604178719328047D-01, + * 1.17004087877603524D-01/ + DATA A(25), A(26), A(27), A(28), A(29), A(30), A(31), A(32), + * A(33), A(34), A(35), A(36), A(37), A(38), A(39), A(40), A(41), + * A(42), A(43), A(44), A(45), A(46), A(47), A(48) + * /1.14566502713486784D-01,1.12275172659217048D-01, + * 1.10116034723462874D-01,1.08076848895250599D-01, + * 1.06146905164978267D-01,1.04316786110409676D-01, + * 1.02578173008569515D-01,1.00923686347140974D-01, + * 9.93467537479668965D-02,9.78414999033007314D-02, + * 9.64026543164874854D-02,9.50254735405376642D-02, + * 9.37056752969190855D-02,9.24393823875012600D-02, + * 9.12230747245078224D-02,9.00535481254756708D-02, + * 8.89278787739072249D-02,8.78433924473961612D-02, + * 8.67976377754033498D-02,8.57883629175498224D-02, + * 8.48134951571231199D-02,8.38711229887106408D-02, + * 8.29594803475290034D-02,8.20769326842574183D-02/ + DATA A(49), A(50) /8.12219646354630702D-02,8.03931690779583449D-02 + * / +C----------------------------------------------------------------------- +C SQRT(PI)/2 +C----------------------------------------------------------------------- + DATA HRTPI /8.86226925452758014D-01/ +C +C***FIRST EXECUTABLE STATEMENT DBSKIN + IERR = 0 + NZ=0 + IF (X.LT.0.0D0) IERR=1 + IF (N.LT.0) IERR=1 + IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 + IF (M.LT.1) IERR=1 + IF (X.EQ.0.0D0 .AND. N.EQ.0) IERR=1 + IF (IERR.NE.0) RETURN + IF (X.EQ.0.0D0) GO TO 300 + I1M = -I1MACH(15) + T1 = 2.3026D0*D1MACH(5)*I1M + XLIM = T1 - 3.228086D0 + T2 = T1 + (N+M-1) + IF (T2.GT.1000.0D0) XLIM = T1 - 0.5D0*(LOG(T2)-0.451583D0) + IF (X.GT.XLIM .AND. KODE.EQ.1) GO TO 320 + TOL = MAX(D1MACH(4),1.0D-18) + I1M = I1MACH(14) +C----------------------------------------------------------------------- +C LN(NLIM) = 0.125*LN(EPS), NLIM = 2*KTRMS+N +C----------------------------------------------------------------------- + XNLIM = 0.287823D0*(I1M-1)*D1MACH(5) + ENLIM = EXP(XNLIM) + NLIM = INT(ENLIM) + 2 + NLIM = MIN(100,NLIM) + NLIM = MAX(20,NLIM) + M3 = MIN(M,3) + NL = N + M - 1 + IF (X.GT.2.0D0) GO TO 130 + IF (N.GT.NLIM) GO TO 280 +C----------------------------------------------------------------------- +C COMPUTATION BY SERIES FOR 0.LE.X.LE.2 +C----------------------------------------------------------------------- + NFLG = 0 + NN = N + IF (NL.LE.2) GO TO 60 + M3 = 3 + NN = 0 + NFLG = 1 + 60 CONTINUE + XP = 1.0D0 + IF (KODE.EQ.2) XP = EXP(X) + DO 80 I=1,M3 + CALL DBKISR(X, NN, W, IERR) + IF(IERR.NE.0) RETURN + W = W*XP + IF (NN.LT.N) GO TO 70 + KK = NN - N + 1 + Y(KK) = W + 70 CONTINUE + YS(I) = W + NN = NN + 1 + 80 CONTINUE + IF (NFLG.EQ.0) RETURN + NS = NN + XP = 1.0D0 + 90 CONTINUE +C----------------------------------------------------------------------- +C FORWARD RECURSION SCALED BY EXP(X) ON ICASE=0,1,2 +C----------------------------------------------------------------------- + FN = NS - 1 + IL = NL - NS + 1 + IF (IL.LE.0) RETURN + DO 110 I=1,IL + T1 = YS(2) + T2 = YS(3) + YS(3) = (X*(YS(1)-YS(3))+(FN-1.0D0)*YS(2))/FN + YS(2) = T2 + YS(1) = T1 + FN = FN + 1.0D0 + IF (NS.LT.N) GO TO 100 + KK = NS - N + 1 + Y(KK) = YS(3)*XP + 100 CONTINUE + NS = NS + 1 + 110 CONTINUE + RETURN +C----------------------------------------------------------------------- +C COMPUTATION BY ASYMPTOTIC EXPANSION FOR X.GT.2 +C----------------------------------------------------------------------- + 130 CONTINUE + W = X + 0.5D0 + NT = INT(W) + IF (NL.GT.NT) GO TO 270 +C----------------------------------------------------------------------- +C CASE NL.LE.NT, ICASE=0 +C----------------------------------------------------------------------- + ICASE = 0 + NN = NL + NFLG = MIN(M-M3,1) + 140 CONTINUE + KK = (NLIM-NN)/2 + KTRMS = MAX(0,KK) + NS = NN + 1 + NP = NN - M3 + 1 + XP = 1.0D0 + IF (KODE.EQ.1) XP = EXP(-X) + DO 150 I=1,M3 + KK = I + CALL DBKIAS(X, NP, KTRMS, A, W, KK, NE, GR, H, IERR) + IF(IERR.NE.0) RETURN + YS(I) = W + NP = NP + 1 + 150 CONTINUE +C----------------------------------------------------------------------- +C SUM SERIES OF EXPONENTIAL INTEGRALS BACKWARD +C----------------------------------------------------------------------- + IF (KTRMS.EQ.0) GO TO 160 + NE = KTRMS + KTRMS + 1 + NP = NN - M3 + 2 + CALL DEXINT(X, NP, 2, NE, TOL, EXI, NZ, IERR) + IF (NZ.NE.0) GO TO 320 + 160 CONTINUE + DO 190 I=1,M3 + SS = 0.0D0 + IF (KTRMS.EQ.0) GO TO 180 + KK = I + KTRMS + KTRMS - 2 + IL = KTRMS + DO 170 K=1,KTRMS + SS = SS + A(IL)*EXI(KK) + KK = KK - 2 + IL = IL - 1 + 170 CONTINUE + 180 CONTINUE + YS(I) = YS(I) + SS + 190 CONTINUE + IF (ICASE.EQ.1) GO TO 200 + IF (NFLG.NE.0) GO TO 220 + 200 CONTINUE + DO 210 I=1,M3 + Y(I) = YS(I)*XP + 210 CONTINUE + IF (ICASE.EQ.1 .AND. NFLG.EQ.1) GO TO 90 + RETURN + 220 CONTINUE +C----------------------------------------------------------------------- +C BACKWARD RECURSION SCALED BY EXP(X) ICASE=0,2 +C----------------------------------------------------------------------- + KK = NN - N + 1 + K = M3 + DO 230 I=1,M3 + Y(KK) = YS(K)*XP + YSS(I) = YS(I) + KK = KK - 1 + K = K - 1 + 230 CONTINUE + IL = KK + IF (IL.LE.0) GO TO 250 + FN = NN - 3 + DO 240 I=1,IL + T1 = YS(2) + T2 = YS(1) + YS(1) = YS(2) + ((FN+2.0D0)*YS(3)-(FN+1.0D0)*YS(1))/X + YS(2) = T2 + YS(3) = T1 + Y(KK) = YS(1)*XP + KK = KK - 1 + FN = FN - 1.0D0 + 240 CONTINUE + 250 CONTINUE + IF (ICASE.NE.2) RETURN + DO 260 I=1,M3 + YS(I) = YSS(I) + 260 CONTINUE + GO TO 90 + 270 CONTINUE + IF (N.LT.NT) GO TO 290 +C----------------------------------------------------------------------- +C ICASE=1, NT.LE.N.LE.NL WITH FORWARD RECURSION +C----------------------------------------------------------------------- + 280 CONTINUE + NN = N + M3 - 1 + NFLG = MIN(M-M3,1) + ICASE = 1 + GO TO 140 +C----------------------------------------------------------------------- +C ICASE=2, N.LT.NT.LT.NL WITH BOTH FORWARD AND BACKWARD RECURSION +C----------------------------------------------------------------------- + 290 CONTINUE + NN = NT + 1 + NFLG = MIN(M-M3,1) + ICASE = 2 + GO TO 140 +C----------------------------------------------------------------------- +C X=0 CASE +C----------------------------------------------------------------------- + 300 CONTINUE + FN = N + HN = 0.5D0*FN + GR = DGAMRN(HN) + Y(1) = HRTPI*GR + IF (M.EQ.1) RETURN + Y(2) = HRTPI/(HN*GR) + IF (M.EQ.2) RETURN + DO 310 K=3,M + Y(K) = FN*Y(K-2)/(FN+1.0D0) + FN = FN + 1.0D0 + 310 CONTINUE + RETURN +C----------------------------------------------------------------------- +C UNDERFLOW ON KODE=1, X.GT.XLIM +C----------------------------------------------------------------------- + 320 CONTINUE + NZ=M + DO 330 I=1,M + Y(I) = 0.0D0 + 330 CONTINUE + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/dbskin.lo b/modules/elementary_functions/src/fortran/slatec/dbskin.lo new file mode 100755 index 000000000..f927fc87e --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbskin.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dbskin.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dbskin.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dbsknu.f b/modules/elementary_functions/src/fortran/slatec/dbsknu.f new file mode 100755 index 000000000..eb9dc1e9a --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbsknu.f @@ -0,0 +1,393 @@ +*DECK DBSKNU + SUBROUTINE DBSKNU (X, FNU, KODE, N, Y, NZ) +C***BEGIN PROLOGUE DBSKNU +C***SUBSIDIARY +C***PURPOSE Subsidiary to DBESK +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (BESKNU-S, DBSKNU-D) +C***AUTHOR Amos, D. E., (SNLA) +C***DESCRIPTION +C +C Abstract **** A DOUBLE PRECISION routine **** +C DBSKNU computes N member sequences of K Bessel functions +C K/SUB(FNU+I-1)/(X), I=1,N for non-negative orders FNU and +C positive X. Equations of the references are implemented on +C small orders DNU for K/SUB(DNU)/(X) and K/SUB(DNU+1)/(X). +C Forward recursion with the three term recursion relation +C generates higher orders FNU+I-1, I=1,...,N. The parameter +C KODE permits K/SUB(FNU+I-1)/(X) values or scaled values +C EXP(X)*K/SUB(FNU+I-1)/(X), I=1,N to be returned. +C +C To start the recursion FNU is normalized to the interval +C -0.5.LE.DNU.LT.0.5. A special form of the power series is +C implemented on 0.LT.X.LE.X1 while the Miller algorithm for the +C K Bessel function in terms of the confluent hypergeometric +C function U(FNU+0.5,2*FNU+1,X) is implemented on X1.LT.X.LE.X2. +C For X.GT.X2, the asymptotic expansion for large X is used. +C When FNU is a half odd integer, a special formula for +C DNU=-0.5 and DNU+1.0=0.5 is used to start the recursion. +C +C The maximum number of significant digits obtainable +C is the smaller of 14 and the number of digits carried in +C DOUBLE PRECISION arithmetic. +C +C DBSKNU assumes that a significant digit SINH function is +C available. +C +C Description of Arguments +C +C INPUT X,FNU are DOUBLE PRECISION +C X - X.GT.0.0D0 +C FNU - Order of initial K function, FNU.GE.0.0D0 +C N - Number of members of the sequence, N.GE.1 +C KODE - A parameter to indicate the scaling option +C KODE= 1 returns +C Y(I)= K/SUB(FNU+I-1)/(X) +C I=1,...,N +C = 2 returns +C Y(I)=EXP(X)*K/SUB(FNU+I-1)/(X) +C I=1,...,N +C +C OUTPUT Y is DOUBLE PRECISION +C Y - A vector whose first N components contain values +C for the sequence +C Y(I)= K/SUB(FNU+I-1)/(X), I=1,...,N or +C Y(I)=EXP(X)*K/SUB(FNU+I-1)/(X), I=1,...,N +C depending on KODE +C NZ - Number of components set to zero due to +C underflow, +C NZ= 0 , normal return +C NZ.NE.0 , first NZ components of Y set to zero +C due to underflow, Y(I)=0.0D0,I=1,...,NZ +C +C Error Conditions +C Improper input arguments - a fatal error +C Overflow - a fatal error +C Underflow with KODE=1 - a non-fatal error (NZ.NE.0) +C +C***SEE ALSO DBESK +C***REFERENCES N. M. Temme, On the numerical evaluation of the modified +C Bessel function of the third kind, Journal of +C Computational Physics 19, (1975), pp. 324-337. +C***ROUTINES CALLED D1MACH, DGAMMA, I1MACH, XERMSG +C***REVISION HISTORY (YYMMDD) +C 790201 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890911 Removed unnecessary intrinsics. (WRB) +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 900328 Added TYPE section. (WRB) +C 900727 Added EXTERNAL statement. (WRB) +C 910408 Updated the AUTHOR and REFERENCES sections. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DBSKNU +C + INTEGER I, IFLAG, INU, J, K, KK, KODE, KODED, N, NN, NZ + INTEGER I1MACH + DOUBLE PRECISION A,AK,A1,A2,B,BK,CC,CK,COEF,CX,DK,DNU,DNU2,ELIM, + 1 ETEST, EX, F, FC, FHS, FK, FKS, FLRX, FMU, FNU, G1, G2, P, PI, + 2 PT, P1, P2, Q, RTHPI, RX, S, SMU, SQK, ST, S1, S2, TM, TOL, T1, + 3 T2, X, X1, X2, Y + DIMENSION A(160), B(160), Y(*), CC(8) + DOUBLE PRECISION DGAMMA, D1MACH + EXTERNAL DGAMMA + SAVE X1, X2, PI, RTHPI, CC + DATA X1, X2 / 2.0D0, 17.0D0 / + DATA PI,RTHPI / 3.14159265358979D+00, 1.25331413731550D+00/ + DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8) + 1 / 5.77215664901533D-01,-4.20026350340952D-02, + 2-4.21977345555443D-02, 7.21894324666300D-03,-2.15241674114900D-04, + 3-2.01348547807000D-05, 1.13302723200000D-06, 6.11609500000000D-09/ +C***FIRST EXECUTABLE STATEMENT DBSKNU + KK = -I1MACH(15) + ELIM = 2.303D0*(KK*D1MACH(5)-3.0D0) + AK = D1MACH(3) + TOL = MAX(AK,1.0D-15) + IF (X.LE.0.0D0) GO TO 350 + IF (FNU.LT.0.0D0) GO TO 360 + IF (KODE.LT.1 .OR. KODE.GT.2) GO TO 370 + IF (N.LT.1) GO TO 380 + NZ = 0 + IFLAG = 0 + KODED = KODE + RX = 2.0D0/X + INU = INT(FNU+0.5D0) + DNU = FNU - INU + IF (ABS(DNU).EQ.0.5D0) GO TO 120 + DNU2 = 0.0D0 + IF (ABS(DNU).LT.TOL) GO TO 10 + DNU2 = DNU*DNU + 10 CONTINUE + IF (X.GT.X1) GO TO 120 +C +C SERIES FOR X.LE.X1 +C + A1 = 1.0D0 - DNU + A2 = 1.0D0 + DNU + T1 = 1.0D0/DGAMMA(A1) + T2 = 1.0D0/DGAMMA(A2) + IF (ABS(DNU).GT.0.1D0) GO TO 40 +C SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU) + S = CC(1) + AK = 1.0D0 + DO 20 K=2,8 + AK = AK*DNU2 + TM = CC(K)*AK + S = S + TM + IF (ABS(TM).LT.TOL) GO TO 30 + 20 CONTINUE + 30 G1 = -S + GO TO 50 + 40 CONTINUE + G1 = (T1-T2)/(DNU+DNU) + 50 CONTINUE + G2 = (T1+T2)*0.5D0 + SMU = 1.0D0 + FC = 1.0D0 + FLRX = LOG(RX) + FMU = DNU*FLRX + IF (DNU.EQ.0.0D0) GO TO 60 + FC = DNU*PI + FC = FC/SIN(FC) + IF (FMU.NE.0.0D0) SMU = SINH(FMU)/FMU + 60 CONTINUE + F = FC*(G1*COSH(FMU)+G2*FLRX*SMU) + FC = EXP(FMU) + P = 0.5D0*FC/T2 + Q = 0.5D0/(FC*T1) + AK = 1.0D0 + CK = 1.0D0 + BK = 1.0D0 + S1 = F + S2 = P + IF (INU.GT.0 .OR. N.GT.1) GO TO 90 + IF (X.LT.TOL) GO TO 80 + CX = X*X*0.25D0 + 70 CONTINUE + F = (AK*F+P+Q)/(BK-DNU2) + P = P/(AK-DNU) + Q = Q/(AK+DNU) + CK = CK*CX/AK + T1 = CK*F + S1 = S1 + T1 + BK = BK + AK + AK + 1.0D0 + AK = AK + 1.0D0 + S = ABS(T1)/(1.0D0+ABS(S1)) + IF (S.GT.TOL) GO TO 70 + 80 CONTINUE + Y(1) = S1 + IF (KODED.EQ.1) RETURN + Y(1) = S1*EXP(X) + RETURN + 90 CONTINUE + IF (X.LT.TOL) GO TO 110 + CX = X*X*0.25D0 + 100 CONTINUE + F = (AK*F+P+Q)/(BK-DNU2) + P = P/(AK-DNU) + Q = Q/(AK+DNU) + CK = CK*CX/AK + T1 = CK*F + S1 = S1 + T1 + T2 = CK*(P-AK*F) + S2 = S2 + T2 + BK = BK + AK + AK + 1.0D0 + AK = AK + 1.0D0 + S = ABS(T1)/(1.0D0+ABS(S1)) + ABS(T2)/(1.0D0+ABS(S2)) + IF (S.GT.TOL) GO TO 100 + 110 CONTINUE + S2 = S2*RX + IF (KODED.EQ.1) GO TO 170 + F = EXP(X) + S1 = S1*F + S2 = S2*F + GO TO 170 + 120 CONTINUE + COEF = RTHPI/SQRT(X) + IF (KODED.EQ.2) GO TO 130 + IF (X.GT.ELIM) GO TO 330 + COEF = COEF*EXP(-X) + 130 CONTINUE + IF (ABS(DNU).EQ.0.5D0) GO TO 340 + IF (X.GT.X2) GO TO 280 +C +C MILLER ALGORITHM FOR X1.LT.X.LE.X2 +C + ETEST = COS(PI*DNU)/(PI*X*TOL) + FKS = 1.0D0 + FHS = 0.25D0 + FK = 0.0D0 + CK = X + X + 2.0D0 + P1 = 0.0D0 + P2 = 1.0D0 + K = 0 + 140 CONTINUE + K = K + 1 + FK = FK + 1.0D0 + AK = (FHS-DNU2)/(FKS+FK) + BK = CK/(FK+1.0D0) + PT = P2 + P2 = BK*P2 - AK*P1 + P1 = PT + A(K) = AK + B(K) = BK + CK = CK + 2.0D0 + FKS = FKS + FK + FK + 1.0D0 + FHS = FHS + FK + FK + IF (ETEST.GT.FK*P1) GO TO 140 + KK = K + S = 1.0D0 + P1 = 0.0D0 + P2 = 1.0D0 + DO 150 I=1,K + PT = P2 + P2 = (B(KK)*P2-P1)/A(KK) + P1 = PT + S = S + P2 + KK = KK - 1 + 150 CONTINUE + S1 = COEF*(P2/S) + IF (INU.GT.0 .OR. N.GT.1) GO TO 160 + GO TO 200 + 160 CONTINUE + S2 = S1*(X+DNU+0.5D0-P1/P2)/X +C +C FORWARD RECURSION ON THE THREE TERM RECURSION RELATION +C + 170 CONTINUE + CK = (DNU+DNU+2.0D0)/X + IF (N.EQ.1) INU = INU - 1 + IF (INU.GT.0) GO TO 180 + IF (N.GT.1) GO TO 200 + S1 = S2 + GO TO 200 + 180 CONTINUE + DO 190 I=1,INU + ST = S2 + S2 = CK*S2 + S1 + S1 = ST + CK = CK + RX + 190 CONTINUE + IF (N.EQ.1) S1 = S2 + 200 CONTINUE + IF (IFLAG.EQ.1) GO TO 220 + Y(1) = S1 + IF (N.EQ.1) RETURN + Y(2) = S2 + IF (N.EQ.2) RETURN + DO 210 I=3,N + Y(I) = CK*Y(I-1) + Y(I-2) + CK = CK + RX + 210 CONTINUE + RETURN +C IFLAG=1 CASES + 220 CONTINUE + S = -X + LOG(S1) + Y(1) = 0.0D0 + NZ = 1 + IF (S.LT.-ELIM) GO TO 230 + Y(1) = EXP(S) + NZ = 0 + 230 CONTINUE + IF (N.EQ.1) RETURN + S = -X + LOG(S2) + Y(2) = 0.0D0 + NZ = NZ + 1 + IF (S.LT.-ELIM) GO TO 240 + NZ = NZ - 1 + Y(2) = EXP(S) + 240 CONTINUE + IF (N.EQ.2) RETURN + KK = 2 + IF (NZ.LT.2) GO TO 260 + DO 250 I=3,N + KK = I + ST = S2 + S2 = CK*S2 + S1 + S1 = ST + CK = CK + RX + S = -X + LOG(S2) + NZ = NZ + 1 + Y(I) = 0.0D0 + IF (S.LT.-ELIM) GO TO 250 + Y(I) = EXP(S) + NZ = NZ - 1 + GO TO 260 + 250 CONTINUE + RETURN + 260 CONTINUE + IF (KK.EQ.N) RETURN + S2 = S2*CK + S1 + CK = CK + RX + KK = KK + 1 + Y(KK) = EXP(-X+LOG(S2)) + IF (KK.EQ.N) RETURN + KK = KK + 1 + DO 270 I=KK,N + Y(I) = CK*Y(I-1) + Y(I-2) + CK = CK + RX + 270 CONTINUE + RETURN +C +C ASYMPTOTIC EXPANSION FOR LARGE X, X.GT.X2 +C +C IFLAG=0 MEANS NO UNDERFLOW OCCURRED +C IFLAG=1 MEANS AN UNDERFLOW OCCURRED- COMPUTATION PROCEEDS WITH +C KODED=2 AND A TEST FOR ON SCALE VALUES IS MADE DURING FORWARD +C RECURSION + 280 CONTINUE + NN = 2 + IF (INU.EQ.0 .AND. N.EQ.1) NN = 1 + DNU2 = DNU + DNU + FMU = 0.0D0 + IF (ABS(DNU2).LT.TOL) GO TO 290 + FMU = DNU2*DNU2 + 290 CONTINUE + EX = X*8.0D0 + S2 = 0.0D0 + DO 320 K=1,NN + S1 = S2 + S = 1.0D0 + AK = 0.0D0 + CK = 1.0D0 + SQK = 1.0D0 + DK = EX + DO 300 J=1,30 + CK = CK*(FMU-SQK)/DK + S = S + CK + DK = DK + EX + AK = AK + 8.0D0 + SQK = SQK + AK + IF (ABS(CK).LT.TOL) GO TO 310 + 300 CONTINUE + 310 S2 = S*COEF + FMU = FMU + 8.0D0*DNU + 4.0D0 + 320 CONTINUE + IF (NN.GT.1) GO TO 170 + S1 = S2 + GO TO 200 + 330 CONTINUE + KODED = 2 + IFLAG = 1 + GO TO 120 +C +C FNU=HALF ODD INTEGER CASE +C + 340 CONTINUE + S1 = COEF + S2 = COEF + GO TO 170 +C +C + 350 CALL XERMSG ('SLATEC', 'DBSKNU', 'X NOT GREATER THAN ZERO', 2, 1) + RETURN + 360 CALL XERMSG ('SLATEC', 'DBSKNU', 'FNU NOT ZERO OR POSITIVE', 2, + + 1) + RETURN + 370 CALL XERMSG ('SLATEC', 'DBSKNU', 'KODE NOT 1 OR 2', 2, 1) + RETURN + 380 CALL XERMSG ('SLATEC', 'DBSKNU', 'N NOT GREATER THAN 0', 2, 1) + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/dbsknu.lo b/modules/elementary_functions/src/fortran/slatec/dbsknu.lo new file mode 100755 index 000000000..cfb3ace75 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbsknu.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dbsknu.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dbsknu.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dbsynu.f b/modules/elementary_functions/src/fortran/slatec/dbsynu.f new file mode 100755 index 000000000..619e1511e --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbsynu.f @@ -0,0 +1,358 @@ +*DECK DBSYNU + SUBROUTINE DBSYNU (X, FNU, N, Y) +C***BEGIN PROLOGUE DBSYNU +C***SUBSIDIARY +C***PURPOSE Subsidiary to DBESY +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (BESYNU-S, DBSYNU-D) +C***AUTHOR Amos, D. E., (SNLA) +C***DESCRIPTION +C +C Abstract **** A DOUBLE PRECISION routine **** +C DBSYNU computes N member sequences of Y Bessel functions +C Y/SUB(FNU+I-1)/(X), I=1,N for non-negative orders FNU and +C positive X. Equations of the references are implemented on +C small orders DNU for Y/SUB(DNU)/(X) and Y/SUB(DNU+1)/(X). +C Forward recursion with the three term recursion relation +C generates higher orders FNU+I-1, I=1,...,N. +C +C To start the recursion FNU is normalized to the interval +C -0.5.LE.DNU.LT.0.5. A special form of the power series is +C implemented on 0.LT.X.LE.X1 while the Miller algorithm for the +C K Bessel function in terms of the confluent hypergeometric +C function U(FNU+0.5,2*FNU+1,I*X) is implemented on X1.LT.X.LE.X +C Here I is the complex number SQRT(-1.). +C For X.GT.X2, the asymptotic expansion for large X is used. +C When FNU is a half odd integer, a special formula for +C DNU=-0.5 and DNU+1.0=0.5 is used to start the recursion. +C +C The maximum number of significant digits obtainable +C is the smaller of 14 and the number of digits carried in +C DOUBLE PRECISION arithmetic. +C +C DBSYNU assumes that a significant digit SINH function is +C available. +C +C Description of Arguments +C +C INPUT +C X - X.GT.0.0D0 +C FNU - Order of initial Y function, FNU.GE.0.0D0 +C N - Number of members of the sequence, N.GE.1 +C +C OUTPUT +C Y - A vector whose first N components contain values +C for the sequence Y(I)=Y/SUB(FNU+I-1), I=1,N. +C +C Error Conditions +C Improper input arguments - a fatal error +C Overflow - a fatal error +C +C***SEE ALSO DBESY +C***REFERENCES N. M. Temme, On the numerical evaluation of the ordinary +C Bessel function of the second kind, Journal of +C Computational Physics 21, (1976), pp. 343-350. +C N. M. Temme, On the numerical evaluation of the modified +C Bessel function of the third kind, Journal of +C Computational Physics 19, (1975), pp. 324-337. +C***ROUTINES CALLED D1MACH, DGAMMA, XERMSG +C***REVISION HISTORY (YYMMDD) +C 800501 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890911 Removed unnecessary intrinsics. (WRB) +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 900328 Added TYPE section. (WRB) +C 900727 Added EXTERNAL statement. (WRB) +C 910408 Updated the AUTHOR and REFERENCES sections. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DBSYNU +C + INTEGER I, INU, J, K, KK, N, NN + DOUBLE PRECISION A,AK,ARG,A1,A2,BK,CB,CBK,CC,CCK,CK,COEF,CPT, + 1 CP1, CP2, CS, CS1, CS2, CX, DNU, DNU2, ETEST, ETX, F, FC, FHS, + 2 FK, FKS, FLRX, FMU, FN, FNU, FX, G, G1, G2, HPI, P, PI, PT, Q, + 3 RB, RBK, RCK, RELB, RPT, RP1, RP2, RS, RS1, RS2, RTHPI, RX, S, + 4 SA, SB, SMU, SS, ST, S1, S2, TB, TM, TOL, T1, T2, X, X1, X2, Y + DIMENSION A(120), RB(120), CB(120), Y(*), CC(8) + DOUBLE PRECISION DGAMMA, D1MACH + EXTERNAL DGAMMA + SAVE X1, X2,PI, RTHPI, HPI, CC + DATA X1, X2 / 3.0D0, 20.0D0 / + DATA PI,RTHPI / 3.14159265358979D+00, 7.97884560802865D-01/ + DATA HPI / 1.57079632679490D+00/ + DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8) + 1 / 5.77215664901533D-01,-4.20026350340952D-02, + 2-4.21977345555443D-02, 7.21894324666300D-03,-2.15241674114900D-04, + 3-2.01348547807000D-05, 1.13302723200000D-06, 6.11609500000000D-09/ +C***FIRST EXECUTABLE STATEMENT DBSYNU + AK = D1MACH(3) + TOL = MAX(AK,1.0D-15) + IF (X.LE.0.0D0) GO TO 270 + IF (FNU.LT.0.0D0) GO TO 280 + IF (N.LT.1) GO TO 290 + RX = 2.0D0/X + INU = INT(FNU+0.5D0) + DNU = FNU - INU + IF (ABS(DNU).EQ.0.5D0) GO TO 260 + DNU2 = 0.0D0 + IF (ABS(DNU).LT.TOL) GO TO 10 + DNU2 = DNU*DNU + 10 CONTINUE + IF (X.GT.X1) GO TO 120 +C +C SERIES FOR X.LE.X1 +C + A1 = 1.0D0 - DNU + A2 = 1.0D0 + DNU + T1 = 1.0D0/DGAMMA(A1) + T2 = 1.0D0/DGAMMA(A2) + IF (ABS(DNU).GT.0.1D0) GO TO 40 +C SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU) + S = CC(1) + AK = 1.0D0 + DO 20 K=2,8 + AK = AK*DNU2 + TM = CC(K)*AK + S = S + TM + IF (ABS(TM).LT.TOL) GO TO 30 + 20 CONTINUE + 30 G1 = -(S+S) + GO TO 50 + 40 CONTINUE + G1 = (T1-T2)/DNU + 50 CONTINUE + G2 = T1 + T2 + SMU = 1.0D0 + FC = 1.0D0/PI + FLRX = LOG(RX) + FMU = DNU*FLRX + TM = 0.0D0 + IF (DNU.EQ.0.0D0) GO TO 60 + TM = SIN(DNU*HPI)/DNU + TM = (DNU+DNU)*TM*TM + FC = DNU/SIN(DNU*PI) + IF (FMU.NE.0.0D0) SMU = SINH(FMU)/FMU + 60 CONTINUE + F = FC*(G1*COSH(FMU)+G2*FLRX*SMU) + FX = EXP(FMU) + P = FC*T1*FX + Q = FC*T2/FX + G = F + TM*Q + AK = 1.0D0 + CK = 1.0D0 + BK = 1.0D0 + S1 = G + S2 = P + IF (INU.GT.0 .OR. N.GT.1) GO TO 90 + IF (X.LT.TOL) GO TO 80 + CX = X*X*0.25D0 + 70 CONTINUE + F = (AK*F+P+Q)/(BK-DNU2) + P = P/(AK-DNU) + Q = Q/(AK+DNU) + G = F + TM*Q + CK = -CK*CX/AK + T1 = CK*G + S1 = S1 + T1 + BK = BK + AK + AK + 1.0D0 + AK = AK + 1.0D0 + S = ABS(T1)/(1.0D0+ABS(S1)) + IF (S.GT.TOL) GO TO 70 + 80 CONTINUE + Y(1) = -S1 + RETURN + 90 CONTINUE + IF (X.LT.TOL) GO TO 110 + CX = X*X*0.25D0 + 100 CONTINUE + F = (AK*F+P+Q)/(BK-DNU2) + P = P/(AK-DNU) + Q = Q/(AK+DNU) + G = F + TM*Q + CK = -CK*CX/AK + T1 = CK*G + S1 = S1 + T1 + T2 = CK*(P-AK*G) + S2 = S2 + T2 + BK = BK + AK + AK + 1.0D0 + AK = AK + 1.0D0 + S = ABS(T1)/(1.0D0+ABS(S1)) + ABS(T2)/(1.0D0+ABS(S2)) + IF (S.GT.TOL) GO TO 100 + 110 CONTINUE + S2 = -S2*RX + S1 = -S1 + GO TO 160 + 120 CONTINUE + COEF = RTHPI/SQRT(X) + IF (X.GT.X2) GO TO 210 +C +C MILLER ALGORITHM FOR X1.LT.X.LE.X2 +C + ETEST = COS(PI*DNU)/(PI*X*TOL) + FKS = 1.0D0 + FHS = 0.25D0 + FK = 0.0D0 + RCK = 2.0D0 + CCK = X + X + RP1 = 0.0D0 + CP1 = 0.0D0 + RP2 = 1.0D0 + CP2 = 0.0D0 + K = 0 + 130 CONTINUE + K = K + 1 + FK = FK + 1.0D0 + AK = (FHS-DNU2)/(FKS+FK) + PT = FK + 1.0D0 + RBK = RCK/PT + CBK = CCK/PT + RPT = RP2 + CPT = CP2 + RP2 = RBK*RPT - CBK*CPT - AK*RP1 + CP2 = CBK*RPT + RBK*CPT - AK*CP1 + RP1 = RPT + CP1 = CPT + RB(K) = RBK + CB(K) = CBK + A(K) = AK + RCK = RCK + 2.0D0 + FKS = FKS + FK + FK + 1.0D0 + FHS = FHS + FK + FK + PT = MAX(ABS(RP1),ABS(CP1)) + FC = (RP1/PT)**2 + (CP1/PT)**2 + PT = PT*SQRT(FC)*FK + IF (ETEST.GT.PT) GO TO 130 + KK = K + RS = 1.0D0 + CS = 0.0D0 + RP1 = 0.0D0 + CP1 = 0.0D0 + RP2 = 1.0D0 + CP2 = 0.0D0 + DO 140 I=1,K + RPT = RP2 + CPT = CP2 + RP2 = (RB(KK)*RPT-CB(KK)*CPT-RP1)/A(KK) + CP2 = (CB(KK)*RPT+RB(KK)*CPT-CP1)/A(KK) + RP1 = RPT + CP1 = CPT + RS = RS + RP2 + CS = CS + CP2 + KK = KK - 1 + 140 CONTINUE + PT = MAX(ABS(RS),ABS(CS)) + FC = (RS/PT)**2 + (CS/PT)**2 + PT = PT*SQRT(FC) + RS1 = (RP2*(RS/PT)+CP2*(CS/PT))/PT + CS1 = (CP2*(RS/PT)-RP2*(CS/PT))/PT + FC = HPI*(DNU-0.5D0) - X + P = COS(FC) + Q = SIN(FC) + S1 = (CS1*Q-RS1*P)*COEF + IF (INU.GT.0 .OR. N.GT.1) GO TO 150 + Y(1) = S1 + RETURN + 150 CONTINUE + PT = MAX(ABS(RP2),ABS(CP2)) + FC = (RP2/PT)**2 + (CP2/PT)**2 + PT = PT*SQRT(FC) + RPT = DNU + 0.5D0 - (RP1*(RP2/PT)+CP1*(CP2/PT))/PT + CPT = X - (CP1*(RP2/PT)-RP1*(CP2/PT))/PT + CS2 = CS1*CPT - RS1*RPT + RS2 = RPT*CS1 + RS1*CPT + S2 = (RS2*Q+CS2*P)*COEF/X +C +C FORWARD RECURSION ON THE THREE TERM RECURSION RELATION +C + 160 CONTINUE + CK = (DNU+DNU+2.0D0)/X + IF (N.EQ.1) INU = INU - 1 + IF (INU.GT.0) GO TO 170 + IF (N.GT.1) GO TO 190 + S1 = S2 + GO TO 190 + 170 CONTINUE + DO 180 I=1,INU + ST = S2 + S2 = CK*S2 - S1 + S1 = ST + CK = CK + RX + 180 CONTINUE + IF (N.EQ.1) S1 = S2 + 190 CONTINUE + Y(1) = S1 + IF (N.EQ.1) RETURN + Y(2) = S2 + IF (N.EQ.2) RETURN + DO 200 I=3,N + Y(I) = CK*Y(I-1) - Y(I-2) + CK = CK + RX + 200 CONTINUE + RETURN +C +C ASYMPTOTIC EXPANSION FOR LARGE X, X.GT.X2 +C + 210 CONTINUE + NN = 2 + IF (INU.EQ.0 .AND. N.EQ.1) NN = 1 + DNU2 = DNU + DNU + FMU = 0.0D0 + IF (ABS(DNU2).LT.TOL) GO TO 220 + FMU = DNU2*DNU2 + 220 CONTINUE + ARG = X - HPI*(DNU+0.5D0) + SA = SIN(ARG) + SB = COS(ARG) + ETX = 8.0D0*X + DO 250 K=1,NN + S1 = S2 + T2 = (FMU-1.0D0)/ETX + SS = T2 + RELB = TOL*ABS(T2) + T1 = ETX + S = 1.0D0 + FN = 1.0D0 + AK = 0.0D0 + DO 230 J=1,13 + T1 = T1 + ETX + AK = AK + 8.0D0 + FN = FN + AK + T2 = -T2*(FMU-FN)/T1 + S = S + T2 + T1 = T1 + ETX + AK = AK + 8.0D0 + FN = FN + AK + T2 = T2*(FMU-FN)/T1 + SS = SS + T2 + IF (ABS(T2).LE.RELB) GO TO 240 + 230 CONTINUE + 240 S2 = COEF*(S*SA+SS*SB) + FMU = FMU + 8.0D0*DNU + 4.0D0 + TB = SA + SA = -SB + SB = TB + 250 CONTINUE + IF (NN.GT.1) GO TO 160 + S1 = S2 + GO TO 190 +C +C FNU=HALF ODD INTEGER CASE +C + 260 CONTINUE + COEF = RTHPI/SQRT(X) + S1 = COEF*SIN(X) + S2 = -COEF*COS(X) + GO TO 160 +C +C + 270 CALL XERMSG ('SLATEC', 'DBSYNU', 'X NOT GREATER THAN ZERO', 2, 1) + RETURN + 280 CALL XERMSG ('SLATEC', 'DBSYNU', 'FNU NOT ZERO OR POSITIVE', 2, + + 1) + RETURN + 290 CALL XERMSG ('SLATEC', 'DBSYNU', 'N NOT GREATER THAN 0', 2, 1) + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/dbsynu.lo b/modules/elementary_functions/src/fortran/slatec/dbsynu.lo new file mode 100755 index 000000000..75654f17f --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dbsynu.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dbsynu.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dbsynu.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dcsevl.f b/modules/elementary_functions/src/fortran/slatec/dcsevl.f new file mode 100755 index 000000000..7cff40651 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/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/modules/elementary_functions/src/fortran/slatec/dcsevl.lo b/modules/elementary_functions/src/fortran/slatec/dcsevl.lo new file mode 100755 index 000000000..97d85a996 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dcsevl.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dcsevl.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dcsevl.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dexint.f b/modules/elementary_functions/src/fortran/slatec/dexint.f new file mode 100755 index 000000000..26e8146cd --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dexint.f @@ -0,0 +1,336 @@ +*DECK DEXINT + SUBROUTINE DEXINT (X, N, KODE, M, TOL, EN, NZ, IERR) +C***BEGIN PROLOGUE DEXINT +C***PURPOSE Compute an M member sequence of exponential integrals +C E(N+K,X), K=0,1,...,M-1 for N .GE. 1 and X .GE. 0. +C***LIBRARY SLATEC +C***CATEGORY C5 +C***TYPE DOUBLE PRECISION (EXINT-S, DEXINT-D) +C***KEYWORDS EXPONENTIAL INTEGRAL, SPECIAL FUNCTIONS +C***AUTHOR Amos, D. E., (SNLA) +C***DESCRIPTION +C +C DEXINT computes M member sequences of exponential integrals +C E(N+K,X), K=0,1,...,M-1 for N .GE. 1 and X .GE. 0. The +C exponential integral is defined by +C +C E(N,X)=integral on (1,infinity) of EXP(-XT)/T**N +C +C where X=0.0 and N=1 cannot occur simultaneously. Formulas +C and notation are found in the NBS Handbook of Mathematical +C Functions (ref. 1). +C +C The power series is implemented for X .LE. XCUT and the +C confluent hypergeometric representation +C +C E(A,X) = EXP(-X)*(X**(A-1))*U(A,A,X) +C +C is computed for X .GT. XCUT. Since sequences are computed in +C a stable fashion by recurring away from X, A is selected as +C the integer closest to X within the constraint N .LE. A .LE. +C N+M-1. For the U computation, A is further modified to be the +C nearest even integer. Indices are carried forward or +C backward by the two term recursion relation +C +C K*E(K+1,X) + X*E(K,X) = EXP(-X) +C +C once E(A,X) is computed. The U function is computed by means +C of the backward recursive Miller algorithm applied to the +C three term contiguous relation for U(A+K,A,X), K=0,1,... +C This produces accurate ratios and determines U(A+K,A,X), and +C hence E(A,X), to within a multiplicative constant C. +C Another contiguous relation applied to C*U(A,A,X) and +C C*U(A+1,A,X) gets C*U(A+1,A+1,X), a quantity proportional to +C E(A+1,X). The normalizing constant C is obtained from the +C two term recursion relation above with K=A. +C +C The maximum number of significant digits obtainable +C is the smaller of 14 and the number of digits carried in +C double precision arithmetic. +C +C Description of Arguments +C +C Input * X and TOL are double precision * +C X X .GT. 0.0 for N=1 and X .GE. 0.0 for N .GE. 2 +C N order of the first member of the sequence, N .GE. 1 +C (X=0.0 and N=1 is an error) +C KODE a selection parameter for scaled values +C KODE=1 returns E(N+K,X), K=0,1,...,M-1. +C =2 returns EXP(X)*E(N+K,X), K=0,1,...,M-1. +C M number of exponential integrals in the sequence, +C M .GE. 1 +C TOL relative accuracy wanted, ETOL .LE. TOL .LE. 0.1 +C ETOL is the larger of double precision unit +C roundoff = D1MACH(4) and 1.0D-18 +C +C Output * EN is a double precision vector * +C EN a vector of dimension at least M containing values +C EN(K) = E(N+K-1,X) or EXP(X)*E(N+K-1,X), K=1,M +C depending on KODE +C NZ underflow indicator +C NZ=0 a normal return +C NZ=M X exceeds XLIM and an underflow occurs. +C EN(K)=0.0D0 , K=1,M returned on KODE=1 +C IERR error flag +C IERR=0, normal return, computation completed +C IERR=1, input error, no computation +C IERR=2, error, no computation +C algorithm termination condition not met +C +C***REFERENCES M. Abramowitz and I. A. Stegun, Handbook of +C Mathematical Functions, NBS AMS Series 55, U.S. Dept. +C of Commerce, 1955. +C D. E. Amos, Computation of exponential integrals, ACM +C Transactions on Mathematical Software 6, (1980), +C pp. 365-377 and pp. 420-428. +C***ROUTINES CALLED D1MACH, DPSIXN, I1MACH +C***REVISION HISTORY (YYMMDD) +C 800501 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 910408 Updated the REFERENCES section. (WRB) +C 920207 Updated with code with a revision date of 880811 from +C D. Amos. Included correction of argument list. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DEXINT + DOUBLE PRECISION A,AA,AAMS,AH,AK,AT,B,BK,BT,CC,CNORM,CT,EM,EMX,EN, + 1 ETOL,FNM,FX,PT,P1,P2,S,TOL,TX,X,XCUT,XLIM,XTOL,Y, + 2 YT,Y1,Y2 + DOUBLE PRECISION D1MACH,DPSIXN + INTEGER I,IC,ICASE,ICT,IERR,IK,IND,IX,I1M,JSET,K,KK,KN,KODE,KS,M, + 1 ML,MU,N,ND,NM,NZ + INTEGER I1MACH + DIMENSION EN(*), A(99), B(99), Y(2) + SAVE XCUT + DATA XCUT / 2.0D0 / +C***FIRST EXECUTABLE STATEMENT DEXINT + IERR = 0 + NZ = 0 + ETOL = MAX(D1MACH(4),0.5D-18) + IF (X.LT.0.0D0) IERR = 1 + IF (N.LT.1) IERR = 1 + IF (KODE.LT.1 .OR. KODE.GT.2) IERR = 1 + IF (M.LT.1) IERR = 1 + IF (TOL.LT.ETOL .OR. TOL.GT.0.1D0) IERR = 1 + IF (X.EQ.0.0D0 .AND. N.EQ.1) IERR = 1 + IF(IERR.NE.0) RETURN + I1M = -I1MACH(15) + PT = 2.3026D0*I1M*D1MACH(5) + XLIM = PT - 6.907755D0 + BT = PT + (N+M-1) + IF (BT.GT.1000.0D0) XLIM = PT - LOG(BT) +C + IF (X.GT.XCUT) GO TO 100 + IF (X.EQ.0.0D0 .AND. N.GT.1) GO TO 80 +C----------------------------------------------------------------------- +C SERIES FOR E(N,X) FOR X.LE.XCUT +C----------------------------------------------------------------------- + TX = X + 0.5D0 + IX = TX +C----------------------------------------------------------------------- +C ICASE=1 MEANS INTEGER CLOSEST TO X IS 2 AND N=1 +C ICASE=2 MEANS INTEGER CLOSEST TO X IS 0,1, OR 2 AND N.GE.2 +C----------------------------------------------------------------------- + ICASE = 2 + IF (IX.GT.N) ICASE = 1 + NM = N - ICASE + 1 + ND = NM + 1 + IND = 3 - ICASE + MU = M - IND + ML = 1 + KS = ND + FNM = NM + S = 0.0D0 + XTOL = 3.0D0*TOL + IF (ND.EQ.1) GO TO 10 + XTOL = 0.3333D0*TOL + S = 1.0D0/FNM + 10 CONTINUE + AA = 1.0D0 + AK = 1.0D0 + IC = 35 + IF (X.LT.ETOL) IC = 1 + DO 50 I=1,IC + AA = -AA*X/AK + IF (I.EQ.NM) GO TO 30 + S = S - AA/(AK-FNM) + IF (ABS(AA).LE.XTOL*ABS(S)) GO TO 20 + AK = AK + 1.0D0 + GO TO 50 + 20 CONTINUE + IF (I.LT.2) GO TO 40 + IF (ND-2.GT.I .OR. I.GT.ND-1) GO TO 60 + AK = AK + 1.0D0 + GO TO 50 + 30 S = S + AA*(-LOG(X)+DPSIXN(ND)) + XTOL = 3.0D0*TOL + 40 AK = AK + 1.0D0 + 50 CONTINUE + IF (IC.NE.1) GO TO 340 + 60 IF (ND.EQ.1) S = S + (-LOG(X)+DPSIXN(1)) + IF (KODE.EQ.2) S = S*EXP(X) + EN(1) = S + EMX = 1.0D0 + IF (M.EQ.1) GO TO 70 + EN(IND) = S + AA = KS + IF (KODE.EQ.1) EMX = EXP(-X) + GO TO (220, 240), ICASE + 70 IF (ICASE.EQ.2) RETURN + IF (KODE.EQ.1) EMX = EXP(-X) + EN(1) = (EMX-S)/X + RETURN + 80 CONTINUE + DO 90 I=1,M + EN(I) = 1.0D0/(N+I-2) + 90 CONTINUE + RETURN +C----------------------------------------------------------------------- +C BACKWARD RECURSIVE MILLER ALGORITHM FOR +C E(N,X)=EXP(-X)*(X**(N-1))*U(N,N,X) +C WITH RECURSION AWAY FROM N=INTEGER CLOSEST TO X. +C U(A,B,X) IS THE SECOND CONFLUENT HYPERGEOMETRIC FUNCTION +C----------------------------------------------------------------------- + 100 CONTINUE + EMX = 1.0D0 + IF (KODE.EQ.2) GO TO 130 + IF (X.LE.XLIM) GO TO 120 + NZ = M + DO 110 I=1,M + EN(I) = 0.0D0 + 110 CONTINUE + RETURN + 120 EMX = EXP(-X) + 130 CONTINUE + TX = X + 0.5D0 + IX = TX + KN = N + M - 1 + IF (KN.LE.IX) GO TO 140 + IF (N.LT.IX .AND. IX.LT.KN) GO TO 170 + IF (N.GE.IX) GO TO 160 + GO TO 340 + 140 ICASE = 1 + KS = KN + ML = M - 1 + MU = -1 + IND = M + IF (KN.GT.1) GO TO 180 + 150 KS = 2 + ICASE = 3 + GO TO 180 + 160 ICASE = 2 + IND = 1 + KS = N + MU = M - 1 + IF (N.GT.1) GO TO 180 + IF (KN.EQ.1) GO TO 150 + IX = 2 + 170 ICASE = 1 + KS = IX + ML = IX - N + IND = ML + 1 + MU = KN - IX + 180 CONTINUE + IK = KS/2 + AH = IK + JSET = 1 + KS - (IK+IK) +C----------------------------------------------------------------------- +C START COMPUTATION FOR +C EN(IND) = C*U( A , A ,X) JSET=1 +C EN(IND) = C*U(A+1,A+1,X) JSET=2 +C FOR AN EVEN INTEGER A. +C----------------------------------------------------------------------- + IC = 0 + AA = AH + AH + AAMS = AA - 1.0D0 + AAMS = AAMS*AAMS + TX = X + X + FX = TX + TX + AK = AH + XTOL = TOL + IF (TOL.LE.1.0D-3) XTOL = 20.0D0*TOL + CT = AAMS + FX*AH + EM = (AH+1.0D0)/((X+AA)*XTOL*SQRT(CT)) + BK = AA + CC = AH*AH +C----------------------------------------------------------------------- +C FORWARD RECURSION FOR P(IC),P(IC+1) AND INDEX IC FOR BACKWARD +C RECURSION +C----------------------------------------------------------------------- + P1 = 0.0D0 + P2 = 1.0D0 + 190 CONTINUE + IF (IC.EQ.99) GO TO 340 + IC = IC + 1 + AK = AK + 1.0D0 + AT = BK/(BK+AK+CC+IC) + BK = BK + AK + AK + A(IC) = AT + BT = (AK+AK+X)/(AK+1.0D0) + B(IC) = BT + PT = P2 + P2 = BT*P2 - AT*P1 + P1 = PT + CT = CT + FX + EM = EM*AT*(1.0D0-TX/CT) + IF (EM*(AK+1.0D0).GT.P1*P1) GO TO 190 + ICT = IC + KK = IC + 1 + BT = TX/(CT+FX) + Y2 = (BK/(BK+CC+KK))*(P1/P2)*(1.0D0-BT+0.375D0*BT*BT) + Y1 = 1.0D0 +C----------------------------------------------------------------------- +C BACKWARD RECURRENCE FOR +C Y1= C*U( A ,A,X) +C Y2= C*(A/(1+A/2))*U(A+1,A,X) +C----------------------------------------------------------------------- + DO 200 K=1,ICT + KK = KK - 1 + YT = Y1 + Y1 = (B(KK)*Y1-Y2)/A(KK) + Y2 = YT + 200 CONTINUE +C----------------------------------------------------------------------- +C THE CONTIGUOUS RELATION +C X*U(B,C+1,X)=(C-B)*U(B,C,X)+U(B-1,C,X) +C WITH B=A+1 , C=A IS USED FOR +C Y(2) = C * U(A+1,A+1,X) +C X IS INCORPORATED INTO THE NORMALIZING RELATION +C----------------------------------------------------------------------- + PT = Y2/Y1 + CNORM = 1.0E0 - PT*(AH+1.0E0)/AA + Y(1) = 1.0E0/(CNORM*AA+X) + Y(2) = CNORM*Y(1) + IF (ICASE.EQ.3) GO TO 210 + EN(IND) = EMX*Y(JSET) + IF (M.EQ.1) RETURN + AA = KS + GO TO (220, 240), ICASE +C----------------------------------------------------------------------- +C RECURSION SECTION N*E(N+1,X) + X*E(N,X)=EMX +C----------------------------------------------------------------------- + 210 EN(1) = EMX*(1.0E0-Y(1))/X + RETURN + 220 K = IND - 1 + DO 230 I=1,ML + AA = AA - 1.0D0 + EN(K) = (EMX-AA*EN(K+1))/X + K = K - 1 + 230 CONTINUE + IF (MU.LE.0) RETURN + AA = KS + 240 K = IND + DO 250 I=1,MU + EN(K+1) = (EMX-X*EN(K))/AA + AA = AA + 1.0D0 + K = K + 1 + 250 CONTINUE + RETURN + 340 CONTINUE + IERR = 2 + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/dexint.lo b/modules/elementary_functions/src/fortran/slatec/dexint.lo new file mode 100755 index 000000000..08a9496a9 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dexint.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dexint.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dexint.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dgamlm.f b/modules/elementary_functions/src/fortran/slatec/dgamlm.f new file mode 100755 index 000000000..7604c883f --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dgamlm.f @@ -0,0 +1,62 @@ +*DECK DGAMLM + SUBROUTINE DGAMLM (XMIN, XMAX) +C***BEGIN PROLOGUE DGAMLM +C***PURPOSE Compute the minimum and maximum bounds for the argument in +C the Gamma function. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C7A, R2 +C***TYPE DOUBLE PRECISION (GAMLIM-S, DGAMLM-D) +C***KEYWORDS COMPLETE GAMMA FUNCTION, FNLIB, LIMITS, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C Calculate the minimum and maximum legal bounds for X in gamma(X). +C XMIN and XMAX are not the only bounds, but they are the only non- +C trivial ones to calculate. +C +C Output Arguments -- +C XMIN double precision minimum legal value of X in gamma(X). Any +C smaller value of X might result in underflow. +C XMAX double precision maximum legal value of X in gamma(X). Any +C larger value of X might cause overflow. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770601 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 DGAMLM + DOUBLE PRECISION XMIN, XMAX, ALNBIG, ALNSML, XLN, XOLD, D1MACH +C***FIRST EXECUTABLE STATEMENT DGAMLM + ALNSML = LOG(D1MACH(1)) + XMIN = -ALNSML + DO 10 I=1,10 + XOLD = XMIN + XLN = LOG(XMIN) + XMIN = XMIN - XMIN*((XMIN+0.5D0)*XLN - XMIN - 0.2258D0 + ALNSML) + 1 / (XMIN*XLN+0.5D0) + IF (ABS(XMIN-XOLD).LT.0.005D0) GO TO 20 + 10 CONTINUE + CALL XERMSG ('SLATEC', 'DGAMLM', 'UNABLE TO FIND XMIN', 1, 2) +C + 20 XMIN = -XMIN + 0.01D0 +C + ALNBIG = LOG (D1MACH(2)) + XMAX = ALNBIG + DO 30 I=1,10 + XOLD = XMAX + XLN = LOG(XMAX) + XMAX = XMAX - XMAX*((XMAX-0.5D0)*XLN - XMAX + 0.9189D0 - ALNBIG) + 1 / (XMAX*XLN-0.5D0) + IF (ABS(XMAX-XOLD).LT.0.005D0) GO TO 40 + 30 CONTINUE + CALL XERMSG ('SLATEC', 'DGAMLM', 'UNABLE TO FIND XMAX', 2, 2) +C + 40 XMAX = XMAX - 0.01D0 + XMIN = MAX (XMIN, -XMAX+1.D0) +C + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/dgamlm.lo b/modules/elementary_functions/src/fortran/slatec/dgamlm.lo new file mode 100755 index 000000000..ddad8e10f --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dgamlm.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dgamlm.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dgamlm.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dgamln.f b/modules/elementary_functions/src/fortran/slatec/dgamln.f new file mode 100755 index 000000000..bd2131f64 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dgamln.f @@ -0,0 +1,198 @@ +*DECK DGAMLN + DOUBLE PRECISION FUNCTION DGAMLN (Z, IERR) +C***BEGIN PROLOGUE DGAMLN +C***SUBSIDIARY +C***PURPOSE Compute the logarithm of the Gamma function +C***LIBRARY SLATEC +C***CATEGORY C7A +C***TYPE DOUBLE PRECISION (GAMLN-S, DGAMLN-D) +C***KEYWORDS LOGARITHM OF GAMMA FUNCTION +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C **** A DOUBLE PRECISION ROUTINE **** +C DGAMLN COMPUTES THE NATURAL LOG OF THE GAMMA FUNCTION FOR +C Z.GT.0. THE ASYMPTOTIC EXPANSION IS USED TO GENERATE VALUES +C GREATER THAN ZMIN WHICH ARE ADJUSTED BY THE RECURSION +C G(Z+1)=Z*G(Z) FOR Z.LE.ZMIN. THE FUNCTION WAS MADE AS +C PORTABLE AS POSSIBLE BY COMPUTING ZMIN FROM THE NUMBER OF BASE +C 10 DIGITS IN A WORD, RLN=MAX(-ALOG10(R1MACH(4)),0.5E-18) +C LIMITED TO 18 DIGITS OF (RELATIVE) ACCURACY. +C +C SINCE INTEGER ARGUMENTS ARE COMMON, A TABLE LOOK UP ON 100 +C VALUES IS USED FOR SPEED OF EXECUTION. +C +C DESCRIPTION OF ARGUMENTS +C +C INPUT Z IS D0UBLE PRECISION +C Z - ARGUMENT, Z.GT.0.0D0 +C +C OUTPUT DGAMLN IS DOUBLE PRECISION +C DGAMLN - NATURAL LOG OF THE GAMMA FUNCTION AT Z.NE.0.0D0 +C IERR - ERROR FLAG +C IERR=0, NORMAL RETURN, COMPUTATION COMPLETED +C IERR=1, Z.LE.0.0D0, NO COMPUTATION +C +C +C***REFERENCES COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT +C BY D. E. AMOS, SAND83-0083, MAY, 1983. +C***ROUTINES CALLED D1MACH, I1MACH +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 830501 REVISION DATE from Version 3.2 +C 910415 Prologue converted to Version 4.0 format. (BAB) +C 920128 Category corrected. (WRB) +C 921215 DGAMLN defined for Z negative. (WRB) +C***END PROLOGUE DGAMLN + DOUBLE PRECISION CF, CON, FLN, FZ, GLN, RLN, S, TLG, TRM, TST, + * T1, WDTOL, Z, ZDMY, ZINC, ZM, ZMIN, ZP, ZSQ, D1MACH + INTEGER I, IERR, I1M, K, MZ, NZ, I1MACH + DIMENSION CF(22), GLN(100) +C LNGAMMA(N), N=1,100 + DATA GLN(1), GLN(2), GLN(3), GLN(4), GLN(5), GLN(6), GLN(7), + 1 GLN(8), GLN(9), GLN(10), GLN(11), GLN(12), GLN(13), GLN(14), + 2 GLN(15), GLN(16), GLN(17), GLN(18), GLN(19), GLN(20), + 3 GLN(21), GLN(22)/ + 4 0.00000000000000000D+00, 0.00000000000000000D+00, + 5 6.93147180559945309D-01, 1.79175946922805500D+00, + 6 3.17805383034794562D+00, 4.78749174278204599D+00, + 7 6.57925121201010100D+00, 8.52516136106541430D+00, + 8 1.06046029027452502D+01, 1.28018274800814696D+01, + 9 1.51044125730755153D+01, 1.75023078458738858D+01, + A 1.99872144956618861D+01, 2.25521638531234229D+01, + B 2.51912211827386815D+01, 2.78992713838408916D+01, + C 3.06718601060806728D+01, 3.35050734501368889D+01, + D 3.63954452080330536D+01, 3.93398841871994940D+01, + E 4.23356164607534850D+01, 4.53801388984769080D+01/ + DATA GLN(23), GLN(24), GLN(25), GLN(26), GLN(27), GLN(28), + 1 GLN(29), GLN(30), GLN(31), GLN(32), GLN(33), GLN(34), + 2 GLN(35), GLN(36), GLN(37), GLN(38), GLN(39), GLN(40), + 3 GLN(41), GLN(42), GLN(43), GLN(44)/ + 4 4.84711813518352239D+01, 5.16066755677643736D+01, + 5 5.47847293981123192D+01, 5.80036052229805199D+01, + 6 6.12617017610020020D+01, 6.45575386270063311D+01, + 7 6.78897431371815350D+01, 7.12570389671680090D+01, + 8 7.46582363488301644D+01, 7.80922235533153106D+01, + 9 8.15579594561150372D+01, 8.50544670175815174D+01, + A 8.85808275421976788D+01, 9.21361756036870925D+01, + B 9.57196945421432025D+01, 9.93306124547874269D+01, + C 1.02968198614513813D+02, 1.06631760260643459D+02, + D 1.10320639714757395D+02, 1.14034211781461703D+02, + E 1.17771881399745072D+02, 1.21533081515438634D+02/ + DATA GLN(45), GLN(46), GLN(47), GLN(48), GLN(49), GLN(50), + 1 GLN(51), GLN(52), GLN(53), GLN(54), GLN(55), GLN(56), + 2 GLN(57), GLN(58), GLN(59), GLN(60), GLN(61), GLN(62), + 3 GLN(63), GLN(64), GLN(65), GLN(66)/ + 4 1.25317271149356895D+02, 1.29123933639127215D+02, + 5 1.32952575035616310D+02, 1.36802722637326368D+02, + 6 1.40673923648234259D+02, 1.44565743946344886D+02, + 7 1.48477766951773032D+02, 1.52409592584497358D+02, + 8 1.56360836303078785D+02, 1.60331128216630907D+02, + 9 1.64320112263195181D+02, 1.68327445448427652D+02, + A 1.72352797139162802D+02, 1.76395848406997352D+02, + B 1.80456291417543771D+02, 1.84533828861449491D+02, + C 1.88628173423671591D+02, 1.92739047287844902D+02, + D 1.96866181672889994D+02, 2.01009316399281527D+02, + E 2.05168199482641199D+02, 2.09342586752536836D+02/ + DATA GLN(67), GLN(68), GLN(69), GLN(70), GLN(71), GLN(72), + 1 GLN(73), GLN(74), GLN(75), GLN(76), GLN(77), GLN(78), + 2 GLN(79), GLN(80), GLN(81), GLN(82), GLN(83), GLN(84), + 3 GLN(85), GLN(86), GLN(87), GLN(88)/ + 4 2.13532241494563261D+02, 2.17736934113954227D+02, + 5 2.21956441819130334D+02, 2.26190548323727593D+02, + 6 2.30439043565776952D+02, 2.34701723442818268D+02, + 7 2.38978389561834323D+02, 2.43268849002982714D+02, + 8 2.47572914096186884D+02, 2.51890402209723194D+02, + 9 2.56221135550009525D+02, 2.60564940971863209D+02, + A 2.64921649798552801D+02, 2.69291097651019823D+02, + B 2.73673124285693704D+02, 2.78067573440366143D+02, + C 2.82474292687630396D+02, 2.86893133295426994D+02, + D 2.91323950094270308D+02, 2.95766601350760624D+02, + E 3.00220948647014132D+02, 3.04686856765668715D+02/ + DATA GLN(89), GLN(90), GLN(91), GLN(92), GLN(93), GLN(94), + 1 GLN(95), GLN(96), GLN(97), GLN(98), GLN(99), GLN(100)/ + 2 3.09164193580146922D+02, 3.13652829949879062D+02, + 3 3.18152639620209327D+02, 3.22663499126726177D+02, + 4 3.27185287703775217D+02, 3.31717887196928473D+02, + 5 3.36261181979198477D+02, 3.40815058870799018D+02, + 6 3.45379407062266854D+02, 3.49954118040770237D+02, + 7 3.54539085519440809D+02, 3.59134205369575399D+02/ +C COEFFICIENTS OF ASYMPTOTIC EXPANSION + DATA CF(1), CF(2), CF(3), CF(4), CF(5), CF(6), CF(7), CF(8), + 1 CF(9), CF(10), CF(11), CF(12), CF(13), CF(14), CF(15), + 2 CF(16), CF(17), CF(18), CF(19), CF(20), CF(21), CF(22)/ + 3 8.33333333333333333D-02, -2.77777777777777778D-03, + 4 7.93650793650793651D-04, -5.95238095238095238D-04, + 5 8.41750841750841751D-04, -1.91752691752691753D-03, + 6 6.41025641025641026D-03, -2.95506535947712418D-02, + 7 1.79644372368830573D-01, -1.39243221690590112D+00, + 8 1.34028640441683920D+01, -1.56848284626002017D+02, + 9 2.19310333333333333D+03, -3.61087712537249894D+04, + A 6.91472268851313067D+05, -1.52382215394074162D+07, + B 3.82900751391414141D+08, -1.08822660357843911D+10, + C 3.47320283765002252D+11, -1.23696021422692745D+13, + D 4.88788064793079335D+14, -2.13203339609193739D+16/ +C +C LN(2*PI) + DATA CON / 1.83787706640934548D+00/ +C +C***FIRST EXECUTABLE STATEMENT DGAMLN + IERR=0 + IF (Z.LE.0.0D0) GO TO 70 + IF (Z.GT.101.0D0) GO TO 10 + NZ = Z + FZ = Z - NZ + IF (FZ.GT.0.0D0) GO TO 10 + IF (NZ.GT.100) GO TO 10 + DGAMLN = GLN(NZ) + RETURN + 10 CONTINUE + WDTOL = D1MACH(4) + WDTOL = MAX(WDTOL,0.5D-18) + I1M = I1MACH(14) + RLN = D1MACH(5)*I1M + FLN = MIN(RLN,20.0D0) + FLN = MAX(FLN,3.0D0) + FLN = FLN - 3.0D0 + ZM = 1.8000D0 + 0.3875D0*FLN + MZ = ZM + 1 + ZMIN = MZ + ZDMY = Z + ZINC = 0.0D0 + IF (Z.GE.ZMIN) GO TO 20 + ZINC = ZMIN - NZ + ZDMY = Z + ZINC + 20 CONTINUE + ZP = 1.0D0/ZDMY + T1 = CF(1)*ZP + S = T1 + IF (ZP.LT.WDTOL) GO TO 40 + ZSQ = ZP*ZP + TST = T1*WDTOL + DO 30 K=2,22 + ZP = ZP*ZSQ + TRM = CF(K)*ZP + IF (ABS(TRM).LT.TST) GO TO 40 + S = S + TRM + 30 CONTINUE + 40 CONTINUE + IF (ZINC.NE.0.0D0) GO TO 50 + TLG = LOG(Z) + DGAMLN = Z*(TLG-1.0D0) + 0.5D0*(CON-TLG) + S + RETURN + 50 CONTINUE + ZP = 1.0D0 + NZ = ZINC + DO 60 I=1,NZ + ZP = ZP*(Z+(I-1)) + 60 CONTINUE + TLG = LOG(ZDMY) + DGAMLN = ZDMY*(TLG-1.0D0) - LOG(ZP) + 0.5D0*(CON-TLG) + S + RETURN +C +C + 70 CONTINUE + DGAMLN = D1MACH(2) + IERR=1 + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/dgamln.lo b/modules/elementary_functions/src/fortran/slatec/dgamln.lo new file mode 100755 index 000000000..822b2f4c8 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dgamln.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dgamln.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dgamln.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dgamma.f b/modules/elementary_functions/src/fortran/slatec/dgamma.f new file mode 100755 index 000000000..7b2c183da --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dgamma.f @@ -0,0 +1,153 @@ +*DECK DGAMMA + DOUBLE PRECISION FUNCTION DGAMMA (X) +C***BEGIN PROLOGUE DGAMMA +C***PURPOSE Compute the complete Gamma function. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C7A +C***TYPE DOUBLE PRECISION (GAMMA-S, DGAMMA-D, CGAMMA-C) +C***KEYWORDS COMPLETE GAMMA FUNCTION, FNLIB, SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C DGAMMA(X) calculates the double precision complete Gamma function +C for double precision argument X. +C +C Series for GAM on the interval 0. to 1.00000E+00 +C with weighted error 5.79E-32 +C log weighted error 31.24 +C significant figures required 30.00 +C decimal places required 32.05 +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, D9LGMC, DCSEVL, DGAMLM, INITDS, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770601 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 920618 Removed space from variable name. (RWC, WRB) +C***END PROLOGUE DGAMMA + DOUBLE PRECISION X, GAMCS(42), DXREL, PI, SINPIY, SQ2PIL, XMAX, + 1 XMIN, Y, D9LGMC, DCSEVL, D1MACH + LOGICAL FIRST +C + SAVE GAMCS, PI, SQ2PIL, NGAM, XMIN, XMAX, DXREL, FIRST + DATA GAMCS( 1) / +.8571195590 9893314219 2006239994 2 D-2 / + DATA GAMCS( 2) / +.4415381324 8410067571 9131577165 2 D-2 / + DATA GAMCS( 3) / +.5685043681 5993633786 3266458878 9 D-1 / + DATA GAMCS( 4) / -.4219835396 4185605010 1250018662 4 D-2 / + DATA GAMCS( 5) / +.1326808181 2124602205 8400679635 2 D-2 / + DATA GAMCS( 6) / -.1893024529 7988804325 2394702388 6 D-3 / + DATA GAMCS( 7) / +.3606925327 4412452565 7808221722 5 D-4 / + DATA GAMCS( 8) / -.6056761904 4608642184 8554829036 5 D-5 / + DATA GAMCS( 9) / +.1055829546 3022833447 3182350909 3 D-5 / + DATA GAMCS( 10) / -.1811967365 5423840482 9185589116 6 D-6 / + DATA GAMCS( 11) / +.3117724964 7153222777 9025459316 9 D-7 / + DATA GAMCS( 12) / -.5354219639 0196871408 7408102434 7 D-8 / + DATA GAMCS( 13) / +.9193275519 8595889468 8778682594 0 D-9 / + DATA GAMCS( 14) / -.1577941280 2883397617 6742327395 3 D-9 / + DATA GAMCS( 15) / +.2707980622 9349545432 6654043308 9 D-10 / + DATA GAMCS( 16) / -.4646818653 8257301440 8166105893 3 D-11 / + DATA GAMCS( 17) / +.7973350192 0074196564 6076717535 9 D-12 / + DATA GAMCS( 18) / -.1368078209 8309160257 9949917230 9 D-12 / + DATA GAMCS( 19) / +.2347319486 5638006572 3347177168 8 D-13 / + DATA GAMCS( 20) / -.4027432614 9490669327 6657053469 9 D-14 / + DATA GAMCS( 21) / +.6910051747 3721009121 3833697525 7 D-15 / + DATA GAMCS( 22) / -.1185584500 2219929070 5238712619 2 D-15 / + DATA GAMCS( 23) / +.2034148542 4963739552 0102605193 2 D-16 / + DATA GAMCS( 24) / -.3490054341 7174058492 7401294910 8 D-17 / + DATA GAMCS( 25) / +.5987993856 4853055671 3505106602 6 D-18 / + DATA GAMCS( 26) / -.1027378057 8722280744 9006977843 1 D-18 / + DATA GAMCS( 27) / +.1762702816 0605298249 4275966074 8 D-19 / + DATA GAMCS( 28) / -.3024320653 7353062609 5877211204 2 D-20 / + DATA GAMCS( 29) / +.5188914660 2183978397 1783355050 6 D-21 / + DATA GAMCS( 30) / -.8902770842 4565766924 4925160106 6 D-22 / + DATA GAMCS( 31) / +.1527474068 4933426022 7459689130 6 D-22 / + DATA GAMCS( 32) / -.2620731256 1873629002 5732833279 9 D-23 / + DATA GAMCS( 33) / +.4496464047 8305386703 3104657066 6 D-24 / + DATA GAMCS( 34) / -.7714712731 3368779117 0390152533 3 D-25 / + DATA GAMCS( 35) / +.1323635453 1260440364 8657271466 6 D-25 / + DATA GAMCS( 36) / -.2270999412 9429288167 0231381333 3 D-26 / + DATA GAMCS( 37) / +.3896418998 0039914493 2081663999 9 D-27 / + DATA GAMCS( 38) / -.6685198115 1259533277 9212799999 9 D-28 / + DATA GAMCS( 39) / +.1146998663 1400243843 4761386666 6 D-28 / + DATA GAMCS( 40) / -.1967938586 3451346772 9510399999 9 D-29 / + DATA GAMCS( 41) / +.3376448816 5853380903 3489066666 6 D-30 / + DATA GAMCS( 42) / -.5793070335 7821357846 2549333333 3 D-31 / + DATA PI / 3.1415926535 8979323846 2643383279 50 D0 / + DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 / + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DGAMMA + IF (FIRST) THEN + NGAM = INITDS (GAMCS, 42, 0.1*REAL(D1MACH(3)) ) +C + CALL DGAMLM (XMIN, XMAX) + DXREL = SQRT(D1MACH(4)) + ENDIF + FIRST = .FALSE. +C + Y = ABS(X) + IF (Y.GT.10.D0) GO TO 50 +C +C COMPUTE GAMMA(X) FOR -XBND .LE. X .LE. XBND. REDUCE INTERVAL AND FIND +C GAMMA(1+Y) FOR 0.0 .LE. Y .LT. 1.0 FIRST OF ALL. +C + N = X + IF (X.LT.0.D0) N = N - 1 + Y = X - N + N = N - 1 + DGAMMA = 0.9375D0 + DCSEVL (2.D0*Y-1.D0, GAMCS, NGAM) + IF (N.EQ.0) RETURN +C + IF (N.GT.0) GO TO 30 +C +C COMPUTE GAMMA(X) FOR X .LT. 1.0 +C + N = -N + IF (X .EQ. 0.D0) CALL XERMSG ('SLATEC', 'DGAMMA', 'X IS 0', 4, 2) + IF (X .LT. 0.0 .AND. X+N-2 .EQ. 0.D0) CALL XERMSG ('SLATEC', + + 'DGAMMA', 'X IS A NEGATIVE INTEGER', 4, 2) + IF (X .LT. (-0.5D0) .AND. ABS((X-AINT(X-0.5D0))/X) .LT. DXREL) + + CALL XERMSG ('SLATEC', 'DGAMMA', + + 'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE INTEGER', + + 1, 1) +C + DO 20 I=1,N + DGAMMA = DGAMMA/(X+I-1 ) + 20 CONTINUE + RETURN +C +C GAMMA(X) FOR X .GE. 2.0 AND X .LE. 10.0 +C + 30 DO 40 I=1,N + DGAMMA = (Y+I) * DGAMMA + 40 CONTINUE + RETURN +C +C GAMMA(X) FOR ABS(X) .GT. 10.0. RECALL Y = ABS(X). +C + 50 IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'DGAMMA', + + 'X SO BIG GAMMA OVERFLOWS', 3, 2) +C + DGAMMA = 0.D0 + IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'DGAMMA', + + 'X SO SMALL GAMMA UNDERFLOWS', 2, 1) + IF (X.LT.XMIN) RETURN +C + DGAMMA = EXP ((Y-0.5D0)*LOG(Y) - Y + SQ2PIL + D9LGMC(Y) ) + IF (X.GT.0.D0) RETURN +C + IF (ABS((X-AINT(X-0.5D0))/X) .LT. DXREL) CALL XERMSG ('SLATEC', + + 'DGAMMA', + + 'ANSWER LT HALF PRECISION, X TOO NEAR NEGATIVE INTEGER', 1, 1) +C + SINPIY = SIN (PI*Y) + IF (SINPIY .EQ. 0.D0) CALL XERMSG ('SLATEC', 'DGAMMA', + + 'X IS A NEGATIVE INTEGER', 4, 2) +C + DGAMMA = -PI/(Y*SINPIY*DGAMMA) +C + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/dgamma.lo b/modules/elementary_functions/src/fortran/slatec/dgamma.lo new file mode 100755 index 000000000..9ccbe61a3 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dgamma.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dgamma.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dgamma.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dgamrn.f b/modules/elementary_functions/src/fortran/slatec/dgamrn.f new file mode 100755 index 000000000..bbd685e29 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dgamrn.f @@ -0,0 +1,107 @@ +*DECK DGAMRN + DOUBLE PRECISION FUNCTION DGAMRN (X) +C***BEGIN PROLOGUE DGAMRN +C***SUBSIDIARY +C***PURPOSE Subsidiary to DBSKIN +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (GAMRN-S, DGAMRN-D) +C***AUTHOR Amos, D. E., (SNLA) +C***DESCRIPTION +C +C Abstract * A Double Precision Routine * +C DGAMRN computes the GAMMA function ratio GAMMA(X)/GAMMA(X+0.5) +C for real X.gt.0. If X.ge.XMIN, an asymptotic expansion is +C evaluated. If X.lt.XMIN, an integer is added to X to form a +C new value of X.ge.XMIN and the asymptotic expansion is eval- +C uated for this new value of X. Successive application of the +C recurrence relation +C +C W(X)=W(X+1)*(1+0.5/X) +C +C reduces the argument to its original value. XMIN and comp- +C utational tolerances are computed as a function of the number +C of digits carried in a word by calls to I1MACH and D1MACH. +C However, the computational accuracy is limited to the max- +C imum of unit roundoff (=D1MACH(4)) and 1.0D-18 since critical +C constants are given to only 18 digits. +C +C Input X is Double Precision +C X - Argument, X.gt.0.0D0 +C +C Output DGAMRN is DOUBLE PRECISION +C DGAMRN - Ratio GAMMA(X)/GAMMA(X+0.5) +C +C***SEE ALSO DBSKIN +C***REFERENCES Y. L. Luke, The Special Functions and Their +C Approximations, Vol. 1, Math In Sci. And +C Eng. Series 53, Academic Press, New York, 1969, +C pp. 34-35. +C***ROUTINES CALLED D1MACH, I1MACH +C***REVISION HISTORY (YYMMDD) +C 820601 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890911 Removed unnecessary intrinsics. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 910722 Updated AUTHOR section. (ALS) +C 920520 Added REFERENCES section. (WRB) +C***END PROLOGUE DGAMRN + INTEGER I, I1M11, K, MX, NX + INTEGER I1MACH + DOUBLE PRECISION FLN, GR, RLN, S, TOL, TRM, X, XDMY, XINC, XM, + * XMIN, XP, XSQ + DOUBLE PRECISION D1MACH + DIMENSION GR(12) + SAVE GR +C + DATA GR(1), GR(2), GR(3), GR(4), GR(5), GR(6), GR(7), GR(8), + * GR(9), GR(10), GR(11), GR(12) /1.00000000000000000D+00, + * -1.56250000000000000D-02,2.56347656250000000D-03, + * -1.27983093261718750D-03,1.34351104497909546D-03, + * -2.43289663922041655D-03,6.75423753364157164D-03, + * -2.66369606131178216D-02,1.41527455519564332D-01, + * -9.74384543032201613D-01,8.43686251229783675D+00, + * -8.97258321640552515D+01/ +C +C***FIRST EXECUTABLE STATEMENT DGAMRN + NX = INT(X) + TOL = MAX(D1MACH(4),1.0D-18) + I1M11 = I1MACH(14) + RLN = D1MACH(5)*I1M11 + FLN = MIN(RLN,20.0D0) + FLN = MAX(FLN,3.0D0) + FLN = FLN - 3.0D0 + XM = 2.0D0 + FLN*(0.2366D0+0.01723D0*FLN) + MX = INT(XM) + 1 + XMIN = MX + XDMY = X - 0.25D0 + XINC = 0.0D0 + IF (X.GE.XMIN) GO TO 10 + XINC = XMIN - NX + XDMY = XDMY + XINC + 10 CONTINUE + S = 1.0D0 + IF (XDMY*TOL.GT.1.0D0) GO TO 30 + XSQ = 1.0D0/(XDMY*XDMY) + XP = XSQ + DO 20 K=2,12 + TRM = GR(K)*XP + IF (ABS(TRM).LT.TOL) GO TO 30 + S = S + TRM + XP = XP*XSQ + 20 CONTINUE + 30 CONTINUE + S = S/SQRT(XDMY) + IF (XINC.NE.0.0D0) GO TO 40 + DGAMRN = S + RETURN + 40 CONTINUE + NX = INT(XINC) + XP = 0.0D0 + DO 50 I=1,NX + S = S*(1.0D0+0.5D0/(X+XP)) + XP = XP + 1.0D0 + 50 CONTINUE + DGAMRN = S + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/dgamrn.lo b/modules/elementary_functions/src/fortran/slatec/dgamrn.lo new file mode 100755 index 000000000..188bf93f8 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dgamrn.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dgamrn.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dgamrn.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dhkseq.f b/modules/elementary_functions/src/fortran/slatec/dhkseq.f new file mode 100755 index 000000000..beecd09dc --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dhkseq.f @@ -0,0 +1,159 @@ +*DECK DHKSEQ + SUBROUTINE DHKSEQ (X, M, H, IERR) +C***BEGIN PROLOGUE DHKSEQ +C***SUBSIDIARY +C***PURPOSE Subsidiary to DBSKIN +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (HKSEQ-S, DHKSEQ-D) +C***AUTHOR Amos, D. E., (SNLA) +C***DESCRIPTION +C +C DHKSEQ is an adaptation of subroutine DPSIFN described in the +C reference below. DHKSEQ generates the sequence +C H(K,X) = (-X)**(K+1)*(PSI(K,X) PSI(K,X+0.5))/GAMMA(K+1), for +C K=0,...,M. +C +C***SEE ALSO DBSKIN +C***REFERENCES D. E. Amos, A portable Fortran subroutine for +C derivatives of the Psi function, Algorithm 610, ACM +C Transactions on Mathematical Software 9, 4 (1983), +C pp. 494-502. +C***ROUTINES CALLED D1MACH, I1MACH +C***REVISION HISTORY (YYMMDD) +C 820601 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890911 Removed unnecessary intrinsics. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 910722 Updated AUTHOR section. (ALS) +C 920528 DESCRIPTION and REFERENCES sections revised. (WRB) +C***END PROLOGUE DHKSEQ + INTEGER I, IERR, J, K, M, MX, NX + INTEGER I1MACH + DOUBLE PRECISION B, FK, FLN, FN, FNP, H, HRX, RLN, RXSQ, R1M5, S, + * SLOPE, T, TK, TRM, TRMH, TRMR, TST, U, V, WDTOL, X, XDMY, XH, + * XINC, XM, XMIN, YINT + DOUBLE PRECISION D1MACH + DIMENSION B(22), TRM(22), TRMR(25), TRMH(25), U(25), V(25), H(*) + SAVE B +C----------------------------------------------------------------------- +C SCALED BERNOULLI NUMBERS 2.0*B(2K)*(1-2**(-2K)) +C----------------------------------------------------------------------- + DATA B(1), B(2), B(3), B(4), B(5), B(6), B(7), B(8), B(9), B(10), + * B(11), B(12), B(13), B(14), B(15), B(16), B(17), B(18), B(19), + * B(20), B(21), B(22) /1.00000000000000000D+00, + * -5.00000000000000000D-01,2.50000000000000000D-01, + * -6.25000000000000000D-02,4.68750000000000000D-02, + * -6.64062500000000000D-02,1.51367187500000000D-01, + * -5.06103515625000000D-01,2.33319091796875000D+00, + * -1.41840972900390625D+01,1.09941936492919922D+02, + * -1.05824747562408447D+03,1.23842434241771698D+04, + * -1.73160495905935764D+05,2.85103429084961116D+06, + * -5.45964619322445132D+07,1.20316174668075304D+09, + * -3.02326315271452307D+10,8.59229286072319606D+11, + * -2.74233104097776039D+13,9.76664637943633248D+14, + * -3.85931586838450360D+16/ +C +C***FIRST EXECUTABLE STATEMENT DHKSEQ + IERR=0 + WDTOL = MAX(D1MACH(4),1.0D-18) + FN = M - 1 + FNP = FN + 1.0D0 +C----------------------------------------------------------------------- +C COMPUTE XMIN +C----------------------------------------------------------------------- + R1M5 = D1MACH(5) + RLN = R1M5*I1MACH(14) + RLN = MIN(RLN,18.06D0) + FLN = MAX(RLN,3.0D0) - 3.0D0 + YINT = 3.50D0 + 0.40D0*FLN + SLOPE = 0.21D0 + FLN*(0.0006038D0*FLN+0.008677D0) + XM = YINT + SLOPE*FN + MX = INT(XM) + 1 + XMIN = MX +C----------------------------------------------------------------------- +C GENERATE H(M-1,XDMY)*XDMY**(M) BY THE ASYMPTOTIC EXPANSION +C----------------------------------------------------------------------- + XDMY = X + XINC = 0.0D0 + IF (X.GE.XMIN) GO TO 10 + NX = INT(X) + XINC = XMIN - NX + XDMY = X + XINC + 10 CONTINUE + RXSQ = 1.0D0/(XDMY*XDMY) + HRX = 0.5D0/XDMY + TST = 0.5D0*WDTOL + T = FNP*HRX +C----------------------------------------------------------------------- +C INITIALIZE COEFFICIENT ARRAY +C----------------------------------------------------------------------- + S = T*B(3) + IF (ABS(S).LT.TST) GO TO 30 + TK = 2.0D0 + DO 20 K=4,22 + T = T*((TK+FN+1.0D0)/(TK+1.0D0))*((TK+FN)/(TK+2.0D0))*RXSQ + TRM(K) = T*B(K) + IF (ABS(TRM(K)).LT.TST) GO TO 30 + S = S + TRM(K) + TK = TK + 2.0D0 + 20 CONTINUE + GO TO 110 + 30 CONTINUE + H(M) = S + 0.5D0 + IF (M.EQ.1) GO TO 70 +C----------------------------------------------------------------------- +C GENERATE LOWER DERIVATIVES, I.LT.M-1 +C----------------------------------------------------------------------- + DO 60 I=2,M + FNP = FN + FN = FN - 1.0D0 + S = FNP*HRX*B(3) + IF (ABS(S).LT.TST) GO TO 50 + FK = FNP + 3.0D0 + DO 40 K=4,22 + TRM(K) = TRM(K)*FNP/FK + IF (ABS(TRM(K)).LT.TST) GO TO 50 + S = S + TRM(K) + FK = FK + 2.0D0 + 40 CONTINUE + GO TO 110 + 50 CONTINUE + MX = M - I + 1 + H(MX) = S + 0.5D0 + 60 CONTINUE + 70 CONTINUE + IF (XINC.EQ.0.0D0) RETURN +C----------------------------------------------------------------------- +C RECUR BACKWARD FROM XDMY TO X +C----------------------------------------------------------------------- + XH = X + 0.5D0 + S = 0.0D0 + NX = INT(XINC) + DO 80 I=1,NX + TRMR(I) = X/(X+NX-I) + U(I) = TRMR(I) + TRMH(I) = X/(XH+NX-I) + V(I) = TRMH(I) + S = S + U(I) - V(I) + 80 CONTINUE + MX = NX + 1 + TRMR(MX) = X/XDMY + U(MX) = TRMR(MX) + H(1) = H(1)*TRMR(MX) + S + IF (M.EQ.1) RETURN + DO 100 J=2,M + S = 0.0D0 + DO 90 I=1,NX + TRMR(I) = TRMR(I)*U(I) + TRMH(I) = TRMH(I)*V(I) + S = S + TRMR(I) - TRMH(I) + 90 CONTINUE + TRMR(MX) = TRMR(MX)*U(MX) + H(J) = H(J)*TRMR(MX) + S + 100 CONTINUE + RETURN + 110 CONTINUE + IERR=2 + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/dhkseq.lo b/modules/elementary_functions/src/fortran/slatec/dhkseq.lo new file mode 100755 index 000000000..18908583d --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dhkseq.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dhkseq.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dhkseq.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/djairy.f b/modules/elementary_functions/src/fortran/slatec/djairy.f new file mode 100755 index 000000000..0ad691d8e --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/djairy.f @@ -0,0 +1,346 @@ +*DECK DJAIRY + SUBROUTINE DJAIRY (X, RX, C, AI, DAI) +C***BEGIN PROLOGUE DJAIRY +C***SUBSIDIARY +C***PURPOSE Subsidiary to DBESJ and DBESY +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (JAIRY-S, DJAIRY-D) +C***AUTHOR Amos, D. E., (SNLA) +C Daniel, S. L., (SNLA) +C Weston, M. K., (SNLA) +C***DESCRIPTION +C +C DJAIRY computes the Airy function AI(X) +C and its derivative DAI(X) for DASYJY +C +C INPUT +C +C X - Argument, computed by DASYJY, X unrestricted +C RX - RX=SQRT(ABS(X)), computed by DASYJY +C C - C=2.*(ABS(X)**1.5)/3., computed by DASYJY +C +C OUTPUT +C +C AI - Value of function AI(X) +C DAI - Value of the derivative DAI(X) +C +C***SEE ALSO DBESJ, DBESY +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 750101 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 891009 Removed unreferenced variable. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 910408 Updated the AUTHOR section. (WRB) +C***END PROLOGUE DJAIRY +C + INTEGER I, J, M1, M1D, M2, M2D, M3, M3D, M4, M4D, N1, N1D, N2, + 1 N2D, N3, N3D, N4, N4D + DOUBLE PRECISION A,AI,AJN,AJP,AK1,AK2,AK3,B,C,CCV,CON2, + 1 CON3, CON4, CON5, CV, DA, DAI, DAJN, DAJP, DAK1, DAK2, DAK3, + 2 DB, EC, E1, E2, FPI12, F1, F2, RTRX, RX, SCV, T, TEMP1, TEMP2, + 3 TT, X + DIMENSION AJP(19), AJN(19), A(15), B(15) + DIMENSION AK1(14), AK2(23), AK3(14) + DIMENSION DAJP(19), DAJN(19), DA(15), DB(15) + DIMENSION DAK1(14), DAK2(24), DAK3(14) + SAVE N1, N2, N3, N4, M1, M2, M3, M4, FPI12, CON2, CON3, + 1 CON4, CON5, AK1, AK2, AK3, AJP, AJN, A, B, + 2 N1D, N2D, N3D, N4D, M1D, M2D, M3D, M4D, DAK1, DAK2, DAK3, + 3 DAJP, DAJN, DA, DB + DATA N1,N2,N3,N4/14,23,19,15/ + DATA M1,M2,M3,M4/12,21,17,13/ + DATA FPI12,CON2,CON3,CON4,CON5/ + 1 1.30899693899575D+00, 5.03154716196777D+00, 3.80004589867293D-01, + 2 8.33333333333333D-01, 8.66025403784439D-01/ + DATA AK1(1), AK1(2), AK1(3), AK1(4), AK1(5), AK1(6), AK1(7), + 1 AK1(8), AK1(9), AK1(10),AK1(11),AK1(12),AK1(13), + 2 AK1(14) / 2.20423090987793D-01,-1.25290242787700D-01, + 3 1.03881163359194D-02, 8.22844152006343D-04,-2.34614345891226D-04, + 4 1.63824280172116D-05, 3.06902589573189D-07,-1.29621999359332D-07, + 5 8.22908158823668D-09, 1.53963968623298D-11,-3.39165465615682D-11, + 6 2.03253257423626D-12,-1.10679546097884D-14,-5.16169497785080D-15/ + DATA AK2(1), AK2(2), AK2(3), AK2(4), AK2(5), AK2(6), AK2(7), + 1 AK2(8), AK2(9), AK2(10),AK2(11),AK2(12),AK2(13),AK2(14), + 2 AK2(15),AK2(16),AK2(17),AK2(18),AK2(19),AK2(20),AK2(21), + 3 AK2(22),AK2(23) / 2.74366150869598D-01, 5.39790969736903D-03, + 4-1.57339220621190D-03, 4.27427528248750D-04,-1.12124917399925D-04, + 5 2.88763171318904D-05,-7.36804225370554D-06, 1.87290209741024D-06, + 6-4.75892793962291D-07, 1.21130416955909D-07,-3.09245374270614D-08, + 7 7.92454705282654D-09,-2.03902447167914D-09, 5.26863056595742D-10, + 8-1.36704767639569D-10, 3.56141039013708D-11,-9.31388296548430D-12, + 9 2.44464450473635D-12,-6.43840261990955D-13, 1.70106030559349D-13, + 1-4.50760104503281D-14, 1.19774799164811D-14,-3.19077040865066D-15/ + DATA AK3(1), AK3(2), AK3(3), AK3(4), AK3(5), AK3(6), AK3(7), + 1 AK3(8), AK3(9), AK3(10),AK3(11),AK3(12),AK3(13), + 2 AK3(14) / 2.80271447340791D-01,-1.78127042844379D-03, + 3 4.03422579628999D-05,-1.63249965269003D-06, 9.21181482476768D-08, + 4-6.52294330229155D-09, 5.47138404576546D-10,-5.24408251800260D-11, + 5 5.60477904117209D-12,-6.56375244639313D-13, 8.31285761966247D-14, + 6-1.12705134691063D-14, 1.62267976598129D-15,-2.46480324312426D-16/ + DATA AJP(1), AJP(2), AJP(3), AJP(4), AJP(5), AJP(6), AJP(7), + 1 AJP(8), AJP(9), AJP(10),AJP(11),AJP(12),AJP(13),AJP(14), + 2 AJP(15),AJP(16),AJP(17),AJP(18), + 3 AJP(19) / 7.78952966437581D-02,-1.84356363456801D-01, + 4 3.01412605216174D-02, 3.05342724277608D-02,-4.95424702513079D-03, + 5-1.72749552563952D-03, 2.43137637839190D-04, 5.04564777517082D-05, + 6-6.16316582695208D-06,-9.03986745510768D-07, 9.70243778355884D-08, + 7 1.09639453305205D-08,-1.04716330588766D-09,-9.60359441344646D-11, + 8 8.25358789454134D-12, 6.36123439018768D-13,-4.96629614116015D-14, + 9-3.29810288929615D-15, 2.35798252031104D-16/ + DATA AJN(1), AJN(2), AJN(3), AJN(4), AJN(5), AJN(6), AJN(7), + 1 AJN(8), AJN(9), AJN(10),AJN(11),AJN(12),AJN(13),AJN(14), + 2 AJN(15),AJN(16),AJN(17),AJN(18), + 3 AJN(19) / 3.80497887617242D-02,-2.45319541845546D-01, + 4 1.65820623702696D-01, 7.49330045818789D-02,-2.63476288106641D-02, + 5-5.92535597304981D-03, 1.44744409589804D-03, 2.18311831322215D-04, + 6-4.10662077680304D-05,-4.66874994171766D-06, 7.15218807277160D-07, + 7 6.52964770854633D-08,-8.44284027565946D-09,-6.44186158976978D-10, + 8 7.20802286505285D-11, 4.72465431717846D-12,-4.66022632547045D-13, + 9-2.67762710389189D-14, 2.36161316570019D-15/ + DATA A(1), A(2), A(3), A(4), A(5), A(6), A(7), + 1 A(8), A(9), A(10), A(11), A(12), A(13), A(14), + 2 A(15) / 4.90275424742791D-01, 1.57647277946204D-03, + 3-9.66195963140306D-05, 1.35916080268815D-07, 2.98157342654859D-07, + 4-1.86824767559979D-08,-1.03685737667141D-09, 3.28660818434328D-10, + 5-2.57091410632780D-11,-2.32357655300677D-12, 9.57523279048255D-13, + 6-1.20340828049719D-13,-2.90907716770715D-15, 4.55656454580149D-15, + 7-9.99003874810259D-16/ + DATA B(1), B(2), B(3), B(4), B(5), B(6), B(7), + 1 B(8), B(9), B(10), B(11), B(12), B(13), B(14), + 2 B(15) / 2.78593552803079D-01,-3.52915691882584D-03, + 3-2.31149677384994D-05, 4.71317842263560D-06,-1.12415907931333D-07, + 4-2.00100301184339D-08, 2.60948075302193D-09,-3.55098136101216D-11, + 5-3.50849978423875D-11, 5.83007187954202D-12,-2.04644828753326D-13, + 6-1.10529179476742D-13, 2.87724778038775D-14,-2.88205111009939D-15, + 7-3.32656311696166D-16/ + DATA N1D,N2D,N3D,N4D/14,24,19,15/ + DATA M1D,M2D,M3D,M4D/12,22,17,13/ + DATA DAK1(1), DAK1(2), DAK1(3), DAK1(4), DAK1(5), DAK1(6), + 1 DAK1(7), DAK1(8), DAK1(9), DAK1(10),DAK1(11),DAK1(12), + 2 DAK1(13),DAK1(14)/ 2.04567842307887D-01,-6.61322739905664D-02, + 3-8.49845800989287D-03, 3.12183491556289D-03,-2.70016489829432D-04, + 4-6.35636298679387D-06, 3.02397712409509D-06,-2.18311195330088D-07, + 5-5.36194289332826D-10, 1.13098035622310D-09,-7.43023834629073D-11, + 6 4.28804170826891D-13, 2.23810925754539D-13,-1.39140135641182D-14/ + DATA DAK2(1), DAK2(2), DAK2(3), DAK2(4), DAK2(5), DAK2(6), + 1 DAK2(7), DAK2(8), DAK2(9), DAK2(10),DAK2(11),DAK2(12), + 2 DAK2(13),DAK2(14),DAK2(15),DAK2(16),DAK2(17),DAK2(18), + 3 DAK2(19),DAK2(20),DAK2(21),DAK2(22),DAK2(23), + 4 DAK2(24) / 2.93332343883230D-01,-8.06196784743112D-03, + 5 2.42540172333140D-03,-6.82297548850235D-04, 1.85786427751181D-04, + 6-4.97457447684059D-05, 1.32090681239497D-05,-3.49528240444943D-06, + 7 9.24362451078835D-07,-2.44732671521867D-07, 6.49307837648910D-08, + 8-1.72717621501538D-08, 4.60725763604656D-09,-1.23249055291550D-09, + 9 3.30620409488102D-10,-8.89252099772401D-11, 2.39773319878298D-11, + 1-6.48013921153450D-12, 1.75510132023731D-12,-4.76303829833637D-13, + 2 1.29498241100810D-13,-3.52679622210430D-14, 9.62005151585923D-15, + 3-2.62786914342292D-15/ + DATA DAK3(1), DAK3(2), DAK3(3), DAK3(4), DAK3(5), DAK3(6), + 1 DAK3(7), DAK3(8), DAK3(9), DAK3(10),DAK3(11),DAK3(12), + 2 DAK3(13),DAK3(14)/ 2.84675828811349D-01, 2.53073072619080D-03, + 3-4.83481130337976D-05, 1.84907283946343D-06,-1.01418491178576D-07, + 4 7.05925634457153D-09,-5.85325291400382D-10, 5.56357688831339D-11, + 5-5.90889094779500D-12, 6.88574353784436D-13,-8.68588256452194D-14, + 6 1.17374762617213D-14,-1.68523146510923D-15, 2.55374773097056D-16/ + DATA DAJP(1), DAJP(2), DAJP(3), DAJP(4), DAJP(5), DAJP(6), + 1 DAJP(7), DAJP(8), DAJP(9), DAJP(10),DAJP(11),DAJP(12), + 2 DAJP(13),DAJP(14),DAJP(15),DAJP(16),DAJP(17),DAJP(18), + 3 DAJP(19) / 6.53219131311457D-02,-1.20262933688823D-01, + 4 9.78010236263823D-03, 1.67948429230505D-02,-1.97146140182132D-03, + 5-8.45560295098867D-04, 9.42889620701976D-05, 2.25827860945475D-05, + 6-2.29067870915987D-06,-3.76343991136919D-07, 3.45663933559565D-08, + 7 4.29611332003007D-09,-3.58673691214989D-10,-3.57245881361895D-11, + 8 2.72696091066336D-12, 2.26120653095771D-13,-1.58763205238303D-14, + 9-1.12604374485125D-15, 7.31327529515367D-17/ + DATA DAJN(1), DAJN(2), DAJN(3), DAJN(4), DAJN(5), DAJN(6), + 1 DAJN(7), DAJN(8), DAJN(9), DAJN(10),DAJN(11),DAJN(12), + 2 DAJN(13),DAJN(14),DAJN(15),DAJN(16),DAJN(17),DAJN(18), + 3 DAJN(19) / 1.08594539632967D-02, 8.53313194857091D-02, + 4-3.15277068113058D-01,-8.78420725294257D-02, 5.53251906976048D-02, + 5 9.41674060503241D-03,-3.32187026018996D-03,-4.11157343156826D-04, + 6 1.01297326891346D-04, 9.87633682208396D-06,-1.87312969812393D-06, + 7-1.50798500131468D-07, 2.32687669525394D-08, 1.59599917419225D-09, + 8-2.07665922668385D-10,-1.24103350500302D-11, 1.39631765331043D-12, + 9 7.39400971155740D-14,-7.32887475627500D-15/ + DATA DA(1), DA(2), DA(3), DA(4), DA(5), DA(6), DA(7), + 1 DA(8), DA(9), DA(10), DA(11), DA(12), DA(13), DA(14), + 2 DA(15) / 4.91627321104601D-01, 3.11164930427489D-03, + 3 8.23140762854081D-05,-4.61769776172142D-06,-6.13158880534626D-08, + 4 2.87295804656520D-08,-1.81959715372117D-09,-1.44752826642035D-10, + 5 4.53724043420422D-11,-3.99655065847223D-12,-3.24089119830323D-13, + 6 1.62098952568741D-13,-2.40765247974057D-14, 1.69384811284491D-16, + 7 8.17900786477396D-16/ + DATA DB(1), DB(2), DB(3), DB(4), DB(5), DB(6), DB(7), + 1 DB(8), DB(9), DB(10), DB(11), DB(12), DB(13), DB(14), + 2 DB(15) /-2.77571356944231D-01, 4.44212833419920D-03, + 3-8.42328522190089D-05,-2.58040318418710D-06, 3.42389720217621D-07, + 4-6.24286894709776D-09,-2.36377836844577D-09, 3.16991042656673D-10, + 5-4.40995691658191D-12,-5.18674221093575D-12, 9.64874015137022D-13, + 6-4.90190576608710D-14,-1.77253430678112D-14, 5.55950610442662D-15, + 7-7.11793337579530D-16/ +C***FIRST EXECUTABLE STATEMENT DJAIRY + IF (X.LT.0.0D0) GO TO 90 + IF (C.GT.5.0D0) GO TO 60 + IF (X.GT.1.20D0) GO TO 30 + T = (X+X-1.2D0)*CON4 + TT = T + T + J = N1 + F1 = AK1(J) + F2 = 0.0D0 + DO 10 I=1,M1 + J = J - 1 + TEMP1 = F1 + F1 = TT*F1 - F2 + AK1(J) + F2 = TEMP1 + 10 CONTINUE + AI = T*F1 - F2 + AK1(1) +C + J = N1D + F1 = DAK1(J) + F2 = 0.0D0 + DO 20 I=1,M1D + J = J - 1 + TEMP1 = F1 + F1 = TT*F1 - F2 + DAK1(J) + F2 = TEMP1 + 20 CONTINUE + DAI = -(T*F1-F2+DAK1(1)) + RETURN +C + 30 CONTINUE + T = (X+X-CON2)*CON3 + TT = T + T + J = N2 + F1 = AK2(J) + F2 = 0.0D0 + DO 40 I=1,M2 + J = J - 1 + TEMP1 = F1 + F1 = TT*F1 - F2 + AK2(J) + F2 = TEMP1 + 40 CONTINUE + RTRX = SQRT(RX) + EC = EXP(-C) + AI = EC*(T*F1-F2+AK2(1))/RTRX + J = N2D + F1 = DAK2(J) + F2 = 0.0D0 + DO 50 I=1,M2D + J = J - 1 + TEMP1 = F1 + F1 = TT*F1 - F2 + DAK2(J) + F2 = TEMP1 + 50 CONTINUE + DAI = -EC*(T*F1-F2+DAK2(1))*RTRX + RETURN +C + 60 CONTINUE + T = 10.0D0/C - 1.0D0 + TT = T + T + J = N1 + F1 = AK3(J) + F2 = 0.0D0 + DO 70 I=1,M1 + J = J - 1 + TEMP1 = F1 + F1 = TT*F1 - F2 + AK3(J) + F2 = TEMP1 + 70 CONTINUE + RTRX = SQRT(RX) + EC = EXP(-C) + AI = EC*(T*F1-F2+AK3(1))/RTRX + J = N1D + F1 = DAK3(J) + F2 = 0.0D0 + DO 80 I=1,M1D + J = J - 1 + TEMP1 = F1 + F1 = TT*F1 - F2 + DAK3(J) + F2 = TEMP1 + 80 CONTINUE + DAI = -RTRX*EC*(T*F1-F2+DAK3(1)) + RETURN +C + 90 CONTINUE + IF (C.GT.5.0D0) GO TO 120 + T = 0.4D0*C - 1.0D0 + TT = T + T + J = N3 + F1 = AJP(J) + E1 = AJN(J) + F2 = 0.0D0 + E2 = 0.0D0 + DO 100 I=1,M3 + J = J - 1 + TEMP1 = F1 + TEMP2 = E1 + F1 = TT*F1 - F2 + AJP(J) + E1 = TT*E1 - E2 + AJN(J) + F2 = TEMP1 + E2 = TEMP2 + 100 CONTINUE + AI = (T*E1-E2+AJN(1)) - X*(T*F1-F2+AJP(1)) + J = N3D + F1 = DAJP(J) + E1 = DAJN(J) + F2 = 0.0D0 + E2 = 0.0D0 + DO 110 I=1,M3D + J = J - 1 + TEMP1 = F1 + TEMP2 = E1 + F1 = TT*F1 - F2 + DAJP(J) + E1 = TT*E1 - E2 + DAJN(J) + F2 = TEMP1 + E2 = TEMP2 + 110 CONTINUE + DAI = X*X*(T*F1-F2+DAJP(1)) + (T*E1-E2+DAJN(1)) + RETURN +C + 120 CONTINUE + T = 10.0D0/C - 1.0D0 + TT = T + T + J = N4 + F1 = A(J) + E1 = B(J) + F2 = 0.0D0 + E2 = 0.0D0 + DO 130 I=1,M4 + J = J - 1 + TEMP1 = F1 + TEMP2 = E1 + F1 = TT*F1 - F2 + A(J) + E1 = TT*E1 - E2 + B(J) + F2 = TEMP1 + E2 = TEMP2 + 130 CONTINUE + TEMP1 = T*F1 - F2 + A(1) + TEMP2 = T*E1 - E2 + B(1) + RTRX = SQRT(RX) + CV = C - FPI12 + CCV = COS(CV) + SCV = SIN(CV) + AI = (TEMP1*CCV-TEMP2*SCV)/RTRX + J = N4D + F1 = DA(J) + E1 = DB(J) + F2 = 0.0D0 + E2 = 0.0D0 + DO 140 I=1,M4D + J = J - 1 + TEMP1 = F1 + TEMP2 = E1 + F1 = TT*F1 - F2 + DA(J) + E1 = TT*E1 - E2 + DB(J) + F2 = TEMP1 + E2 = TEMP2 + 140 CONTINUE + TEMP1 = T*F1 - F2 + DA(1) + TEMP2 = T*E1 - E2 + DB(1) + E1 = CCV*CON5 + 0.5D0*SCV + E2 = SCV*CON5 - 0.5D0*CCV + DAI = (TEMP1*E1-TEMP2*E2)*RTRX + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/djairy.lo b/modules/elementary_functions/src/fortran/slatec/djairy.lo new file mode 100755 index 000000000..256b676bc --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/djairy.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/djairy.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/djairy.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dlngam.f b/modules/elementary_functions/src/fortran/slatec/dlngam.f new file mode 100755 index 000000000..3755450de --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dlngam.f @@ -0,0 +1,73 @@ +*DECK DLNGAM + DOUBLE PRECISION FUNCTION DLNGAM (X) +C***BEGIN PROLOGUE DLNGAM +C***PURPOSE Compute the logarithm of the absolute value of the Gamma +C function. +C***LIBRARY SLATEC (FNLIB) +C***CATEGORY C7A +C***TYPE DOUBLE PRECISION (ALNGAM-S, DLNGAM-D, CLNGAM-C) +C***KEYWORDS ABSOLUTE VALUE, COMPLETE GAMMA FUNCTION, FNLIB, LOGARITHM, +C SPECIAL FUNCTIONS +C***AUTHOR Fullerton, W., (LANL) +C***DESCRIPTION +C +C DLNGAM(X) calculates the double precision logarithm of the +C absolute value of the Gamma function for double precision +C argument X. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH, D9LGMC, DGAMMA, XERMSG +C***REVISION HISTORY (YYMMDD) +C 770601 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 900727 Added EXTERNAL statement. (WRB) +C***END PROLOGUE DLNGAM + DOUBLE PRECISION X, DXREL, PI, SINPIY, SQPI2L, SQ2PIL, XMAX, + 1 Y, DGAMMA, D9LGMC, D1MACH, TEMP + LOGICAL FIRST + EXTERNAL DGAMMA + SAVE SQ2PIL, SQPI2L, PI, XMAX, DXREL, FIRST + DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 / + DATA SQPI2L / +.2257913526 4472743236 3097614947 441 D+0 / + DATA PI / 3.1415926535 8979323846 2643383279 50 D0 / + DATA FIRST /.TRUE./ +C***FIRST EXECUTABLE STATEMENT DLNGAM + IF (FIRST) THEN + TEMP = 1.D0/LOG(D1MACH(2)) + XMAX = TEMP*D1MACH(2) + DXREL = SQRT(D1MACH(4)) + ENDIF + FIRST = .FALSE. +C + Y = ABS (X) + IF (Y.GT.10.D0) GO TO 20 +C +C LOG (ABS (DGAMMA(X)) ) FOR ABS(X) .LE. 10.0 +C + DLNGAM = LOG (ABS (DGAMMA(X)) ) + RETURN +C +C LOG ( ABS (DGAMMA(X)) ) FOR ABS(X) .GT. 10.0 +C + 20 IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'DLNGAM', + + 'ABS(X) SO BIG DLNGAM OVERFLOWS', 2, 2) +C + IF (X.GT.0.D0) DLNGAM = SQ2PIL + (X-0.5D0)*LOG(X) - X + D9LGMC(Y) + IF (X.GT.0.D0) RETURN +C + SINPIY = ABS (SIN(PI*Y)) + IF (SINPIY .EQ. 0.D0) CALL XERMSG ('SLATEC', 'DLNGAM', + + 'X IS A NEGATIVE INTEGER', 3, 2) +C + IF (ABS((X-AINT(X-0.5D0))/X) .LT. DXREL) CALL XERMSG ('SLATEC', + + 'DLNGAM', + + 'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE INTEGER', + + 1, 1) +C + DLNGAM = SQPI2L + (X-0.5D0)*LOG(Y) - X - LOG(SINPIY) - D9LGMC(Y) + RETURN +C + END diff --git a/modules/elementary_functions/src/fortran/slatec/dlngam.lo b/modules/elementary_functions/src/fortran/slatec/dlngam.lo new file mode 100755 index 000000000..675fd7d0d --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dlngam.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dlngam.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dlngam.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dpsixn.f b/modules/elementary_functions/src/fortran/slatec/dpsixn.f new file mode 100755 index 000000000..171204c89 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dpsixn.f @@ -0,0 +1,122 @@ +*DECK DPSIXN + DOUBLE PRECISION FUNCTION DPSIXN (N) +C***BEGIN PROLOGUE DPSIXN +C***SUBSIDIARY +C***PURPOSE Subsidiary to DEXINT +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (PSIXN-S, DPSIXN-D) +C***AUTHOR Amos, D. E., (SNLA) +C***DESCRIPTION +C +C This subroutine returns values of PSI(X)=derivative of log +C GAMMA(X), X.GT.0.0 at integer arguments. A table look-up is +C performed for N .LE. 100, and the asymptotic expansion is +C evaluated for N.GT.100. +C +C***SEE ALSO DEXINT +C***ROUTINES CALLED D1MACH +C***REVISION HISTORY (YYMMDD) +C 800501 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890911 Removed unnecessary intrinsics. (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 DPSIXN +C + INTEGER N, K + DOUBLE PRECISION AX, B, C, FN, RFN2, TRM, S, WDTOL + DOUBLE PRECISION D1MACH + DIMENSION B(6), C(100) +C +C DPSIXN(N), N = 1,100 + DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), + 1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), + 2 C(19), C(20), C(21), C(22), C(23), C(24)/ + 3 -5.77215664901532861D-01, 4.22784335098467139D-01, + 4 9.22784335098467139D-01, 1.25611766843180047D+00, + 5 1.50611766843180047D+00, 1.70611766843180047D+00, + 6 1.87278433509846714D+00, 2.01564147795561000D+00, + 7 2.14064147795561000D+00, 2.25175258906672111D+00, + 8 2.35175258906672111D+00, 2.44266167997581202D+00, + 9 2.52599501330914535D+00, 2.60291809023222227D+00, + 1 2.67434666166079370D+00, 2.74101332832746037D+00, + 2 2.80351332832746037D+00, 2.86233685773922507D+00, + 3 2.91789241329478063D+00, 2.97052399224214905D+00, + 4 3.02052399224214905D+00, 3.06814303986119667D+00, + 5 3.11359758531574212D+00, 3.15707584618530734D+00/ + DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), + 1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), + 2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ + 3 3.19874251285197401D+00, 3.23874251285197401D+00, + 4 3.27720405131351247D+00, 3.31424108835054951D+00, + 5 3.34995537406483522D+00, 3.38443813268552488D+00, + 6 3.41777146601885821D+00, 3.45002953053498724D+00, + 7 3.48127953053498724D+00, 3.51158256083801755D+00, + 8 3.54099432554389990D+00, 3.56956575411532847D+00, + 9 3.59734353189310625D+00, 3.62437055892013327D+00, + 1 3.65068634839381748D+00, 3.67632737403484313D+00, + 2 3.70132737403484313D+00, 3.72571761793728215D+00, + 3 3.74952714174680596D+00, 3.77278295570029433D+00, + 4 3.79551022842756706D+00, 3.81773245064978928D+00, + 5 3.83947158108457189D+00, 3.86074817682925274D+00/ + DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), + 1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), + 2 C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/ + 3 3.88158151016258607D+00, 3.90198967342789220D+00, + 4 3.92198967342789220D+00, 3.94159751656514710D+00, + 5 3.96082828579591633D+00, 3.97969621032421822D+00, + 6 3.99821472884273674D+00, 4.01639654702455492D+00, + 7 4.03425368988169777D+00, 4.05179754953082058D+00, + 8 4.06903892884116541D+00, 4.08598808138353829D+00, + 9 4.10265474805020496D+00, 4.11904819067315578D+00, + 1 4.13517722293122029D+00, 4.15105023880423617D+00, + 2 4.16667523880423617D+00, 4.18205985418885155D+00, + 3 4.19721136934036670D+00, 4.21213674247469506D+00, + 4 4.22684262482763624D+00, 4.24133537845082464D+00, + 5 4.25562109273653893D+00, 4.26970559977879245D+00/ + DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80), + 1 C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88), + 2 C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/ + 3 4.28359448866768134D+00, 4.29729311880466764D+00, + 4 4.31080663231818115D+00, 4.32413996565151449D+00, + 5 4.33729786038835659D+00, 4.35028487337536958D+00, + 6 4.36310538619588240D+00, 4.37576361404398366D+00, + 7 4.38826361404398366D+00, 4.40060929305632934D+00, + 8 4.41280441500754886D+00, 4.42485260777863319D+00, + 9 4.43675736968339510D+00, 4.44852207556574804D+00, + 1 4.46014998254249223D+00, 4.47164423541605544D+00, + 2 4.48300787177969181D+00, 4.49424382683587158D+00, + 3 4.50535493794698269D+00, 4.51634394893599368D+00, + 4 4.52721351415338499D+00, 4.53796620232542800D+00, + 5 4.54860450019776842D+00, 4.55913081598724211D+00/ + DATA C(97), C(98), C(99), C(100)/ + 1 4.56954748265390877D+00, 4.57985676100442424D+00, + 2 4.59006084263707730D+00, 4.60016185273808740D+00/ +C COEFFICIENTS OF ASYMPTOTIC EXPANSION + DATA B(1), B(2), B(3), B(4), B(5), B(6)/ + 1 8.33333333333333333D-02, -8.33333333333333333D-03, + 2 3.96825396825396825D-03, -4.16666666666666666D-03, + 3 7.57575757575757576D-03, -2.10927960927960928D-02/ +C +C***FIRST EXECUTABLE STATEMENT DPSIXN + IF (N.GT.100) GO TO 10 + DPSIXN = C(N) + RETURN + 10 CONTINUE + WDTOL = MAX(D1MACH(4),1.0D-18) + FN = N + AX = 1.0D0 + S = -0.5D0/FN + IF (ABS(S).LE.WDTOL) GO TO 30 + RFN2 = 1.0D0/(FN*FN) + DO 20 K=1,6 + AX = AX*RFN2 + TRM = -B(K)*AX + IF (ABS(TRM).LT.WDTOL) GO TO 30 + S = S + TRM + 20 CONTINUE + 30 CONTINUE + DPSIXN = S + LOG(FN) + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/dpsixn.lo b/modules/elementary_functions/src/fortran/slatec/dpsixn.lo new file mode 100755 index 000000000..b2c5c0407 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dpsixn.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dpsixn.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dpsixn.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dtensbs.f b/modules/elementary_functions/src/fortran/slatec/dtensbs.f new file mode 100755 index 000000000..3ba2caa61 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dtensbs.f @@ -0,0 +1,1484 @@ + DOUBLE PRECISION FUNCTION DBVALU(T,A,N,K,IDERIV,X,INBV,WORK) +C***BEGIN PROLOGUE DBVALU +C***DATE WRITTEN 800901 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***REVISION HISTORY (YYMMDD) +C 000330 Modified array declarations. (JEC) +C +C***CATEGORY NO. E3,K6 +C***KEYWORDS B-SPLINE,DATA FITTING,DOUBLE PRECISION,INTERPOLATION, +C SPLINE +C***AUTHOR AMOS, D. E., (SNLA) +C***PURPOSE Evaluates the B-representation of a B-spline at X for the +C function value or any of its derivatives. +C***DESCRIPTION +C +C Written by Carl de Boor and modified by D. E. Amos +C +C Reference +C SIAM J. Numerical Analysis, 14, No. 3, June, 1977, pp.441-472. +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***REFERENCES C. DE BOOR, *PACKAGE FOR CALCULATING WITH B-SPLINES*, +C SIAM JOURNAL ON NUMERICAL ANALYSIS, VOLUME 14, NO. 3, +C JUNE 1977, PP. 441-472. +C***ROUTINES CALLED DINTRV,XERROR +C***END PROLOGUE DBVALU +C +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(N), 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 = DBLE(FLOAT(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 XERROR( ' DBVALU, N DOES NOT SATISFY N.GE.K',35,2,1) + print *, ' DBVALU, N DOES NOT SATISFY N.GE.K' + RETURN + 102 CONTINUE +! CALL XERROR( ' DBVALU, K DOES NOT SATISFY K.GE.1',35,2,1) + print *, ' DBVALU, K DOES NOT SATISFY K.GE.1' + RETURN + 110 CONTINUE +! CALL XERROR( ' DBVALU, IDERIV DOES NOT SATISFY 0.LE.IDERIV.LT.K', + print *, ' DBVALU, IDERIV DOES NOT SATISFY 0.LE.IDERIV.LT.K' + + RETURN + 120 CONTINUE +! CALL XERROR( ' DBVALU, X IS N0T GREATER THAN OR EQUAL TO T(K)' + print *, ' DBVALU, X IS N0T GREATER THAN OR EQUAL TO T(K)' + RETURN + 130 CONTINUE +* CALL XERROR( ' DBVALU, X IS NOT LESS THAN OR EQUAL TO T(N+1)', +* 1 47, 2, 1) + print *, ' DBVALU, X IS NOT LESS THAN OR EQUAL TO T(N+1)' + RETURN + 140 CONTINUE +* CALL XERROR( ' DBVALU, A LEFT LIMITING VALUE CANN0T BE OBTAINED A +* 1T T(K)', 58, 2, 1) + print *,' DBVALU, A LEFT LIMITING VALUE CANT BE OBTAINED AT T(K)' + RETURN + END + + SUBROUTINE DINTRV(XT,LXT,X,ILO,ILEFT,MFLAG) +C***BEGIN PROLOGUE DINTRV +C***DATE WRITTEN 800901 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. E3,K6 +C***KEYWORDS B-SPLINE,DATA FITTING,DOUBLE PRECISION,INTERPOLATION, +C SPLINE +C***AUTHOR AMOS, D. E., (SNLA) +C***PURPOSE Computes 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***DESCRIPTION +C +C Written by Carl de Boor and modified by D. E. Amos +C +C Reference +C SIAM J. Numerical Analysis, 14, No. 3, June 1977, pp.441-472. +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***REFERENCES C. DE BOOR, *PACKAGE FOR CALCULATING WITH B-SPLINES*, +C SIAM JOURNAL ON NUMERICAL ANALYSIS, VOLUME 14, NO. 3, +C JUNE 1977, PP. 441-472. +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DINTRV +C +C + INTEGER IHI, ILEFT, ILO, ISTEP, LXT, MFLAG, MIDDLE + DOUBLE PRECISION X, XT + DIMENSION XT(LXT) +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 + + SUBROUTINE DBKNOT(X,N,K,T) +C***BEGIN PROLOGUE DBKNOT +C***REFER TO DB2INK,DB3INK +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 000330 Modified array declarations. (JEC) +C +C***END PROLOGUE DBKNOT +C +C -------------------------------------------------------------------- +C DBKNOT CHOOSES A KNOT SEQUENCE FOR INTERPOLATION OF ORDER K AT THE +C DATA POINTS X(I), I=1,..,N. THE N+K KNOTS ARE PLACED IN THE ARRAY +C T. K KNOTS ARE PLACED AT EACH ENDPOINT AND NOT-A-KNOT END +C CONDITIONS ARE USED. THE REMAINING KNOTS ARE PLACED AT DATA POINTS +C IF N IS EVEN AND BETWEEN DATA POINTS IF N IS ODD. THE RIGHTMOST +C KNOT IS SHIFTED SLIGHTLY TO THE RIGHT TO INSURE PROPER INTERPOLATION +C AT X(N) (SEE PAGE 350 OF THE REFERENCE). +C DOUBLE PRECISION VERSION OF BKNOT. +C -------------------------------------------------------------------- +C +C ------------ +C DECLARATIONS +C ------------ +C +C PARAMETERS +C + INTEGER + * N, K + DOUBLE PRECISION + * X(N), T(*) +C +C LOCAL VARIABLES +C + INTEGER + * I, J, IPJ, NPJ, IP1 + DOUBLE PRECISION + * RNOT +C +C +C ---------------------------- +C PUT K KNOTS AT EACH ENDPOINT +C ---------------------------- +C +C (SHIFT RIGHT ENPOINTS SLIGHTLY -- SEE PG 350 OF REFERENCE) + RNOT = X(N) + 0.10D0*( X(N)-X(N-1) ) + DO 110 J=1,K + T(J) = X(1) + NPJ = N + J + T(NPJ) = RNOT + 110 CONTINUE +C +C -------------------------- +C DISTRIBUTE REMAINING KNOTS +C -------------------------- +C + IF (MOD(K,2) .EQ. 1) GO TO 150 +C +C CASE OF EVEN K -- KNOTS AT DATA POINTS +C + I = (K/2) - K + JSTRT = K+1 + DO 120 J=JSTRT,N + IPJ = I + J + T(J) = X(IPJ) + 120 CONTINUE + GO TO 200 +C +C CASE OF ODD K -- KNOTS BETWEEN DATA POINTS +C + 150 CONTINUE + I = (K-1)/2 - K + IP1 = I + 1 + JSTRT = K + 1 + DO 160 J=JSTRT,N + IPJ = I + J + T(J) = 0.50D0*( X(IPJ) + X(IPJ+1) ) + 160 CONTINUE + 200 CONTINUE +C + RETURN + END + + SUBROUTINE DBTPCF(X,N,FCN,LDF,NF,T,K,BCOEF,WORK) +C***BEGIN PROLOGUE DBTPCF +C***REFER TO DB2INK,DB3INK +C***ROUTINES CALLED DBINTK,DBNSLV +C***REVISION HISTORY (YYMMDD) +C 000330 Modified array declarations. (JEC) +C +C***END PROLOGUE DBTPCF +C +C ----------------------------------------------------------------- +C DBTPCF COMPUTES B-SPLINE INTERPOLATION COEFFICIENTS FOR NF SETS +C OF DATA STORED IN THE COLUMNS OF THE ARRAY FCN. THE B-SPLINE +C COEFFICIENTS ARE STORED IN THE ROWS OF BCOEF HOWEVER. +C EACH INTERPOLATION IS BASED ON THE N ABCISSA STORED IN THE +C ARRAY X, AND THE N+K KNOTS STORED IN THE ARRAY T. THE ORDER +C OF EACH INTERPOLATION IS K. THE WORK ARRAY MUST BE OF LENGTH +C AT LEAST 2*K*(N+1). +C DOUBLE PRECISION VERSION OF BTPCF. +C ----------------------------------------------------------------- +C +C ------------ +C DECLARATIONS +C ------------ +C +C PARAMETERS +C + INTEGER + * N, LDF, K + DOUBLE PRECISION + * X(N), FCN(LDF,NF), T(*), BCOEF(NF,N), WORK(*) +C +C LOCAL VARIABLES +C + INTEGER + * I, J, K1, K2, IQ, IW +C +C --------------------------------------------- +C CHECK FOR NULL INPUT AND PARTITION WORK ARRAY +C --------------------------------------------- +C +C***FIRST EXECUTABLE STATEMENT + IF (NF .LE. 0) GO TO 500 + K1 = K - 1 + K2 = K1 + K + IQ = 1 + N + IW = IQ + K2*N+1 +C +C ----------------------------- +C COMPUTE B-SPLINE COEFFICIENTS +C ----------------------------- +C +C +C FIRST DATA SET +C + CALL DBINTK(X,FCN,T,N,K,WORK,WORK(IQ),WORK(IW)) + DO 20 I=1,N + BCOEF(1,I) = WORK(I) + 20 CONTINUE +C +C ALL REMAINING DATA SETS BY BACK-SUBSTITUTION +C + IF (NF .EQ. 1) GO TO 500 + DO 100 J=2,NF + DO 50 I=1,N + WORK(I) = FCN(I,J) + 50 CONTINUE + CALL DBNSLV(WORK(IQ),K2,N,K1,K1,WORK) + DO 60 I=1,N + BCOEF(J,I) = WORK(I) + 60 CONTINUE + 100 CONTINUE +C +C ---- +C EXIT +C ---- +C + 500 CONTINUE + RETURN + END + + SUBROUTINE DBINTK(X,Y,T,N,K,BCOEF,Q,WORK) +C***BEGIN PROLOGUE DBINTK +C***DATE WRITTEN 800901 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***REVISION HISTORY (YYMMDD) +C 000330 Modified array declarations. (JEC) +C +C***CATEGORY NO. E1A +C***KEYWORDS B-SPLINE,DATA FITTING,DOUBLE PRECISION,INTERPOLATION, +C SPLINE +C***AUTHOR AMOS, D. E., (SNLA) +C***PURPOSE Produces the B-spline coefficients, BCOEF, of the +C B-spline of order K with knots T(I), I=1,...,N+K, which +C takes on the value Y(I) at X(I), I=1,...,N. +C***DESCRIPTION +C +C Written by Carl de Boor and modified by D. E. Amos +C +C References +C +C A Practical Guide to Splines by C. de Boor, Applied +C Mathematics Series 27, Springer, 1979. +C +C Abstract **** a double precision routine **** +C +C DBINTK is the SPLINT routine of the reference. +C +C DBINTK produces the B-spline coefficients, BCOEF, of the +C B-spline of order K with knots T(I), I=1,...,N+K, which +C takes on the value Y(I) at X(I), I=1,...,N. The spline or +C any of its derivatives can be evaluated by calls to DBVALU. +C +C The I-th equation of the linear system A*BCOEF = B for the +C coefficients of the interpolant enforces interpolation at +C X(I), I=1,...,N. Hence, B(I) = Y(I), for all I, and A is +C a band matrix with 2K-1 bands if A is invertible. The matrix +C A is generated row by row and stored, diagonal by diagonal, +C in the rows of Q, with the main diagonal going into row K. +C The banded system is then solved by a call to DBNFAC (which +C constructs the triangular factorization for A and stores it +C again in Q), followed by a call to DBNSLV (which then +C obtains the solution BCOEF by substitution). DBNFAC does no +C pivoting, since the total positivity of the matrix A makes +C this unnecessary. The linear system to be solved is +C (theoretically) invertible if and only if +C T(I) .LT. X(I) .LT. T(I+K), for all I. +C Equality is permitted on the left for I=1 and on the right +C for I=N when K knots are used at X(1) or X(N). Otherwise, +C violation of this condition is certain to lead to an error. +C +C DBINTK calls DBSPVN, DBNFAC, DBNSLV, XERROR +C +C Description of Arguments +C +C Input X,Y,T are double precision +C X - vector of length N containing data point abscissa +C in strictly increasing order. +C Y - corresponding vector of length N containing data +C point ordinates. +C T - knot vector of length N+K +C Since T(1),..,T(K) .LE. X(1) and T(N+1),..,T(N+K) +C .GE. X(N), this leaves only N-K knots (not nec- +C essarily X(I) values) interior to (X(1),X(N)) +C N - number of data points, N .GE. K +C K - order of the spline, K .GE. 1 +C +C Output BCOEF,Q,WORK are double precision +C BCOEF - a vector of length N containing the B-spline +C coefficients +C Q - a work vector of length (2*K-1)*N, containing +C the triangular factorization of the coefficient +C matrix of the linear system being solved. The +C coefficients for the interpolant of an +C additional data set (X(I),yY(I)), I=1,...,N +C with the same abscissa can be obtained by loading +C YY into BCOEF and then executing +C CALL DBNSLV(Q,2K-1,N,K-1,K-1,BCOEF) +C WORK - work vector of length 2*K +C +C Error Conditions +C Improper input is a fatal error +C Singular system of equations is a fatal error +C***REFERENCES C. DE BOOR, *A PRACTICAL GUIDE TO SPLINES*, APPLIED +C MATHEMATICS SERIES 27, SPRINGER, 1979. +C D.E. AMOS, *COMPUTATION WITH SPLINES AND B-SPLINES*, +C SAND78-1968,SANDIA LABORATORIES,MARCH,1979. +C***ROUTINES CALLED DBNFAC,DBNSLV,DBSPVN,XERROR +C***END PROLOGUE DBINTK +C +C + INTEGER IFLAG, IWORK, K, N, I, ILP1MX, J, JJ, KM1, KPKM2, LEFT, + 1 LENQ, NP1 + DOUBLE PRECISION BCOEF(N), Y(N), Q(*), T(*), X(N), XI, WORK(*) +C DIMENSION Q(2*K-1,N), T(N+K) +C***FIRST EXECUTABLE STATEMENT DBINTK + IF(K.LT.1) GO TO 100 + IF(N.LT.K) GO TO 105 + JJ = N - 1 + IF(JJ.EQ.0) GO TO 6 + DO 5 I=1,JJ + IF(X(I).GE.X(I+1)) GO TO 110 + 5 CONTINUE + 6 CONTINUE + NP1 = N + 1 + KM1 = K - 1 + KPKM2 = 2*KM1 + LEFT = K +C ZERO OUT ALL ENTRIES OF Q + LENQ = N*(K+KM1) + DO 10 I=1,LENQ + Q(I) = 0.0D0 + 10 CONTINUE +C +C *** LOOP OVER I TO CONSTRUCT THE N INTERPOLATION EQUATIONS + DO 50 I=1,N + XI = X(I) + ILP1MX = MIN0(I+K,NP1) +C *** FIND LEFT IN THE CLOSED INTERVAL (I,I+K-1) SUCH THAT +C T(LEFT) .LE. X(I) .LT. T(LEFT+1) +C MATRIX IS SINGULAR IF THIS IS NOT POSSIBLE + LEFT = MAX0(LEFT,I) + IF (XI.LT.T(LEFT)) GO TO 80 + 20 IF (XI.LT.T(LEFT+1)) GO TO 30 + LEFT = LEFT + 1 + IF (LEFT.LT.ILP1MX) GO TO 20 + LEFT = LEFT - 1 + IF (XI.GT.T(LEFT+1)) GO TO 80 +C *** THE I-TH EQUATION ENFORCES INTERPOLATION AT XI, HENCE +C A(I,J) = B(J,K,T)(XI), ALL J. ONLY THE K ENTRIES WITH J = +C LEFT-K+1,...,LEFT ACTUALLY MIGHT BE NONZERO. THESE K NUMBERS +C ARE RETURNED, IN BCOEF (USED FOR TEMP.STORAGE HERE), BY THE +C FOLLOWING + 30 CALL DBSPVN(T, K, K, 1, XI, LEFT, BCOEF, WORK, IWORK) +C WE THEREFORE WANT BCOEF(J) = B(LEFT-K+J)(XI) TO GO INTO +C A(I,LEFT-K+J), I.E., INTO Q(I-(LEFT+J)+2*K,(LEFT+J)-K) SINCE +C A(I+J,J) IS TO GO INTO Q(I+K,J), ALL I,J, IF WE CONSIDER Q +C AS A TWO-DIM. ARRAY , WITH 2*K-1 ROWS (SEE COMMENTS IN +C DBNFAC). IN THE PRESENT PROGRAM, WE TREAT Q AS AN EQUIVALENT +C ONE-DIMENSIONAL ARRAY (BECAUSE OF FORTRAN RESTRICTIONS ON +C DIMENSION STATEMENTS) . WE THEREFORE WANT BCOEF(J) TO GO INTO +C ENTRY +C I -(LEFT+J) + 2*K + ((LEFT+J) - K-1)*(2*K-1) +C = I-LEFT+1 + (LEFT -K)*(2*K-1) + (2*K-2)*J +C OF Q . + JJ = I - LEFT + 1 + (LEFT-K)*(K+KM1) + DO 40 J=1,K + JJ = JJ + KPKM2 + Q(JJ) = BCOEF(J) + 40 CONTINUE + 50 CONTINUE +C +C ***OBTAIN FACTORIZATION OF A , STORED AGAIN IN Q. + CALL DBNFAC(Q, K+KM1, N, KM1, KM1, IFLAG) + GO TO (60, 90), IFLAG +C *** SOLVE A*BCOEF = Y BY BACKSUBSTITUTION + 60 DO 70 I=1,N + BCOEF(I) = Y(I) + 70 CONTINUE + CALL DBNSLV(Q, K+KM1, N, KM1, KM1, BCOEF) + RETURN +C +C + 80 CONTINUE +! CALL XERROR( ' DBINTK, SOME ABSCISSA WAS NOT IN THE SUPPORT OF TH +! 1E CORRESPONDING BASIS FUNCTION AND THE SYSTEM IS SINGULAR.',109,2, +! 21) + RETURN + 90 CONTINUE +! CALL XERROR( ' DBINTK, THE SYSTEM OF SOLVER DETECTS A SINGULAR SY +! 1STEM ALTHOUGH THE THEORETICAL CONDITIONS FOR A SOLUTION WERE SATIS +! 2FIED.',123,8,1) + RETURN + 100 CONTINUE +! CALL XERROR( ' DBINTK, K DOES NOT SATISFY K.GE.1', 35, 2, 1) + RETURN + 105 CONTINUE +! CALL XERROR( ' DBINTK, N DOES NOT SATISFY N.GE.K', 35, 2, 1) + RETURN + 110 CONTINUE +! CALL XERROR( ' DBINTK, X(I) DOES NOT SATISFY X(I).LT.X(I+1) FOR S +! 1OME I', 57, 2, 1) + RETURN + END + + SUBROUTINE DBNFAC(W,NROWW,NROW,NBANDL,NBANDU,IFLAG) +C***BEGIN PROLOGUE DBNFAC +C***REFER TO DBINT4,DBINTK +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***ROUTINES CALLED (NONE) +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,NROW), 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 .lt. 0) then + goto 120 + elseif (NROWM1 .eq. 0) then + goto 110 + else + goto 10 + endif + 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 = MIN0(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 = MIN0(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 = MIN0(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 + + SUBROUTINE DBNSLV(W,NROWW,NROW,NBANDL,NBANDU,B) +C***BEGIN PROLOGUE DBNSLV +C***REFER TO DBINT4,DBINTK +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***ROUTINES CALLED (NONE) +C***END PROLOGUE DBNSLV +C + INTEGER NBANDL, NBANDU, NROW, NROWW, I, J, JMAX, MIDDLE, NROWM1 + DOUBLE PRECISION W(NROWW,NROW), B(NROW) +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 = MIN0(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 = MIN0(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 + + SUBROUTINE DBSPVN(T,JHIGH,K,INDEX,X,ILEFT,VNIKX,WORK,IWORK) +C***BEGIN PROLOGUE DBSPVN +C***DATE WRITTEN 800901 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***REVISION HISTORY (YYMMDD) +C 000330 Modified array declarations. (JEC) +C +C***CATEGORY NO. E3,K6 +C***KEYWORDS B-SPLINE,DATA FITTING,DOUBLE PRECISION,INTERPOLATION, +C SPLINE +C***AUTHOR AMOS, D. E., (SNLA) +C***PURPOSE Calculates the value of all (possibly) nonzero basis +C functions at X. +C***DESCRIPTION +C +C Written by Carl de Boor and modified by D. E. Amos +C +C Reference +C SIAM J. Numerical Analysis, 14, No. 3, June, 1977, pp.441-472. +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***REFERENCES C. DE BOOR, *PACKAGE FOR CALCULATING WITH B-SPLINES*, +C SIAM JOURNAL ON NUMERICAL ANALYSIS, VOLUME 14, NO. 3, +C JUNE 1977, PP. 441-472. +C***ROUTINES CALLED XERROR +C***END PROLOGUE DBSPVN +C +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(K), 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 XERROR( ' DBSPVN, K DOES NOT SATISFY K.GE.1', 35, 2, 1) + RETURN + 100 CONTINUE +! CALL XERROR( ' DBSPVN, JHIGH DOES NOT SATISFY 1.LE.JHIGH.LE.K', +! 1 48, 2, 1) + RETURN + 105 CONTINUE +! CALL XERROR( ' DBSPVN, INDEX IS NOT 1 OR 2',29,2,1) + RETURN + 110 CONTINUE +! CALL XERROR( ' DBSPVN, X DOES NOT SATISFY T(ILEFT).LE.X.LE.T(ILEF +! 1T+1)', 56, 2, 1) + RETURN + END + + DOUBLE PRECISION FUNCTION DB3VAL(XVAL,YVAL,ZVAL,IDX,IDY,IDZ, + * TX,TY,TZ,NX,NY,NZ,KX,KY,KZ,BCOEF,WORK) +C***BEGIN PROLOGUE DB3VAL +C***DATE WRITTEN 25 MAY 1982 +C***REVISION DATE 25 MAY 1982 +C***REVISION HISTORY (YYMMDD) +C 000330 Modified array declarations. (JEC) +C +C***CATEGORY NO. E1A +C***KEYWORDS INTERPOLATION, THREE-DIMENSIONS, GRIDDED DATA, SPLINES, +C PIECEWISE POLYNOMIALS +C***AUTHOR BOISVERT, RONALD, NBS +C SCIENTIFIC COMPUTING DIVISION +C NATIONAL BUREAU OF STANDARDS +C WASHINGTON, DC 20234 +C***PURPOSE DB3VAL EVALUATES THE PIECEWISE POLYNOMIAL INTERPOLATING +C FUNCTION CONSTRUCTED BY THE ROUTINE B3INK OR ONE OF ITS +C PARTIAL DERIVATIVES. +C DOUBLE PRECISION VERSION OF B3VAL. +C***DESCRIPTION +C +C DB3VAL evaluates the tensor product piecewise polynomial +C interpolant constructed by the routine DB3INK or one of its +C derivatives at the point (XVAL,YVAL,ZVAL). To evaluate the +C interpolant itself, set IDX=IDY=IDZ=0, to evaluate the first +C partial with respect to x, set IDX=1,IDY=IDZ=0, and so on. +C +C DB3VAL returns 0.0D0 if (XVAL,YVAL,ZVAL) is out of range. That is, +C XVAL.LT.TX(1) .OR. XVAL.GT.TX(NX+KX) .OR. +C YVAL.LT.TY(1) .OR. YVAL.GT.TY(NY+KY) .OR. +C ZVAL.LT.TZ(1) .OR. ZVAL.GT.TZ(NZ+KZ) +C If the knots TX, TY, and TZ were chosen by DB3INK, then this is +C equivalent to +C XVAL.LT.X(1) .OR. XVAL.GT.X(NX)+EPSX .OR. +C YVAL.LT.Y(1) .OR. YVAL.GT.Y(NY)+EPSY .OR. +C ZVAL.LT.Z(1) .OR. ZVAL.GT.Z(NZ)+EPSZ +C where EPSX = 0.1*(X(NX)-X(NX-1)), EPSY = 0.1*(Y(NY)-Y(NY-1)), and +C EPSZ = 0.1*(Z(NZ)-Z(NZ-1)). +C +C The input quantities TX, TY, TZ, NX, NY, NZ, KX, KY, KZ, and BCOEF +C should remain unchanged since the last call of DB3INK. +C +C +C I N P U T +C --------- +C +C XVAL Double precision scalar +C X coordinate of evaluation point. +C +C YVAL Double precision scalar +C Y coordinate of evaluation point. +C +C ZVAL Double precision scalar +C Z coordinate of evaluation point. +C +C IDX Integer scalar +C X derivative of piecewise polynomial to evaluate. +C +C IDY Integer scalar +C Y derivative of piecewise polynomial to evaluate. +C +C IDZ Integer scalar +C Z derivative of piecewise polynomial to evaluate. +C +C TX Double precision 1D array (size NX+KX) +C Sequence of knots defining the piecewise polynomial in +C the x direction. (Same as in last call to DB3INK.) +C +C TY Double precision 1D array (size NY+KY) +C Sequence of knots defining the piecewise polynomial in +C the y direction. (Same as in last call to DB3INK.) +C +C TZ Double precision 1D array (size NZ+KZ) +C Sequence of knots defining the piecewise polynomial in +C the z direction. (Same as in last call to DB3INK.) +C +C NX Integer scalar +C The number of interpolation points in x. +C (Same as in last call to DB3INK.) +C +C NY Integer scalar +C The number of interpolation points in y. +C (Same as in last call to DB3INK.) +C +C NZ Integer scalar +C The number of interpolation points in z. +C (Same as in last call to DB3INK.) +C +C KX Integer scalar +C Order of polynomial pieces in x. +C (Same as in last call to DB3INK.) +C +C KY Integer scalar +C Order of polynomial pieces in y. +C (Same as in last call to DB3INK.) +C +C KZ Integer scalar +C Order of polynomial pieces in z. +C (Same as in last call to DB3INK.) +C +C BCOEF Double precision 2D array (size NX by NY by NZ) +C The B-spline coefficients computed by DB3INK. +C +C WORK Double precision 1D array (size KY*KZ+3*max(KX,KY,KZ)+KZ) +C A working storage array. +C +C***REFERENCES CARL DE BOOR, A PRACTICAL GUIDE TO SPLINES, +C SPRINGER-VERLAG, NEW YORK, 1978. +C***ROUTINES CALLED DINTRV,DBVALU +C***END PROLOGUE DB3VAL +C +C<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> +C +C MODIFICATION +C ------------ +C +C ADDED CHECK TO SEE IF X OR Y IS OUT OF RANGE, IF SO, RETURN 0.0 +C +C R.F. BOISVERT, NIST +C 22 FEB 00 +C +C<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> +C ------------ +C DECLARATIONS +C ------------ +C +C PARAMETERS +C + INTEGER + * IDX, IDY, IDZ, NX, NY, NZ, KX, KY, KZ + DOUBLE PRECISION + * XVAL, YVAL, ZVAL, TX(*), TY(*), TZ(*), BCOEF(NX,NY,NZ), + * WORK(*) +C +C LOCAL VARIABLES +C + INTEGER + * ILOY, ILOZ, INBVX, INBV1, INBV2, LEFTY, LEFTZ, MFLAG, + * KCOLY, KCOLZ, IZ, IZM1, IW, I, J, K + DOUBLE PRECISION + * DBVALU +C + DATA ILOY /1/, ILOZ /1/, INBVX /1/ +C SAVE ILOY , ILOZ , INBVX +C +C +C***FIRST EXECUTABLE STATEMENT + DB3VAL = 0.0D0 +C NEXT STATEMENT - RFB MOD + IF (XVAL.LT.TX(1) .OR. XVAL.GT.TX(NX+KX) .OR. + + YVAL.LT.TY(1) .OR. YVAL.GT.TY(NY+KY) .OR. + + ZVAL.LT.TZ(1) .OR. ZVAL.GT.TZ(NZ+KZ)) GO TO 100 + CALL DINTRV(TY,NY+KY,YVAL,ILOY,LEFTY,MFLAG) + IF (MFLAG .NE. 0) GO TO 100 + CALL DINTRV(TZ,NZ+KZ,ZVAL,ILOZ,LEFTZ,MFLAG) + IF (MFLAG .NE. 0) GO TO 100 + IZ = 1 + KY*KZ + IW = IZ + KZ + KCOLZ = LEFTZ - KZ + I = 0 + DO 50 K=1,KZ + KCOLZ = KCOLZ + 1 + KCOLY = LEFTY - KY + DO 50 J=1,KY + I = I + 1 + KCOLY = KCOLY + 1 + WORK(I) = DBVALU(TX,BCOEF(1,KCOLY,KCOLZ),NX,KX,IDX,XVAL, + * INBVX,WORK(IW)) + 50 CONTINUE + INBV1 = 1 + IZM1 = IZ - 1 + KCOLY = LEFTY - KY + 1 + DO 60 K=1,KZ + I = (K-1)*KY + 1 + J = IZM1 + K + WORK(J) = DBVALU(TY(KCOLY),WORK(I),KY,KY,IDY,YVAL, + * INBV1,WORK(IW)) + 60 CONTINUE + INBV2 = 1 + KCOLZ = LEFTZ - KZ + 1 + DB3VAL = DBVALU(TZ(KCOLZ),WORK(IZ),KZ,KZ,IDZ,ZVAL,INBV2, + * WORK(IW)) + 100 CONTINUE + RETURN + END + + SUBROUTINE DB3INK(X,NX,Y,NY,Z,NZ,FCN,LDF1,LDF2,KX,KY,KZ,TX,TY,TZ, + * BCOEF,WORK,IFLAG) +C***BEGIN PROLOGUE DB3INK +C***DATE WRITTEN 25 MAY 1982 +C***REVISION DATE 25 MAY 1982 +C***REVISION HISTORY (YYMMDD) +C 000330 Modified array declarations. (JEC) +C +C***CATEGORY NO. E1A +C***KEYWORDS INTERPOLATION, THREE-DIMENSIONS, GRIDDED DATA, SPLINES, +C PIECEWISE POLYNOMIALS +C***AUTHOR BOISVERT, RONALD, NBS +C SCIENTIFIC COMPUTING DIVISION +C NATIONAL BUREAU OF STANDARDS +C WASHINGTON, DC 20234 +C***PURPOSE DOUBLE PRECISION VERSION OF DB3INK +C DB3INK DETERMINES A PIECEWISE POLYNOMIAL FUNCTION THAT +C INTERPOLATES THREE-DIMENSIONAL GRIDDED DATA. USERS SPECIFY +C THE POLYNOMIAL ORDER (DEGREE+1) OF THE INTERPOLANT AND +C (OPTIONALLY) THE KNOT SEQUENCE. +C***DESCRIPTION +C +C DB3INK determines the parameters of a function that interpolates +C the three-dimensional gridded data (X(i),Y(j),Z(k),FCN(i,j,k)) for +C i=1,..,NX, j=1,..,NY, and k=1,..,NZ. The interpolating function and +C its derivatives may subsequently be evaluated by the function +C DB3VAL. +C +C The interpolating function is a piecewise polynomial function +C represented as a tensor product of one-dimensional B-splines. The +C form of this function is +C +C NX NY NZ +C S(x,y,z) = SUM SUM SUM a U (x) V (y) W (z) +C i=1 j=1 k=1 ij i j k +C +C where the functions U(i), V(j), and W(k) are one-dimensional B- +C spline basis functions. The coefficients a(i,j) are chosen so that +C +C S(X(i),Y(j),Z(k)) = FCN(i,j,k) for i=1,..,NX, j=1,..,NY, k=1,..,NZ +C +C Note that for fixed values of y and z S(x,y,z) is a piecewise +C polynomial function of x alone, for fixed values of x and z S(x,y, +C z) is a piecewise polynomial function of y alone, and for fixed +C values of x and y S(x,y,z) is a function of z alone. In one +C dimension a piecewise polynomial may be created by partitioning a +C given interval into subintervals and defining a distinct polynomial +C piece on each one. The points where adjacent subintervals meet are +C called knots. Each of the functions U(i), V(j), and W(k) above is a +C piecewise polynomial. +C +C Users of DB3INK choose the order (degree+1) of the polynomial +C pieces used to define the piecewise polynomial in each of the x, y, +C and z directions (KX, KY, and KZ). Users also may define their own +C knot sequence in x, y, and z separately (TX, TY, and TZ). If IFLAG= +C 0, however, DB3INK will choose sequences of knots that result in a +C piecewise polynomial interpolant with KX-2 continuous partial +C derivatives in x, KY-2 continuous partial derivatives in y, and KZ- +C 2 continuous partial derivatives in z. (KX knots are taken near +C each endpoint in x, not-a-knot end conditions are used, and the +C remaining knots are placed at data points if KX is even or at +C midpoints between data points if KX is odd. The y and z directions +C are treated similarly.) +C +C After a call to DB3INK, all information necessary to define the +C interpolating function are contained in the parameters NX, NY, NZ, +C KX, KY, KZ, TX, TY, TZ, and BCOEF. These quantities should not be +C altered until after the last call of the evaluation routine DB3VAL. +C +C +C I N P U T +C --------- +C +C X Double precision 1D array (size NX) +C Array of x abcissae. Must be strictly increasing. +C +C NX Integer scalar (.GE. 3) +C Number of x abcissae. +C +C Y Double precision 1D array (size NY) +C Array of y abcissae. Must be strictly increasing. +C +C NY Integer scalar (.GE. 3) +C Number of y abcissae. +C +C Z Double precision 1D array (size NZ) +C Array of z abcissae. Must be strictly increasing. +C +C NZ Integer scalar (.GE. 3) +C Number of z abcissae. +C +C FCN Double precision 3D array (size LDF1 by LDF2 by NY) +C Array of function values to interpolate. FCN(I,J,K) should +C contain the function value at the point (X(I),Y(J),Z(K)) +C +C LDF1 Integer scalar (.GE. NX) +C The actual first dimension of FCN used in the +C calling program. +C +C LDF2 Integer scalar (.GE. NY) +C The actual second dimension of FCN used in the calling +C program. +C +C KX Integer scalar (.GE. 2, .LT. NX) +C The order of spline pieces in x. +C (Order = polynomial degree + 1) +C +C KY Integer scalar (.GE. 2, .LT. NY) +C The order of spline pieces in y. +C (Order = polynomial degree + 1) +C +C KZ Integer scalar (.GE. 2, .LT. NZ) +C The order of spline pieces in z. +C (Order = polynomial degree + 1) +C +C +C I N P U T O R O U T P U T +C ----------------------------- +C +C TX Double precision 1D array (size NX+KX) +C The knots in the x direction for the spline interpolant. +C If IFLAG=0 these are chosen by DB3INK. +C If IFLAG=1 these are specified by the user. +C (Must be non-decreasing.) +C +C TY Double precision 1D array (size NY+KY) +C The knots in the y direction for the spline interpolant. +C If IFLAG=0 these are chosen by DB3INK. +C If IFLAG=1 these are specified by the user. +C (Must be non-decreasing.) +C +C TZ Double precision 1D array (size NZ+KZ) +C The knots in the z direction for the spline interpolant. +C If IFLAG=0 these are chosen by DB3INK. +C If IFLAG=1 these are specified by the user. +C (Must be non-decreasing.) +C +C +C O U T P U T +C ----------- +C +C BCOEF Double precision 3D array (size NX by NY by NZ) +C Array of coefficients of the B-spline interpolant. +C This may be the same array as FCN. +C +C +C M I S C E L L A N E O U S +C ------------------------- +C +C WORK Double precision 1D array (size NX*NY*NZ + max( 2*KX*(NX+1), +C 2*KY*(NY+1), 2*KZ*(NZ+1) ) +C Array of working storage. +C +C IFLAG Integer scalar. +C On input: 0 == knot sequence chosen by B2INK +C 1 == knot sequence chosen by user. +C On output: 1 == successful execution +C 2 == IFLAG out of range +C 3 == NX out of range +C 4 == KX out of range +C 5 == X not strictly increasing +C 6 == TX not non-decreasing +C 7 == NY out of range +C 8 == KY out of range +C 9 == Y not strictly increasing +C 10 == TY not non-decreasing +C 11 == NZ out of range +C 12 == KZ out of range +C 13 == Z not strictly increasing +C 14 == TY not non-decreasing +C +C***REFERENCES CARL DE BOOR, A PRACTICAL GUIDE TO SPLINES, +C SPRINGER-VERLAG, NEW YORK, 1978. +C CARL DE BOOR, EFFICIENT COMPUTER MANIPULATION OF TENSOR +C PRODUCTS, ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE, +C VOL. 5 (1979), PP. 173-182. +C***ROUTINES CALLED DBTPCF,DBKNOT +C***END PROLOGUE DB3INK +C +C ------------ +C DECLARATIONS +C ------------ +C +C PARAMETERS +C + INTEGER + * NX, NY, NZ, LDF1, LDF2, KX, KY, KZ, IFLAG + DOUBLE PRECISION + * X(NX), Y(NY), Z(NZ), FCN(LDF1,LDF2,NZ), TX(*), TY(*), TZ(*), + * BCOEF(NX,NY,NZ), WORK(*) +C +C LOCAL VARIABLES +C + INTEGER + * I, J, LOC, IW, NPK +C +C ----------------------- +C CHECK VALIDITY OF INPUT +C ----------------------- +C +C***FIRST EXECUTABLE STATEMENT + IF ((IFLAG .LT. 0) .OR. (IFLAG .GT. 1)) GO TO 920 + IF (NX .LT. 3) GO TO 930 + IF (NY .LT. 3) GO TO 970 + IF (NZ .LT. 3) GO TO 1010 + IF ((KX .LT. 2) .OR. (KX .GE. NX)) GO TO 940 + IF ((KY .LT. 2) .OR. (KY .GE. NY)) GO TO 980 + IF ((KZ .LT. 2) .OR. (KZ .GE. NZ)) GO TO 1020 + DO 10 I=2,NX + IF (X(I) .LE. X(I-1)) GO TO 950 + 10 CONTINUE + DO 20 I=2,NY + IF (Y(I) .LE. Y(I-1)) GO TO 990 + 20 CONTINUE + DO 30 I=2,NZ + IF (Z(I) .LE. Z(I-1)) GO TO 1030 + 30 CONTINUE + IF (IFLAG .EQ. 0) GO TO 70 + NPK = NX + KX + DO 40 I=2,NPK + IF (TX(I) .LT. TX(I-1)) GO TO 960 + 40 CONTINUE + NPK = NY + KY + DO 50 I=2,NPK + IF (TY(I) .LT. TY(I-1)) GO TO 1000 + 50 CONTINUE + NPK = NZ + KZ + DO 60 I=2,NPK + IF (TZ(I) .LT. TZ(I-1)) GO TO 1040 + 60 CONTINUE + 70 CONTINUE +C +C ------------ +C CHOOSE KNOTS +C ------------ +C + IF (IFLAG .NE. 0) GO TO 100 + CALL DBKNOT(X,NX,KX,TX) + CALL DBKNOT(Y,NY,KY,TY) + CALL DBKNOT(Z,NZ,KZ,TZ) + 100 CONTINUE +C +C ------------------------------- +C CONSTRUCT B-SPLINE COEFFICIENTS +C ------------------------------- +C + IFLAG = 1 + IW = NX*NY*NZ + 1 +C +C COPY FCN TO WORK IN PACKED FOR DBTPCF + LOC = 0 + DO 510 K=1,NZ + DO 510 J=1,NY + DO 510 I=1,NX + LOC = LOC + 1 + WORK(LOC) = FCN(I,J,K) + 510 CONTINUE +C + CALL DBTPCF(X,NX,WORK,NX,NY*NZ,TX,KX,BCOEF,WORK(IW)) + CALL DBTPCF(Y,NY,BCOEF,NY,NX*NZ,TY,KY,WORK,WORK(IW)) + CALL DBTPCF(Z,NZ,WORK,NZ,NX*NY,TZ,KZ,BCOEF,WORK(IW)) + GO TO 9999 +C +C ----- +C EXITS +C ----- +C + 920 CONTINUE +! CALL XERRWV('DB3INK - IFLAG=I1 IS OUT OF RANGE.', +! * 35,2,1,1,IFLAG,I2,0,R1,R2) + IFLAG = 2 + GO TO 9999 +C + 930 CONTINUE + IFLAG = 3 +! CALL XERRWV('DB3INK - NX=I1 IS OUT OF RANGE.', +! * 32,IFLAG,1,1,NX,I2,0,R1,R2) + GO TO 9999 +C + 940 CONTINUE + IFLAG = 4 +! CALL XERRWV('DB3INK - KX=I1 IS OUT OF RANGE.', +! * 32,IFLAG,1,1,KX,I2,0,R1,R2) + GO TO 9999 +C + 950 CONTINUE + IFLAG = 5 +! CALL XERRWV('DB3INK - X ARRAY MUST BE STRICTLY INCREASING.', +! * 46,IFLAG,1,0,I1,I2,0,R1,R2) + GO TO 9999 +C + 960 CONTINUE + IFLAG = 6 +! CALL XERRWV('DB3INK - TX ARRAY MUST BE NON-DECREASING.', +! * 42,IFLAG,1,0,I1,I2,0,R1,R2) + GO TO 9999 +C + 970 CONTINUE + IFLAG = 7 +! CALL XERRWV('DB3INK - NY=I1 IS OUT OF RANGE.', +! * 32,IFLAG,1,1,NY,I2,0,R1,R2) + GO TO 9999 +C + 980 CONTINUE + IFLAG = 8 +! CALL XERRWV('DB3INK - KY=I1 IS OUT OF RANGE.', +! * 32,IFLAG,1,1,KY,I2,0,R1,R2) + GO TO 9999 +C + 990 CONTINUE + IFLAG = 9 +! CALL XERRWV('DB3INK - Y ARRAY MUST BE STRICTLY INCREASING.', +! * 46,IFLAG,1,0,I1,I2,0,R1,R2) + GO TO 9999 +C + 1000 CONTINUE + IFLAG = 10 +! CALL XERRWV('DB3INK - TY ARRAY MUST BE NON-DECREASING.', +! * 42,IFLAG,1,0,I1,I2,0,R1,R2) + GO TO 9999 +C + 1010 CONTINUE + IFLAG = 11 +! CALL XERRWV('DB3INK - NZ=I1 IS OUT OF RANGE.', +! * 32,IFLAG,1,1,NZ,I2,0,R1,R2) + GO TO 9999 +C + 1020 CONTINUE + IFLAG = 12 +! CALL XERRWV('DB3INK - KZ=I1 IS OUT OF RANGE.', +! * 32,IFLAG,1,1,KZ,I2,0,R1,R2) + GO TO 9999 +C + 1030 CONTINUE + IFLAG = 13 +! CALL XERRWV('DB3INK - Z ARRAY MUST BE STRICTLY INCREASING.', +! * 46,IFLAG,1,0,I1,I2,0,R1,R2) + GO TO 9999 +C + 1040 CONTINUE + IFLAG = 14 +! CALL XERRWV('DB3INK - TZ ARRAY MUST BE NON-DECREASING.', +! * 42,IFLAG,1,0,I1,I2,0,R1,R2) + GO TO 9999 +C + 9999 CONTINUE + RETURN + END + diff --git a/modules/elementary_functions/src/fortran/slatec/dtensbs.lo b/modules/elementary_functions/src/fortran/slatec/dtensbs.lo new file mode 100755 index 000000000..34102d76e --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dtensbs.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dtensbs.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dtensbs.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dxlegf.f b/modules/elementary_functions/src/fortran/slatec/dxlegf.f new file mode 100755 index 000000000..5ba6a02ec --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dxlegf.f @@ -0,0 +1,1642 @@ +* +* original code from the Slatec library +* +* slight modifications by Bruno Pincon <Bruno.Pincon@iecn.u-nancy.fr> : +* +* 1/ some (minor modifications) so that the "enter" is +* now X and not THETA (X=cos(THETA)). This leads to +* better accuracy for x near 0 and seems more +* natural but may be there is some drawback ? +* 2/ remove parts which send warning messages to the +* Slatec XERMSG routine (nevertheless all the errors +* flags are communicated throw IERROR). +* Normaly the scilab interface verify the validity of the +* input arguments but the verifications in this code are +* still here. +* 3/ substitute calls to I1MACH by calls to dlamch +* (Scilab uses dlamch and not I1MACH to get machine +* parameter so it seems more logical). +* +* IERROR values : +* 210 : DNU1, NUDIFF, MU1, MU2, or ID not valid +* 211 : X out of range (must be in [0,1) +* 201, 202, 203, 204 : invalid input was provided to DXSET +* (should not occurred in IEEE floating point) +* 205, 206 : internal consistency error occurred in DXSET +* (probably due to a software malfunction in the +* library routine I1MACH) Should not occurred +* in IEEE floating point, if dlamch works well. +* 207 : an overflow or underflow of an extended-range number +* was detected in DXADJ. +* 208 : an error which may occur in DXC210 but this one is not +* call from DXLEGF (don't know why it is given below). +* +* Normally on the return to scilab, only 207 may be present. + + +*DECK DXLEGF + SUBROUTINE DXLEGF(DNU1, NUDIFF, MU1, MU2, X, ID, PQA, IPQA, + 1 IERROR) +C***BEGIN PROLOGUE DXLEGF +C***PURPOSE Compute normalized Legendre polynomials and associated +C Legendre functions. +C***LIBRARY SLATEC +C***CATEGORY C3A2, C9 +C***TYPE DOUBLE PRECISION (XLEGF-S, DXLEGF-D) +C***KEYWORDS LEGENDRE FUNCTIONS +C***AUTHOR Smith, John M., (NBS and George Mason University) +C***DESCRIPTION +C +C DXLEGF: Extended-range Double-precision Legendre Functions +C +C A feature of the DXLEGF subroutine for Legendre functions is +C the use of extended-range arithmetic, a software extension of +C ordinary floating-point arithmetic that greatly increases the +C exponent range of the representable numbers. This avoids the +C need for scaling the solutions to lie within the exponent range +C of the most restrictive manufacturer's hardware. The increased +C exponent range is achieved by allocating an integer storage +C location together with each floating-point storage location. +C +C The interpretation of the pair (X,I) where X is floating-point +C and I is integer is X*(IR**I) where IR is the internal radix of +C the computer arithmetic. +C +C This subroutine computes one of the following vectors: +C +C 1. Legendre function of the first kind of negative order, either +C a. P(-MU1,NU,X), P(-MU1-1,NU,X), ..., P(-MU2,NU,X) or +C b. P(-MU,NU1,X), P(-MU,NU1+1,X), ..., P(-MU,NU2,X) +C 2. Legendre function of the second kind, either +C a. Q(MU1,NU,X), Q(MU1+1,NU,X), ..., Q(MU2,NU,X) or +C b. Q(MU,NU1,X), Q(MU,NU1+1,X), ..., Q(MU,NU2,X) +C 3. Legendre function of the first kind of positive order, either +C a. P(MU1,NU,X), P(MU1+1,NU,X), ..., P(MU2,NU,X) or +C b. P(MU,NU1,X), P(MU,NU1+1,X), ..., P(MU,NU2,X) +C 4. Normalized Legendre polynomials, either +C a. PN(MU1,NU,X), PN(MU1+1,NU,X), ..., PN(MU2,NU,X) or +C b. PN(MU,NU1,X), PN(MU,NU1+1,X), ..., PN(MU,NU2,X) +C +C where X = COS(THETA). +C +C The input values to DXLEGF are DNU1, NUDIFF, MU1, MU2, THETA (now X), +C and ID. These must satisfy +C +C DNU1 is DOUBLE PRECISION and greater than or equal to -0.5; +C NUDIFF is INTEGER and non-negative; +C MU1 is INTEGER and non-negative; +C MU2 is INTEGER and greater than or equal to MU1; + +C THETA is DOUBLE PRECISION and in the half-open interval (0,PI/2]; +* modification : X is given (and not THETA) X must be in [0,1) + +C ID is INTEGER and equal to 1, 2, 3 or 4; +C +C and additionally either NUDIFF = 0 or MU2 = MU1. +C +C If ID=1 and NUDIFF=0, a vector of type 1a above is computed +C with NU=DNU1. +C +C If ID=1 and MU1=MU2, a vector of type 1b above is computed +C with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1. +C +C If ID=2 and NUDIFF=0, a vector of type 2a above is computed +C with NU=DNU1. +C +C If ID=2 and MU1=MU2, a vector of type 2b above is computed +C with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1. +C +C If ID=3 and NUDIFF=0, a vector of type 3a above is computed +C with NU=DNU1. +C +C If ID=3 and MU1=MU2, a vector of type 3b above is computed +C with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1. +C +C If ID=4 and NUDIFF=0, a vector of type 4a above is computed +C with NU=DNU1. +C +C If ID=4 and MU1=MU2, a vector of type 4b above is computed +C with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1. +C +C In each case the vector of computed Legendre function values +C is returned in the extended-range vector (PQA(I),IPQA(I)). The +C length of this vector is either MU2-MU1+1 or NUDIFF+1. +C +C Where possible, DXLEGF returns IPQA(I) as zero. In this case the +C value of the Legendre function is contained entirely in PQA(I), +C so it can be used in subsequent computations without further +C consideration of extended-range arithmetic. If IPQA(I) is nonzero, +C then the value of the Legendre function is not representable in +C floating-point because of underflow or overflow. The program that +C calls DXLEGF must test IPQA(I) to ensure correct usage. +C +C IERROR is an error indicator. If no errors are detected, IERROR=0 +C when control returns to the calling routine. If an error is detected, +C IERROR is returned as nonzero. The calling routine must check the +C value of IERROR. +C +C If IERROR=210 or 211, invalid input was provided to DXLEGF. +C If IERROR=201,202,203, or 204, invalid input was provided to DXSET. +C If IERROR=205 or 206, an internal consistency error occurred in +C DXSET (probably due to a software malfunction in the library routine +C I1MACH). +C If IERROR=207, an overflow or underflow of an extended-range number +C was detected in DXADJ. +C If IERROR=208, an overflow or underflow of an extended-range number +C was detected in DXC210. +C +C***SEE ALSO DXSET +C***REFERENCES Olver and Smith, Associated Legendre Functions on the +C Cut, J Comp Phys, v 51, n 3, Sept 1983, pp 502--518. +C Smith, Olver and Lozier, Extended-Range Arithmetic and +C Normalized Legendre Polynomials, ACM Trans on Math +C Softw, v 7, n 1, March 1981, pp 93--105. +C***ROUTINES CALLED DXPMU, DXPMUP, DXPNRM, DXPQNU, DXQMU, DXQNU, DXRED, +C DXSET, XERMSG +C***REVISION HISTORY (YYMMDD) +C 820728 DATE WRITTEN +C 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) +C 901019 Revisions to prologue. (DWL and WRB) +C 901106 Changed all specific intrinsics to generic. (WRB) +C Corrected order of sections in prologue and added TYPE +C section. (WRB) +C CALLs to XERROR changed to CALLs to XERMSG. (WRB) +C 920127 Revised PURPOSE section of prologue. (DWL) +C***END PROLOGUE DXLEGF + DOUBLE PRECISION PQA,DNU1,DNU2,SX,X,PI2 + DIMENSION PQA(*),IPQA(*) +C +C***FIRST EXECUTABLE STATEMENT DXLEGF + IERROR=0 + CALL DXSET (0, 0, 0.0D0, 0,IERROR) + IF (IERROR.NE.0) RETURN + PI2=2.D0*ATAN(1.D0) +C +C ZERO OUTPUT ARRAYS +C + L=(MU2-MU1)+NUDIFF+1 + DO 290 I=1,L + PQA(I)=0.D0 + 290 IPQA(I)=0 +C +C CHECK FOR VALID INPUT VALUES +C +*** normally all these are verified by the scilab interface + IF(NUDIFF.LT.0) GO TO 400 + IF(DNU1.LT.-.5D0) GO TO 400 + IF(MU2.LT.MU1) GO TO 400 + IF(MU1.LT.0) GO TO 400 +* IF(THETA.LE.0.D0.OR.THETA.GT.PI2) GO TO 420 + IF(X.LT.0.D0.OR.X.GT.1.d0) GO TO 420 + IF(ID.LT.1.OR.ID.GT.4) GO TO 400 + IF((MU1.NE.MU2).AND.(NUDIFF.GT.0)) GO TO 400 +C +C IF DNU1 IS NOT AN INTEGER, NORMALIZED P(MU,DNU,X) +C CANNOT BE CALCULATED. IF DNU1 IS AN INTEGER AND +C MU1.GT.DNU2 THEN ALL VALUES OF P(+MU,DNU,X) AND +C NORMALIZED P(MU,NU,X) WILL BE ZERO. +C + DNU2=DNU1+NUDIFF + IF((ID.EQ.3).AND.(MOD(DNU1,1.D0).NE.0.D0)) GO TO 295 + IF((ID.EQ.4).AND.(MOD(DNU1,1.D0).NE.0.D0)) GO TO 400 + IF((ID.EQ.3.OR.ID.EQ.4).AND.MU1.GT.DNU2) RETURN + 295 CONTINUE +C +* X=COS(THETA) +* SX=1.D0/SIN(THETA) + SX=1.D0/SQRT((1.d0-X)*(1.d0+X)) + IF(ID.EQ.2) GO TO 300 + IF(MU2-MU1.LE.0) GO TO 360 +C +C FIXED NU, VARIABLE MU +C CALL DXPMU TO CALCULATE P(-MU1,NU,X),....,P(-MU2,NU,X) +C + CALL DXPMU(DNU1,DNU2,MU1,MU2,X,SX,ID,PQA,IPQA,IERROR) + IF (IERROR.NE.0) RETURN + GO TO 380 +C + 300 IF(MU2.EQ.MU1) GO TO 320 +C +C FIXED NU, VARIABLE MU +C CALL DXQMU TO CALCULATE Q(MU1,NU,X),....,Q(MU2,NU,X) +C + CALL DXQMU(DNU1,DNU2,MU1,MU2,X,SX,ID,PQA,IPQA,IERROR) + IF (IERROR.NE.0) RETURN + GO TO 390 +C +C FIXED MU, VARIABLE NU +C CALL DXQNU TO CALCULATE Q(MU,DNU1,X),....,Q(MU,DNU2,X) +C + 320 CALL DXQNU(DNU1,DNU2,MU1,X,SX,ID,PQA,IPQA,IERROR) + IF (IERROR.NE.0) RETURN + GO TO 390 +C +C FIXED MU, VARIABLE NU +C CALL DXPQNU TO CALCULATE P(-MU,DNU1,X),....,P(-MU,DNU2,X) +C + 360 CALL DXPQNU(DNU1,DNU2,MU1,X,SX,ID,PQA,IPQA,IERROR) + IF (IERROR.NE.0) RETURN +C +C IF ID = 3, TRANSFORM P(-MU,NU,X) VECTOR INTO +C P(MU,NU,X) VECTOR. +C + 380 IF(ID.EQ.3) CALL DXPMUP(DNU1,DNU2,MU1,MU2,PQA,IPQA,IERROR) + IF (IERROR.NE.0) RETURN +C +C IF ID = 4, TRANSFORM P(-MU,NU,X) VECTOR INTO +C NORMALIZED P(MU,NU,X) VECTOR. +C + IF(ID.EQ.4) CALL DXPNRM(DNU1,DNU2,MU1,MU2,PQA,IPQA,IERROR) + IF (IERROR.NE.0) RETURN +C +C PLACE RESULTS IN REDUCED FORM IF POSSIBLE +C AND RETURN TO MAIN PROGRAM. +C + 390 DO 395 I=1,L + CALL DXRED(PQA(I),IPQA(I),IERROR) + IF (IERROR.NE.0) RETURN + 395 CONTINUE + RETURN +C +C ***** ERROR TERMINATION ***** +C +* 400 CALL XERMSG ('SLATEC', 'DXLEGF', +* + 'DNU1, NUDIFF, MU1, MU2, or ID not valid', 210, 1) + 400 continue + IERROR=210 + RETURN +* 420 CALL XERMSG ('SLATEC', 'DXLEGF', 'THETA out of range', 211, 1) + 420 continue + IERROR=211 + RETURN + END +*DECK DXPMU + SUBROUTINE DXPMU (NU1, NU2, MU1, MU2, X, SX, ID, PQA, IPQA, + 1 IERROR) +C***BEGIN PROLOGUE DXPMU +C***SUBSIDIARY +C***PURPOSE To compute the values of Legendre functions for DXLEGF. +C Method: backward mu-wise recurrence for P(-MU,NU,X) for +C fixed nu to obtain P(-MU2,NU1,X), P(-(MU2-1),NU1,X), ..., +C P(-MU1,NU1,X) and store in ascending mu order. +C***LIBRARY SLATEC +C***CATEGORY C3A2, C9 +C***TYPE DOUBLE PRECISION (XPMU-S, DXPMU-D) +C***KEYWORDS LEGENDRE FUNCTIONS +C***AUTHOR Smith, John M., (NBS and George Mason University) +C***ROUTINES CALLED DXADD, DXADJ, DXPQNU +C***REVISION HISTORY (YYMMDD) +C 820728 DATE WRITTEN +C 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) +C 901019 Revisions to prologue. (DWL and WRB) +C 901106 Changed all specific intrinsics to generic. (WRB) +C Corrected order of sections in prologue and added TYPE +C section. (WRB) +C 920127 Revised PURPOSE section of prologue. (DWL) +C***END PROLOGUE DXPMU + DOUBLE PRECISION PQA,NU1,NU2,P0,X,SX,X1,X2 + DIMENSION PQA(*),IPQA(*) +C +C CALL DXPQNU TO OBTAIN P(-MU2,NU,X) +C +C***FIRST EXECUTABLE STATEMENT DXPMU + IERROR=0 + CALL DXPQNU(NU1,NU2,MU2,X,SX,ID,PQA,IPQA,IERROR) + IF (IERROR.NE.0) RETURN + P0=PQA(1) + IP0=IPQA(1) + MU=MU2-1 +C +C CALL DXPQNU TO OBTAIN P(-MU2-1,NU,X) +C + CALL DXPQNU(NU1,NU2,MU,X,SX,ID,PQA,IPQA,IERROR) + IF (IERROR.NE.0) RETURN + N=MU2-MU1+1 + PQA(N)=P0 + IPQA(N)=IP0 + IF(N.EQ.1) GO TO 300 + PQA(N-1)=PQA(1) + IPQA(N-1)=IPQA(1) + IF(N.EQ.2) GO TO 300 + J=N-2 + 290 CONTINUE +C +C BACKWARD RECURRENCE IN MU TO OBTAIN +C P(-MU2,NU1,X),P(-(MU2-1),NU1,X),....P(-MU1,NU1,X) +C USING +C (NU-MU)*(NU+MU+1.)*P(-(MU+1),NU,X)= +C 2.*MU*X*SQRT((1./(1.-X**2))*P(-MU,NU,X)-P(-(MU-1),NU,X) +C + X1=2.D0*MU*X*SX*PQA(J+1) + X2=-(NU1-MU)*(NU1+MU+1.D0)*PQA(J+2) + CALL DXADD(X1,IPQA(J+1),X2,IPQA(J+2),PQA(J),IPQA(J),IERROR) + IF (IERROR.NE.0) RETURN + CALL DXADJ(PQA(J),IPQA(J),IERROR) + IF (IERROR.NE.0) RETURN + IF(J.EQ.1) GO TO 300 + J=J-1 + MU=MU-1 + GO TO 290 + 300 RETURN + END +*DECK DXPMUP + SUBROUTINE DXPMUP (NU1, NU2, MU1, MU2, PQA, IPQA, IERROR) +C***BEGIN PROLOGUE DXPMUP +C***SUBSIDIARY +C***PURPOSE To compute the values of Legendre functions for DXLEGF. +C This subroutine transforms an array of Legendre functions +C of the first kind of negative order stored in array PQA +C into Legendre functions of the first kind of positive +C order stored in array PQA. The original array is destroyed. +C***LIBRARY SLATEC +C***CATEGORY C3A2, C9 +C***TYPE DOUBLE PRECISION (XPMUP-S, DXPMUP-D) +C***KEYWORDS LEGENDRE FUNCTIONS +C***AUTHOR Smith, John M., (NBS and George Mason University) +C***ROUTINES CALLED DXADJ +C***REVISION HISTORY (YYMMDD) +C 820728 DATE WRITTEN +C 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) +C 901019 Revisions to prologue. (DWL and WRB) +C 901106 Changed all specific intrinsics to generic. (WRB) +C Corrected order of sections in prologue and added TYPE +C section. (WRB) +C 920127 Revised PURPOSE section of prologue. (DWL) +C***END PROLOGUE DXPMUP + DOUBLE PRECISION DMU,NU,NU1,NU2,PQA,PROD + DIMENSION PQA(*),IPQA(*) +C***FIRST EXECUTABLE STATEMENT DXPMUP + IERROR=0 + NU=NU1 + MU=MU1 + DMU=MU + N=INT(NU2-NU1+.1D0)+(MU2-MU1)+1 + J=1 +* IF(MOD(REAL(NU),1.).NE.0.) GO TO 210 + IF(MOD(NU,1.d0).NE.0.d0) GO TO 210 + 200 IF(DMU.LT.NU+1.D0) GO TO 210 + PQA(J)=0.D0 + IPQA(J)=0 + J=J+1 + IF(J.GT.N) RETURN +C INCREMENT EITHER MU OR NU AS APPROPRIATE. + IF(NU2-NU1.GT..5D0) NU=NU+1.D0 + IF(MU2.GT.MU1) MU=MU+1 + GO TO 200 +C +C TRANSFORM P(-MU,NU,X) TO P(MU,NU,X) USING +C P(MU,NU,X)=(NU-MU+1)*(NU-MU+2)*...*(NU+MU)*P(-MU,NU,X)*(-1)**MU +C + 210 PROD=1.D0 + IPROD=0 + K=2*MU + IF(K.EQ.0) GO TO 222 + DO 220 L=1,K + PROD=PROD*(DMU-NU-L) + 220 CALL DXADJ(PROD,IPROD,IERROR) + IF (IERROR.NE.0) RETURN + 222 CONTINUE + DO 240 I=J,N + IF(MU.EQ.0) GO TO 225 + PQA(I)=PQA(I)*PROD*(-1)**MU + IPQA(I)=IPQA(I)+IPROD + CALL DXADJ(PQA(I),IPQA(I),IERROR) + IF (IERROR.NE.0) RETURN + 225 IF(NU2-NU1.GT..5D0) GO TO 230 + PROD=(DMU-NU)*PROD*(-DMU-NU-1.D0) + CALL DXADJ(PROD,IPROD,IERROR) + IF (IERROR.NE.0) RETURN + MU=MU+1 + DMU=DMU+1.D0 + GO TO 240 + 230 PROD=PROD*(-DMU-NU-1.D0)/(DMU-NU-1.D0) + CALL DXADJ(PROD,IPROD,IERROR) + IF (IERROR.NE.0) RETURN + NU=NU+1.D0 + 240 CONTINUE + RETURN + END +*DECK DXPNRM + SUBROUTINE DXPNRM (NU1, NU2, MU1, MU2, PQA, IPQA, IERROR) +C***BEGIN PROLOGUE DXPNRM +C***SUBSIDIARY +C***PURPOSE To compute the values of Legendre functions for DXLEGF. +C This subroutine transforms an array of Legendre functions +C of the first kind of negative order stored in array PQA +C into normalized Legendre polynomials stored in array PQA. +C The original array is destroyed. +C***LIBRARY SLATEC +C***CATEGORY C3A2, C9 +C***TYPE DOUBLE PRECISION (XPNRM-S, DXPNRM-D) +C***KEYWORDS LEGENDRE FUNCTIONS +C***AUTHOR Smith, John M., (NBS and George Mason University) +C***ROUTINES CALLED DXADJ +C***REVISION HISTORY (YYMMDD) +C 820728 DATE WRITTEN +C 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) +C 901019 Revisions to prologue. (DWL and WRB) +C 901106 Changed all specific intrinsics to generic. (WRB) +C Corrected order of sections in prologue and added TYPE +C section. (WRB) +C 920127 Revised PURPOSE section of prologue. (DWL) +C***END PROLOGUE DXPNRM + DOUBLE PRECISION C1,DMU,NU,NU1,NU2,PQA,PROD + DIMENSION PQA(*),IPQA(*) +C***FIRST EXECUTABLE STATEMENT DXPNRM + IERROR=0 + L=(MU2-MU1)+(NU2-NU1+1.5D0) + MU=MU1 + DMU=MU1 + NU=NU1 +C +C IF MU .GT.NU, NORM P =0. +C + J=1 + 500 IF(DMU.LE.NU) GO TO 505 + PQA(J)=0.D0 + IPQA(J)=0 + J=J+1 + IF(J.GT.L) RETURN +C +C INCREMENT EITHER MU OR NU AS APPROPRIATE. +C + IF(MU2.GT.MU1) DMU=DMU+1.D0 + IF(NU2-NU1.GT..5D0) NU=NU+1.D0 + GO TO 500 +C +C TRANSFORM P(-MU,NU,X) INTO NORMALIZED P(MU,NU,X) USING +C NORM P(MU,NU,X)= +C SQRT((NU+.5)*FACTORIAL(NU+MU)/FACTORIAL(NU-MU)) +C *P(-MU,NU,X) +C + 505 PROD=1.D0 + IPROD=0 + K=2*MU + IF(K.LE.0) GO TO 520 + DO 510 I=1,K + PROD=PROD*SQRT(NU+DMU+1.D0-I) + 510 CALL DXADJ(PROD,IPROD,IERROR) + IF (IERROR.NE.0) RETURN + 520 DO 540 I=J,L + C1=PROD*SQRT(NU+.5D0) + PQA(I)=PQA(I)*C1 + IPQA(I)=IPQA(I)+IPROD + CALL DXADJ(PQA(I),IPQA(I),IERROR) + IF (IERROR.NE.0) RETURN + IF(NU2-NU1.GT..5D0) GO TO 530 + IF(DMU.GE.NU) GO TO 525 + PROD=SQRT(NU+DMU+1.D0)*PROD + IF(NU.GT.DMU) PROD=PROD*SQRT(NU-DMU) + CALL DXADJ(PROD,IPROD,IERROR) + IF (IERROR.NE.0) RETURN + MU=MU+1 + DMU=DMU+1.D0 + GO TO 540 + 525 PROD=0.D0 + IPROD=0 + MU=MU+1 + DMU=DMU+1.D0 + GO TO 540 + 530 PROD=SQRT(NU+DMU+1.D0)*PROD + IF(NU.NE.DMU-1.D0) PROD=PROD/SQRT(NU-DMU+1.D0) + CALL DXADJ(PROD,IPROD,IERROR) + IF (IERROR.NE.0) RETURN + NU=NU+1.D0 + 540 CONTINUE + RETURN + END +*DECK DXPQNU + SUBROUTINE DXPQNU (NU1, NU2, MU, X, SX, ID, PQA, IPQA, IERROR) +C***BEGIN PROLOGUE DXPQNU +C***SUBSIDIARY +C***PURPOSE To compute the values of Legendre functions for DXLEGF. +C This subroutine calculates initial values of P or Q using +C power series, then performs forward nu-wise recurrence to +C obtain P(-MU,NU,X), Q(0,NU,X), or Q(1,NU,X). The nu-wise +C recurrence is stable for P for all mu and for Q for mu=0,1. +C***LIBRARY SLATEC +C***CATEGORY C3A2, C9 +C***TYPE DOUBLE PRECISION (XPQNU-S, DXPQNU-D) +C***KEYWORDS LEGENDRE FUNCTIONS +C***AUTHOR Smith, John M., (NBS and George Mason University) +C***ROUTINES CALLED DXADD, DXADJ, DXPSI +C***COMMON BLOCKS DXBLK1 +C***REVISION HISTORY (YYMMDD) +C 820728 DATE WRITTEN +C 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) +C 901019 Revisions to prologue. (DWL and WRB) +C 901106 Changed all specific intrinsics to generic. (WRB) +C Corrected order of sections in prologue and added TYPE +C section. (WRB) +C 920127 Revised PURPOSE section of prologue. (DWL) +C***END PROLOGUE DXPQNU + DOUBLE PRECISION A,NU,NU1,NU2,PQ,PQA,DXPSI,R,W,X,X1,X2,SX,XS, + 1 Y,Z + DOUBLE PRECISION DI,DMU,PQ1,PQ2,FACTMU,FLOK + DIMENSION PQA(*),IPQA(*) + COMMON /DXBLK1/ NBITSF + SAVE /DXBLK1/ +C +C J0, IPSIK, AND IPSIX ARE INITIALIZED IN THIS SUBROUTINE. +C J0 IS THE NUMBER OF TERMS USED IN SERIES EXPANSION +C IN SUBROUTINE DXPQNU. +C IPSIK, IPSIX ARE VALUES OF K AND X RESPECTIVELY +C USED IN THE CALCULATION OF THE DXPSI FUNCTION. +C +C***FIRST EXECUTABLE STATEMENT DXPQNU + IERROR=0 + J0=NBITSF + IPSIK=1+(NBITSF/10) + IPSIX=5*IPSIK + IPQ=0 +C FIND NU IN INTERVAL [-.5,.5) IF ID=2 ( CALCULATION OF Q ) + NU=MOD(NU1,1.D0) + IF(NU.GE..5D0) NU=NU-1.D0 +C FIND NU IN INTERVAL (-1.5,-.5] IF ID=1,3, OR 4 ( CALC. OF P ) + IF(ID.NE.2.AND.NU.GT.-.5D0) NU=NU-1.D0 +C CALCULATE MU FACTORIAL + K=MU + DMU=MU + IF(MU.LE.0) GO TO 60 + FACTMU=1.D0 + IF=0 + DO 50 I=1,K + FACTMU=FACTMU*I + 50 CALL DXADJ(FACTMU,IF,IERROR) + IF (IERROR.NE.0) RETURN + 60 IF(K.EQ.0) FACTMU=1.D0 + IF(K.EQ.0) IF=0 +C +C X=COS(THETA) +C Y=SIN(THETA/2)**2=(1-X)/2=.5-.5*X +C R=TAN(THETA/2)=SQRT((1-X)/(1+X) +C + Y=0.5d0*(1.d0-X) + R=sqrt((1.d0-X)/(1.d0+X)) +C +C USE ASCENDING SERIES TO CALCULATE TWO VALUES OF P OR Q +C FOR USE AS STARTING VALUES IN RECURRENCE RELATION. +C + PQ2=0.0D0 + DO 100 J=1,2 + IPQ1=0 + IF(ID.EQ.2) GO TO 80 +C +C SERIES FOR P ( ID = 1, 3, OR 4 ) +C P(-MU,NU,X)=1./FACTORIAL(MU)*SQRT(((1.-X)/(1.+X))**MU) +C *SUM(FROM 0 TO J0-1)A(J)*(.5-.5*X)**J +C + IPQ=0 + PQ=1.D0 + A=1.D0 + IA=0 + DO 65 I=2,J0 + DI=I + A=A*Y*(DI-2.D0-NU)*(DI-1.D0+NU)/((DI-1.D0+DMU)*(DI-1.D0)) + CALL DXADJ(A,IA,IERROR) + IF (IERROR.NE.0) RETURN + IF(A.EQ.0.D0) GO TO 66 + CALL DXADD(PQ,IPQ,A,IA,PQ,IPQ,IERROR) + IF (IERROR.NE.0) RETURN + 65 CONTINUE + 66 CONTINUE + IF(MU.LE.0) GO TO 90 + X2=R + X1=PQ + K=MU + DO 77 I=1,K + X1=X1*X2 + 77 CALL DXADJ(X1,IPQ,IERROR) + IF (IERROR.NE.0) RETURN + PQ=X1/FACTMU + IPQ=IPQ-IF + CALL DXADJ(PQ,IPQ,IERROR) + IF (IERROR.NE.0) RETURN + GO TO 90 +C +C Z=-LN(R)=.5*LN((1+X)/(1-X)) +C + 80 Z=-LOG(R) + W=DXPSI(NU+1.D0,IPSIK,IPSIX) + XS = SX ! pour le cas ou XS serait modifie par la suite +* XS=1.D0/SIN(THETA) +C +C SERIES SUMMATION FOR Q ( ID = 2 ) +C Q(0,NU,X)=SUM(FROM 0 TO J0-1)((.5*LN((1+X)/(1-X)) +C +DXPSI(J+1,IPSIK,IPSIX)-DXPSI(NU+1,IPSIK,IPSIX)))*A(J)*(.5-.5*X)**J +C +C Q(1,NU,X)=-SQRT(1./(1.-X**2))+SQRT((1-X)/(1+X)) +C *SUM(FROM 0 T0 J0-1)(-NU*(NU+1)/2*LN((1+X)/(1-X)) +C +(J-NU)*(J+NU+1)/(2*(J+1))+NU*(NU+1)* +C (DXPSI(NU+1,IPSIK,IPSIX)-DXPSI(J+1,IPSIK,IPSIX))*A(J)*(.5-.5*X)**J +C +C NOTE, IN THIS LOOP K=J+1 +C + PQ=0.D0 + IPQ=0 + IA=0 + A=1.D0 + DO 85 K=1,J0 + FLOK=K + IF(K.EQ.1) GO TO 81 + A=A*Y*(FLOK-2.D0-NU)*(FLOK-1.D0+NU)/((FLOK-1.D0+DMU)*(FLOK-1.D0)) + CALL DXADJ(A,IA,IERROR) + IF (IERROR.NE.0) RETURN + 81 CONTINUE + IF(MU.GE.1) GO TO 83 + X1=(DXPSI(FLOK,IPSIK,IPSIX)-W+Z)*A + IX1=IA + CALL DXADD(PQ,IPQ,X1,IX1,PQ,IPQ,IERROR) + IF (IERROR.NE.0) RETURN + GO TO 85 + 83 X1=(NU*(NU+1.D0)*(Z-W+DXPSI(FLOK,IPSIK,IPSIX))+(NU-FLOK+1.D0) + 1 *(NU+FLOK)/(2.D0*FLOK))*A + IX1=IA + CALL DXADD(PQ,IPQ,X1,IX1,PQ,IPQ,IERROR) + IF (IERROR.NE.0) RETURN + 85 CONTINUE + IF(MU.GE.1) PQ=-R*PQ + IXS=0 + IF(MU.GE.1) CALL DXADD(PQ,IPQ,-XS,IXS,PQ,IPQ,IERROR) + IF (IERROR.NE.0) RETURN + IF(J.EQ.2) MU=-MU + IF(J.EQ.2) DMU=-DMU + 90 IF(J.EQ.1) PQ2=PQ + IF(J.EQ.1) IPQ2=IPQ + NU=NU+1.D0 + 100 CONTINUE + K=0 + IF(NU-1.5D0.LT.NU1) GO TO 120 + K=K+1 + PQA(K)=PQ2 + IPQA(K)=IPQ2 + IF(NU.GT.NU2+.5D0) RETURN + 120 PQ1=PQ + IPQ1=IPQ + IF(NU.LT.NU1+.5D0) GO TO 130 + K=K+1 + PQA(K)=PQ + IPQA(K)=IPQ + IF(NU.GT.NU2+.5D0) RETURN +C +C FORWARD NU-WISE RECURRENCE FOR F(MU,NU,X) FOR FIXED MU +C USING +C (NU+MU+1)*F(MU,NU,X)=(2.*NU+1)*F(MU,NU,X)-(NU-MU)*F(MU,NU-1,X) +C WHERE F(MU,NU,X) MAY BE P(-MU,NU,X) OR IF MU IS REPLACED +C BY -MU THEN F(MU,NU,X) MAY BE Q(MU,NU,X). +C NOTE, IN THIS LOOP, NU=NU+1 +C + 130 X1=(2.D0*NU-1.D0)/(NU+DMU)*X*PQ1 + X2=(NU-1.D0-DMU)/(NU+DMU)*PQ2 + CALL DXADD(X1,IPQ1,-X2,IPQ2,PQ,IPQ,IERROR) + IF (IERROR.NE.0) RETURN + CALL DXADJ(PQ,IPQ,IERROR) + IF (IERROR.NE.0) RETURN + NU=NU+1.D0 + PQ2=PQ1 + IPQ2=IPQ1 + GO TO 120 +C + END +*DECK DXPSI + DOUBLE PRECISION FUNCTION DXPSI (A, IPSIK, IPSIX) +C***BEGIN PROLOGUE DXPSI +C***SUBSIDIARY +C***PURPOSE To compute values of the Psi function for DXLEGF. +C***LIBRARY SLATEC +C***CATEGORY C7C +C***TYPE DOUBLE PRECISION (XPSI-S, DXPSI-D) +C***KEYWORDS PSI FUNCTION +C***AUTHOR Smith, John M., (NBS and George Mason University) +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 820728 DATE WRITTEN +C 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) +C 901019 Revisions to prologue. (DWL and WRB) +C 901106 Changed all specific intrinsics to generic. (WRB) +C Corrected order of sections in prologue and added TYPE +C section. (WRB) +C 920127 Revised PURPOSE section of prologue. (DWL) +C***END PROLOGUE DXPSI + DOUBLE PRECISION A,B,C,CNUM,CDENOM + DIMENSION CNUM(12),CDENOM(12) + SAVE CNUM, CDENOM +C +C CNUM(I) AND CDENOM(I) ARE THE ( REDUCED ) NUMERATOR +C AND 2*I*DENOMINATOR RESPECTIVELY OF THE 2*I TH BERNOULLI +C NUMBER. +C + DATA CNUM(1),CNUM(2),CNUM(3),CNUM(4),CNUM(5),CNUM(6),CNUM(7), + 1CNUM(8),CNUM(9),CNUM(10),CNUM(11),CNUM(12) + 2 / 1.D0, -1.D0, 1.D0, -1.D0, 1.D0, + 3 -691.D0, 1.D0, -3617.D0, 43867.D0, -174611.D0, 77683.D0, + 4 -236364091.D0/ + DATA CDENOM(1),CDENOM(2),CDENOM(3),CDENOM(4),CDENOM(5),CDENOM(6), + 1 CDENOM(7),CDENOM(8),CDENOM(9),CDENOM(10),CDENOM(11),CDENOM(12) + 2/12.D0,120.D0, 252.D0, 240.D0,132.D0, + 3 32760.D0, 12.D0, 8160.D0, 14364.D0, 6600.D0, 276.D0, 65520.D0/ +C***FIRST EXECUTABLE STATEMENT DXPSI + N=MAX(0,IPSIX-INT(A)) + B=N+A + K1=IPSIK-1 +C +C SERIES EXPANSION FOR A .GT. IPSIX USING IPSIK-1 TERMS. +C + C=0.D0 + DO 12 I=1,K1 + K=IPSIK-I + 12 C=(C+CNUM(K)/CDENOM(K))/B**2 + DXPSI=LOG(B)-(C+.5D0/B) + IF(N.EQ.0) GO TO 20 + B=0.D0 +C +C RECURRENCE FOR A .LE. IPSIX. +C + DO 15 M=1,N + 15 B=B+1.D0/(N-M+A) + DXPSI=DXPSI-B + 20 RETURN + END +*DECK DXQMU + SUBROUTINE DXQMU (NU1, NU2, MU1, MU2, X, SX, ID, PQA, IPQA, + 1 IERROR) +C***BEGIN PROLOGUE DXQMU +C***SUBSIDIARY +C***PURPOSE To compute the values of Legendre functions for DXLEGF. +C Method: forward mu-wise recurrence for Q(MU,NU,X) for fixed +C nu to obtain Q(MU1,NU,X), Q(MU1+1,NU,X), ..., Q(MU2,NU,X). +C***LIBRARY SLATEC +C***CATEGORY C3A2, C9 +C***TYPE DOUBLE PRECISION (XQMU-S, DXQMU-D) +C***KEYWORDS LEGENDRE FUNCTIONS +C***AUTHOR Smith, John M., (NBS and George Mason University) +C***ROUTINES CALLED DXADD, DXADJ, DXPQNU +C***REVISION HISTORY (YYMMDD) +C 820728 DATE WRITTEN +C 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) +C 901019 Revisions to prologue. (DWL and WRB) +C 901106 Corrected order of sections in prologue and added TYPE +C section. (WRB) +C 920127 Revised PURPOSE section of prologue. (DWL) +C***END PROLOGUE DXQMU + DIMENSION PQA(*),IPQA(*) + DOUBLE PRECISION DMU,NU,NU1,NU2,PQ,PQA,PQ1,PQ2,SX,X,X1,X2 +C***FIRST EXECUTABLE STATEMENT DXQMU + IERROR=0 + MU=0 +C +C CALL DXPQNU TO OBTAIN Q(0.,NU1,X) +C + CALL DXPQNU(NU1,NU2,MU,X,SX,ID,PQA,IPQA,IERROR) + IF (IERROR.NE.0) RETURN + PQ2=PQA(1) + IPQ2=IPQA(1) + MU=1 +C +C CALL DXPQNU TO OBTAIN Q(1.,NU1,X) +C + CALL DXPQNU(NU1,NU2,MU,X,SX,ID,PQA,IPQA,IERROR) + IF (IERROR.NE.0) RETURN + NU=NU1 + K=0 + MU=1 + DMU=1.D0 + PQ1=PQA(1) + IPQ1=IPQA(1) + IF(MU1.GT.0) GO TO 310 + K=K+1 + PQA(K)=PQ2 + IPQA(K)=IPQ2 + IF(MU2.LT.1) GO TO 330 + 310 IF(MU1.GT.1) GO TO 320 + K=K+1 + PQA(K)=PQ1 + IPQA(K)=IPQ1 + IF(MU2.LE.1) GO TO 330 + 320 CONTINUE +C +C FORWARD RECURRENCE IN MU TO OBTAIN +C Q(MU1,NU,X),Q(MU1+1,NU,X),....,Q(MU2,NU,X) USING +C Q(MU+1,NU,X)=-2.*MU*X*SQRT(1./(1.-X**2))*Q(MU,NU,X) +C -(NU+MU)*(NU-MU+1.)*Q(MU-1,NU,X) +C + X1=-2.D0*DMU*X*SX*PQ1 + X2=(NU+DMU)*(NU-DMU+1.D0)*PQ2 + CALL DXADD(X1,IPQ1,-X2,IPQ2,PQ,IPQ,IERROR) + IF (IERROR.NE.0) RETURN + CALL DXADJ(PQ,IPQ,IERROR) + IF (IERROR.NE.0) RETURN + PQ2=PQ1 + IPQ2=IPQ1 + PQ1=PQ + IPQ1=IPQ + MU=MU+1 + DMU=DMU+1.D0 + IF(MU.LT.MU1) GO TO 320 + K=K+1 + PQA(K)=PQ + IPQA(K)=IPQ + IF(MU2.GT.MU) GO TO 320 + 330 RETURN + END +*DECK DXQNU + SUBROUTINE DXQNU (NU1, NU2, MU1, X, SX, ID, PQA, IPQA, + 1 IERROR) +C***BEGIN PROLOGUE DXQNU +C***SUBSIDIARY +C***PURPOSE To compute the values of Legendre functions for DXLEGF. +C Method: backward nu-wise recurrence for Q(MU,NU,X) for +C fixed mu to obtain Q(MU1,NU1,X), Q(MU1,NU1+1,X), ..., +C Q(MU1,NU2,X). +C***LIBRARY SLATEC +C***CATEGORY C3A2, C9 +C***TYPE DOUBLE PRECISION (XQNU-S, DXQNU-D) +C***KEYWORDS LEGENDRE FUNCTIONS +C***AUTHOR Smith, John M., (NBS and George Mason University) +C***ROUTINES CALLED DXADD, DXADJ, DXPQNU +C***REVISION HISTORY (YYMMDD) +C 820728 DATE WRITTEN +C 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) +C 901019 Revisions to prologue. (DWL and WRB) +C 901106 Corrected order of sections in prologue and added TYPE +C section. (WRB) +C 920127 Revised PURPOSE section of prologue. (DWL) +C***END PROLOGUE DXQNU + DIMENSION PQA(*),IPQA(*) + DOUBLE PRECISION DMU,NU,NU1,NU2,PQ,PQA,PQ1,PQ2,SX,X,X1,X2 + DOUBLE PRECISION PQL1,PQL2 +C***FIRST EXECUTABLE STATEMENT DXQNU + IERROR=0 + K=0 + PQ2=0.0D0 + IPQ2=0 + PQL2=0.0D0 + IPQL2=0 + IF(MU1.EQ.1) GO TO 290 + MU=0 +C +C CALL DXPQNU TO OBTAIN Q(0.,NU2,X) AND Q(0.,NU2-1,X) +C + CALL DXPQNU(NU1,NU2,MU,X,SX,ID,PQA,IPQA,IERROR) + IF (IERROR.NE.0) RETURN + IF(MU1.EQ.0) RETURN + K=(NU2-NU1+1.5D0) + PQ2=PQA(K) + IPQ2=IPQA(K) + PQL2=PQA(K-1) + IPQL2=IPQA(K-1) + 290 MU=1 +C +C CALL DXPQNU TO OBTAIN Q(1.,NU2,X) AND Q(1.,NU2-1,X) +C + CALL DXPQNU(NU1,NU2,MU,X,SX,ID,PQA,IPQA,IERROR) + IF (IERROR.NE.0) RETURN + IF(MU1.EQ.1) RETURN + NU=NU2 + PQ1=PQA(K) + IPQ1=IPQA(K) + PQL1=PQA(K-1) + IPQL1=IPQA(K-1) + 300 MU=1 + DMU=1.D0 + 320 CONTINUE +C +C FORWARD RECURRENCE IN MU TO OBTAIN Q(MU1,NU2,X) AND +C Q(MU1,NU2-1,X) USING +C Q(MU+1,NU,X)=-2.*MU*X*SQRT(1./(1.-X**2))*Q(MU,NU,X) +C -(NU+MU)*(NU-MU+1.)*Q(MU-1,NU,X) +C +C FIRST FOR NU=NU2 +C + X1=-2.D0*DMU*X*SX*PQ1 + X2=(NU+DMU)*(NU-DMU+1.D0)*PQ2 + CALL DXADD(X1,IPQ1,-X2,IPQ2,PQ,IPQ,IERROR) + IF (IERROR.NE.0) RETURN + CALL DXADJ(PQ,IPQ,IERROR) + IF (IERROR.NE.0) RETURN + PQ2=PQ1 + IPQ2=IPQ1 + PQ1=PQ + IPQ1=IPQ + MU=MU+1 + DMU=DMU+1.D0 + IF(MU.LT.MU1) GO TO 320 + PQA(K)=PQ + IPQA(K)=IPQ + IF(K.EQ.1) RETURN + IF(NU.LT.NU2) GO TO 340 +C +C THEN FOR NU=NU2-1 +C + NU=NU-1.D0 + PQ2=PQL2 + IPQ2=IPQL2 + PQ1=PQL1 + IPQ1=IPQL1 + K=K-1 + GO TO 300 +C +C BACKWARD RECURRENCE IN NU TO OBTAIN +C Q(MU1,NU1,X),Q(MU1,NU1+1,X),....,Q(MU1,NU2,X) +C USING +C (NU-MU+1.)*Q(MU,NU+1,X)= +C (2.*NU+1.)*X*Q(MU,NU,X)-(NU+MU)*Q(MU,NU-1,X) +C + 340 PQ1=PQA(K) + IPQ1=IPQA(K) + PQ2=PQA(K+1) + IPQ2=IPQA(K+1) + 350 IF(NU.LE.NU1) RETURN + K=K-1 + X1=(2.D0*NU+1.D0)*X*PQ1/(NU+DMU) + X2=-(NU-DMU+1.D0)*PQ2/(NU+DMU) + CALL DXADD(X1,IPQ1,X2,IPQ2,PQ,IPQ,IERROR) + IF (IERROR.NE.0) RETURN + CALL DXADJ(PQ,IPQ,IERROR) + IF (IERROR.NE.0) RETURN + PQ2=PQ1 + IPQ2=IPQ1 + PQ1=PQ + IPQ1=IPQ + PQA(K)=PQ + IPQA(K)=IPQ + NU=NU-1.D0 + GO TO 350 + END +*DECK DXRED + SUBROUTINE DXRED (X, IX, IERROR) +C***BEGIN PROLOGUE DXRED +C***PURPOSE To provide double-precision floating-point arithmetic +C with an extended exponent range. +C***LIBRARY SLATEC +C***CATEGORY A3D +C***TYPE DOUBLE PRECISION (XRED-S, DXRED-D) +C***KEYWORDS EXTENDED-RANGE DOUBLE-PRECISION ARITHMETIC +C***AUTHOR Lozier, Daniel W., (National Bureau of Standards) +C Smith, John M., (NBS and George Mason University) +C***DESCRIPTION +C DOUBLE PRECISION X +C INTEGER IX +C +C IF +C RADIX**(-2L) .LE. (ABS(X),IX) .LE. RADIX**(2L) +C THEN DXRED TRANSFORMS (X,IX) SO THAT IX=0. +C IF (X,IX) IS OUTSIDE THE ABOVE RANGE, +C THEN DXRED TAKES NO ACTION. +C THIS SUBROUTINE IS USEFUL IF THE +C RESULTS OF EXTENDED-RANGE CALCULATIONS +C ARE TO BE USED IN SUBSEQUENT ORDINARY +C DOUBLE-PRECISION CALCULATIONS. +C +C***SEE ALSO DXSET +C***REFERENCES (NONE) +C***ROUTINES CALLED (NONE) +C***COMMON BLOCKS DXBLK2 +C***REVISION HISTORY (YYMMDD) +C 820712 DATE WRITTEN +C 881020 Revised to meet SLATEC CML recommendations. (DWL and JMS) +C 901019 Revisions to prologue. (DWL and WRB) +C 901106 Changed all specific intrinsics to generic. (WRB) +C Corrected order of sections in prologue and added TYPE +C section. (WRB) +C 920127 Revised PURPOSE section of prologue. (DWL) +C***END PROLOGUE DXRED + DOUBLE PRECISION X + INTEGER IX + DOUBLE PRECISION RADIX, RADIXL, RAD2L, DLG10R, XA + INTEGER L, L2, KMAX + COMMON /DXBLK2/ RADIX, RADIXL, RAD2L, DLG10R, L, L2, KMAX + SAVE /DXBLK2/ +C +C***FIRST EXECUTABLE STATEMENT DXRED + IERROR=0 + IF (X.EQ.0.0D0) GO TO 90 + XA = ABS(X) + IF (IX.EQ.0) GO TO 70 + IXA = ABS(IX) + IXA1 = IXA/L2 + IXA2 = MOD(IXA,L2) + IF (IX.GT.0) GO TO 40 + 10 CONTINUE + IF (XA.GT.1.0D0) GO TO 20 + XA = XA*RAD2L + IXA1 = IXA1 + 1 + GO TO 10 + 20 XA = XA/RADIX**IXA2 + IF (IXA1.EQ.0) GO TO 70 + DO 30 I=1,IXA1 + IF (XA.LT.1.0D0) GO TO 100 + XA = XA/RAD2L + 30 CONTINUE + GO TO 70 +C + 40 CONTINUE + IF (XA.LT.1.0D0) GO TO 50 + XA = XA/RAD2L + IXA1 = IXA1 + 1 + GO TO 40 + 50 XA = XA*RADIX**IXA2 + IF (IXA1.EQ.0) GO TO 70 + DO 60 I=1,IXA1 + IF (XA.GT.1.0D0) GO TO 100 + XA = XA*RAD2L + 60 CONTINUE + 70 IF (XA.GT.RAD2L) GO TO 100 + IF (XA.GT.1.0D0) GO TO 80 + IF (RAD2L*XA.LT.1.0D0) GO TO 100 + 80 X = SIGN(XA,X) + 90 IX = 0 + 100 RETURN + END +*DECK DXSET + SUBROUTINE DXSET (IRAD, NRADPL, DZERO, NBITS, IERROR) +C***BEGIN PROLOGUE DXSET +C***PURPOSE To provide double-precision floating-point arithmetic +C with an extended exponent range. +C***LIBRARY SLATEC +C***CATEGORY A3D +C***TYPE DOUBLE PRECISION (XSET-S, DXSET-D) +C***KEYWORDS EXTENDED-RANGE DOUBLE-PRECISION ARITHMETIC +C***AUTHOR Lozier, Daniel W., (National Bureau of Standards) +C Smith, John M., (NBS and George Mason University) +C***DESCRIPTION +C +C SUBROUTINE DXSET MUST BE CALLED PRIOR TO CALLING ANY OTHER +C EXTENDED-RANGE SUBROUTINE. IT CALCULATES AND STORES SEVERAL +C MACHINE-DEPENDENT CONSTANTS IN COMMON BLOCKS. THE USER MUST +C SUPPLY FOUR CONSTANTS THAT PERTAIN TO HIS PARTICULAR COMPUTER. +C THE CONSTANTS ARE +C +C IRAD = THE INTERNAL BASE OF DOUBLE-PRECISION +C ARITHMETIC IN THE COMPUTER. +C NRADPL = THE NUMBER OF RADIX PLACES CARRIED IN +C THE DOUBLE-PRECISION REPRESENTATION. +C DZERO = THE SMALLEST OF 1/DMIN, DMAX, DMAXLN WHERE +C DMIN = THE SMALLEST POSITIVE DOUBLE-PRECISION +C NUMBER OR AN UPPER BOUND TO THIS NUMBER, +C DMAX = THE LARGEST DOUBLE-PRECISION NUMBER +C OR A LOWER BOUND TO THIS NUMBER, +C DMAXLN = THE LARGEST DOUBLE-PRECISION NUMBER +C SUCH THAT LOG10(DMAXLN) CAN BE COMPUTED BY THE +C FORTRAN SYSTEM (ON MOST SYSTEMS DMAXLN = DMAX). +C NBITS = THE NUMBER OF BITS (EXCLUSIVE OF SIGN) IN +C AN INTEGER COMPUTER WORD. +C +C ALTERNATIVELY, ANY OR ALL OF THE CONSTANTS CAN BE GIVEN +C THE VALUE 0 (0.0D0 FOR DZERO). IF A CONSTANT IS ZERO, DXSET TRIES +C TO ASSIGN AN APPROPRIATE VALUE BY CALLING I1MACH +C (SEE P.A.FOX, A.D.HALL, N.L.SCHRYER, ALGORITHM 528 FRAMEWORK +C FOR A PORTABLE LIBRARY, ACM TRANSACTIONS ON MATH SOFTWARE, +C V.4, NO.2, JUNE 1978, 177-188). +C +C THIS IS THE SETTING-UP SUBROUTINE FOR A PACKAGE OF SUBROUTINES +C THAT FACILITATE THE USE OF EXTENDED-RANGE ARITHMETIC. EXTENDED-RANGE +C ARITHMETIC ON A PARTICULAR COMPUTER IS DEFINED ON THE SET OF NUMBERS +C OF THE FORM +C +C (X,IX) = X*RADIX**IX +C +C WHERE X IS A DOUBLE-PRECISION NUMBER CALLED THE PRINCIPAL PART, +C IX IS AN INTEGER CALLED THE AUXILIARY INDEX, AND RADIX IS THE +C INTERNAL BASE OF THE DOUBLE-PRECISION ARITHMETIC. OBVIOUSLY, +C EACH REAL NUMBER IS REPRESENTABLE WITHOUT ERROR BY MORE THAN ONE +C EXTENDED-RANGE FORM. CONVERSIONS BETWEEN DIFFERENT FORMS ARE +C ESSENTIAL IN CARRYING OUT ARITHMETIC OPERATIONS. WITH THE CHOICE +C OF RADIX WE HAVE MADE, AND THE SUBROUTINES WE HAVE WRITTEN, THESE +C CONVERSIONS ARE PERFORMED WITHOUT ERROR (AT LEAST ON MOST COMPUTERS). +C (SEE SMITH, J.M., OLVER, F.W.J., AND LOZIER, D.W., EXTENDED-RANGE +C ARITHMETIC AND NORMALIZED LEGENDRE POLYNOMIALS, ACM TRANSACTIONS ON +C MATHEMATICAL SOFTWARE, MARCH 1981). +C +C AN EXTENDED-RANGE NUMBER (X,IX) IS SAID TO BE IN ADJUSTED FORM IF +C X AND IX ARE ZERO OR +C +C RADIX**(-L) .LE. ABS(X) .LT. RADIX**L +C +C IS SATISFIED, WHERE L IS A COMPUTER-DEPENDENT INTEGER DEFINED IN THIS +C SUBROUTINE. TWO EXTENDED-RANGE NUMBERS IN ADJUSTED FORM CAN BE ADDED, +C SUBTRACTED, MULTIPLIED OR DIVIDED (IF THE DIVISOR IS NONZERO) WITHOUT +C CAUSING OVERFLOW OR UNDERFLOW IN THE PRINCIPAL PART OF THE RESULT. +C WITH PROPER USE OF THE EXTENDED-RANGE SUBROUTINES, THE ONLY OVERFLOW +C THAT CAN OCCUR IS INTEGER OVERFLOW IN THE AUXILIARY INDEX. IF THIS +C IS DETECTED, THE SOFTWARE CALLS XERROR (A GENERAL ERROR-HANDLING +C FORTRAN SUBROUTINE PACKAGE). +C +C MULTIPLICATION AND DIVISION IS PERFORMED BY SETTING +C +C (X,IX)*(Y,IY) = (X*Y,IX+IY) +C OR +C (X,IX)/(Y,IY) = (X/Y,IX-IY). +C +C PRE-ADJUSTMENT OF THE OPERANDS IS ESSENTIAL TO AVOID +C OVERFLOW OR UNDERFLOW OF THE PRINCIPAL PART. SUBROUTINE +C DXADJ (SEE BELOW) MAY BE CALLED TO TRANSFORM ANY EXTENDED- +C RANGE NUMBER INTO ADJUSTED FORM. +C +C ADDITION AND SUBTRACTION REQUIRE THE USE OF SUBROUTINE DXADD +C (SEE BELOW). THE INPUT OPERANDS NEED NOT BE IN ADJUSTED FORM. +C HOWEVER, THE RESULT OF ADDITION OR SUBTRACTION IS RETURNED +C IN ADJUSTED FORM. THUS, FOR EXAMPLE, IF (X,IX),(Y,IY), +C (U,IU), AND (V,IV) ARE IN ADJUSTED FORM, THEN +C +C (X,IX)*(Y,IY) + (U,IU)*(V,IV) +C +C CAN BE COMPUTED AND STORED IN ADJUSTED FORM WITH NO EXPLICIT +C CALLS TO DXADJ. +C +C WHEN AN EXTENDED-RANGE NUMBER IS TO BE PRINTED, IT MUST BE +C CONVERTED TO AN EXTENDED-RANGE FORM WITH DECIMAL RADIX. SUBROUTINE +C DXCON IS PROVIDED FOR THIS PURPOSE. +C +C THE SUBROUTINES CONTAINED IN THIS PACKAGE ARE +C +C SUBROUTINE DXADD +C USAGE +C CALL DXADD(X,IX,Y,IY,Z,IZ,IERROR) +C IF (IERROR.NE.0) RETURN +C DESCRIPTION +C FORMS THE EXTENDED-RANGE SUM (Z,IZ) = +C (X,IX) + (Y,IY). (Z,IZ) IS ADJUSTED +C BEFORE RETURNING. THE INPUT OPERANDS +C NEED NOT BE IN ADJUSTED FORM, BUT THEIR +C PRINCIPAL PARTS MUST SATISFY +C RADIX**(-2L).LE.ABS(X).LE.RADIX**(2L), +C RADIX**(-2L).LE.ABS(Y).LE.RADIX**(2L). +C +C SUBROUTINE DXADJ +C USAGE +C CALL DXADJ(X,IX,IERROR) +C IF (IERROR.NE.0) RETURN +C DESCRIPTION +C TRANSFORMS (X,IX) SO THAT +C RADIX**(-L) .LE. ABS(X) .LT. RADIX**L. +C ON MOST COMPUTERS THIS TRANSFORMATION DOES +C NOT CHANGE THE MANTISSA OF X PROVIDED RADIX IS +C THE NUMBER BASE OF DOUBLE-PRECISION ARITHMETIC. +C +C SUBROUTINE DXC210 +C USAGE +C CALL DXC210(K,Z,J,IERROR) +C IF (IERROR.NE.0) RETURN +C DESCRIPTION +C GIVEN K THIS SUBROUTINE COMPUTES J AND Z +C SUCH THAT RADIX**K = Z*10**J, WHERE Z IS IN +C THE RANGE 1/10 .LE. Z .LT. 1. +C THE VALUE OF Z WILL BE ACCURATE TO FULL +C DOUBLE-PRECISION PROVIDED THE NUMBER +C OF DECIMAL PLACES IN THE LARGEST +C INTEGER PLUS THE NUMBER OF DECIMAL +C PLACES CARRIED IN DOUBLE-PRECISION DOES NOT +C EXCEED 60. DXC210 IS CALLED BY SUBROUTINE +C DXCON WHEN NECESSARY. THE USER SHOULD +C NEVER NEED TO CALL DXC210 DIRECTLY. +C +C SUBROUTINE DXCON +C USAGE +C CALL DXCON(X,IX,IERROR) +C IF (IERROR.NE.0) RETURN +C DESCRIPTION +C CONVERTS (X,IX) = X*RADIX**IX +C TO DECIMAL FORM IN PREPARATION FOR +C PRINTING, SO THAT (X,IX) = X*10**IX +C WHERE 1/10 .LE. ABS(X) .LT. 1 +C IS RETURNED, EXCEPT THAT IF +C (ABS(X),IX) IS BETWEEN RADIX**(-2L) +C AND RADIX**(2L) THEN THE REDUCED +C FORM WITH IX = 0 IS RETURNED. +C +C SUBROUTINE DXRED +C USAGE +C CALL DXRED(X,IX,IERROR) +C IF (IERROR.NE.0) RETURN +C DESCRIPTION +C IF +C RADIX**(-2L) .LE. (ABS(X),IX) .LE. RADIX**(2L) +C THEN DXRED TRANSFORMS (X,IX) SO THAT IX=0. +C IF (X,IX) IS OUTSIDE THE ABOVE RANGE, +C THEN DXRED TAKES NO ACTION. +C THIS SUBROUTINE IS USEFUL IF THE +C RESULTS OF EXTENDED-RANGE CALCULATIONS +C ARE TO BE USED IN SUBSEQUENT ORDINARY +C DOUBLE-PRECISION CALCULATIONS. +C +C***REFERENCES Smith, Olver and Lozier, Extended-Range Arithmetic and +C Normalized Legendre Polynomials, ACM Trans on Math +C Softw, v 7, n 1, March 1981, pp 93--105. +C***ROUTINES CALLED I1MACH, XERMSG +C***COMMON BLOCKS DXBLK1, DXBLK2, DXBLK3 +C***REVISION HISTORY (YYMMDD) +C 820712 DATE WRITTEN +C 881020 Revised to meet SLATEC CML recommendations. (DWL and JMS) +C 901019 Revisions to prologue. (DWL and WRB) +C 901106 Changed all specific intrinsics to generic. (WRB) +C Corrected order of sections in prologue and added TYPE +C section. (WRB) +C CALLs to XERROR changed to CALLs to XERMSG. (WRB) +C 920127 Revised PURPOSE section of prologue. (DWL) +C***END PROLOGUE DXSET + INTEGER IRAD, NRADPL, NBITS + DOUBLE PRECISION DZERO, DZEROX + COMMON /DXBLK1/ NBITSF + SAVE /DXBLK1/ + DOUBLE PRECISION RADIX, RADIXL, RAD2L, DLG10R + INTEGER L, L2, KMAX + COMMON /DXBLK2/ RADIX, RADIXL, RAD2L, DLG10R, L, L2, KMAX + SAVE /DXBLK2/ + INTEGER NLG102, MLG102, LG102 + COMMON /DXBLK3/ NLG102, MLG102, LG102(21) + SAVE /DXBLK3/ + INTEGER IFLAG + SAVE IFLAG + +* dlamch is used in place of i1mach : + double precision dlamch + external dlamch +C + DIMENSION LOG102(20), LGTEMP(20) + SAVE LOG102 +C +C LOG102 CONTAINS THE FIRST 60 DIGITS OF LOG10(2) FOR USE IN +C CONVERSION OF EXTENDED-RANGE NUMBERS TO BASE 10 . + DATA LOG102 /301,029,995,663,981,195,213,738,894,724,493,026,768, + * 189,881,462,108,541,310,428/ +C +C FOLLOWING CODING PREVENTS DXSET FROM BEING EXECUTED MORE THAN ONCE. +C THIS IS IMPORTANT BECAUSE SOME SUBROUTINES (SUCH AS DXNRMP AND +C DXLEGF) CALL DXSET TO MAKE SURE EXTENDED-RANGE ARITHMETIC HAS +C BEEN INITIALIZED. THE USER MAY WANT TO PRE-EMPT THIS CALL, FOR +C EXAMPLE WHEN I1MACH IS NOT AVAILABLE. SEE CODING BELOW. + DATA IFLAG /0/ +C***FIRST EXECUTABLE STATEMENT DXSET + IERROR=0 + IF (IFLAG .NE. 0) RETURN + IRADX = IRAD + NRDPLC = NRADPL + DZEROX = DZERO + IMINEX = 0 + IMAXEX = 0 + NBITSX = NBITS +C FOLLOWING 5 STATEMENTS SHOULD BE DELETED IF I1MACH IS +C NOT AVAILABLE OR NOT CONFIGURED TO RETURN THE CORRECT +C MACHINE-DEPENDENT VALUES. +* +* modif : use a call to dlamch in place of I1MACH + IF (IRADX .EQ. 0) IRADX = int(dlamch('b')) ! I1MACH (10) + IF (NRDPLC .EQ. 0) NRDPLC = int(dlamch('n')) ! I1MACH (14) + IF (DZEROX .EQ. 0.0D0) IMINEX = int(dlamch('m')) ! I1MACH (15) + IF (DZEROX .EQ. 0.0D0) IMAXEX = int(dlamch('l')) ! I1MACH (16) + IF (NBITSX .EQ. 0) NBITSX = 31 ! I1MACH (8) + IF (IRADX.EQ.2) GO TO 10 + IF (IRADX.EQ.4) GO TO 10 + IF (IRADX.EQ.8) GO TO 10 + IF (IRADX.EQ.16) GO TO 10 +* CALL XERMSG ('SLATEC', 'DXSET', 'IMPROPER VALUE OF IRAD', 201, 1) + IERROR=201 + RETURN + 10 CONTINUE + LOG2R=0 + IF (IRADX.EQ.2) LOG2R = 1 + IF (IRADX.EQ.4) LOG2R = 2 + IF (IRADX.EQ.8) LOG2R = 3 + IF (IRADX.EQ.16) LOG2R = 4 + NBITSF=LOG2R*NRDPLC + RADIX = IRADX + DLG10R = LOG10(RADIX) + IF (DZEROX .NE. 0.0D0) GO TO 14 + LX = MIN ((1-IMINEX)/2, (IMAXEX-1)/2) + GO TO 16 + 14 LX = 0.5D0*LOG10(DZEROX)/DLG10R +C RADIX**(2*L) SHOULD NOT OVERFLOW, BUT REDUCE L BY 1 FOR FURTHER +C PROTECTION. + LX=LX-1 + 16 L2 = 2*LX + IF (LX.GE.4) GO TO 20 +* CALL XERMSG ('SLATEC', 'DXSET', 'IMPROPER VALUE OF DZERO', 202, 1) + IERROR=202 + RETURN + 20 L = LX + RADIXL = RADIX**L + RAD2L = RADIXL**2 +C IT IS NECESSARY TO RESTRICT NBITS (OR NBITSX) TO BE LESS THAN SOME +C UPPER LIMIT BECAUSE OF BINARY-TO-DECIMAL CONVERSION. SUCH CONVERSION +C IS DONE BY DXC210 AND REQUIRES A CONSTANT THAT IS STORED TO SOME FIXED +C PRECISION. THE STORED CONSTANT (LOG102 IN THIS ROUTINE) PROVIDES +C FOR CONVERSIONS ACCURATE TO THE LAST DECIMAL DIGIT WHEN THE INTEGER +C WORD LENGTH DOES NOT EXCEED 63. A LOWER LIMIT OF 15 BITS IS IMPOSED +C BECAUSE THE SOFTWARE IS DESIGNED TO RUN ON COMPUTERS WITH INTEGER WORD +C LENGTH OF AT LEAST 16 BITS. + IF (15.LE.NBITSX .AND. NBITSX.LE.63) GO TO 30 +* CALL XERMSG ('SLATEC', 'DXSET', 'IMPROPER VALUE OF NBITS', 203, 1) + IERROR=203 + RETURN + 30 CONTINUE + KMAX = 2**(NBITSX-1) - L2 + NB = (NBITSX-1)/2 + MLG102 = 2**NB + IF (1.LE.NRDPLC*LOG2R .AND. NRDPLC*LOG2R.LE.120) GO TO 40 +* CALL XERMSG ('SLATEC', 'DXSET', 'IMPROPER VALUE OF NRADPL', 204, +* + 1) + IERROR=204 + RETURN + 40 CONTINUE + NLG102 = NRDPLC*LOG2R/NB + 3 + NP1 = NLG102 + 1 +C +C AFTER COMPLETION OF THE FOLLOWING LOOP, IC CONTAINS +C THE INTEGER PART AND LGTEMP CONTAINS THE FRACTIONAL PART +C OF LOG10(IRADX) IN RADIX 1000. + IC = 0 + DO 50 II=1,20 + I = 21 - II + IT = LOG2R*LOG102(I) + IC + IC = IT/1000 + LGTEMP(I) = MOD(IT,1000) + 50 CONTINUE +C +C AFTER COMPLETION OF THE FOLLOWING LOOP, LG102 CONTAINS +C LOG10(IRADX) IN RADIX MLG102. THE RADIX POINT IS +C BETWEEN LG102(1) AND LG102(2). + LG102(1) = IC + DO 80 I=2,NP1 + LG102X = 0 + DO 70 J=1,NB + IC = 0 + DO 60 KK=1,20 + K = 21 - KK + IT = 2*LGTEMP(K) + IC + IC = IT/1000 + LGTEMP(K) = MOD(IT,1000) + 60 CONTINUE + LG102X = 2*LG102X + IC + 70 CONTINUE + LG102(I) = LG102X + 80 CONTINUE +C +C CHECK SPECIAL CONDITIONS REQUIRED BY SUBROUTINES... + IF (NRDPLC.LT.L) GO TO 90 +* CALL XERMSG ('SLATEC', 'DXSET', 'NRADPL .GE. L', 205, 1) + IERROR=205 + RETURN + 90 IF (6*L.LE.KMAX) GO TO 100 +* CALL XERMSG ('SLATEC', 'DXSET', '6*L .GT. KMAX', 206, 1) + IERROR=206 + RETURN + 100 CONTINUE + IFLAG = 1 + RETURN + END + + SUBROUTINE DXADD (X, IX, Y, IY, Z, IZ, IERROR) +C***BEGIN PROLOGUE DXADD +C***PURPOSE To provide double-precision floating-point arithmetic +C with an extended exponent range. +C***LIBRARY SLATEC +C***CATEGORY A3D +C***TYPE DOUBLE PRECISION (XADD-S, DXADD-D) +C***KEYWORDS EXTENDED-RANGE DOUBLE-PRECISION ARITHMETIC +C***AUTHOR Lozier, Daniel W., (National Bureau of Standards) +C Smith, John M., (NBS and George Mason University) +C***DESCRIPTION +C DOUBLE PRECISION X, Y, Z +C INTEGER IX, IY, IZ +C +C FORMS THE EXTENDED-RANGE SUM (Z,IZ) = +C (X,IX) + (Y,IY). (Z,IZ) IS ADJUSTED +C BEFORE RETURNING. THE INPUT OPERANDS +C NEED NOT BE IN ADJUSTED FORM, BUT THEIR +C PRINCIPAL PARTS MUST SATISFY +C RADIX**(-2L).LE.ABS(X).LE.RADIX**(2L), +C RADIX**(-2L).LE.ABS(Y).LE.RADIX**(2L). +C +C***SEE ALSO DXSET +C***REFERENCES (NONE) +C***ROUTINES CALLED DXADJ +C***COMMON BLOCKS DXBLK2 +C***REVISION HISTORY (YYMMDD) +C 820712 DATE WRITTEN +C 881020 Revised to meet SLATEC CML recommendations. (DWL and JMS) +C 901019 Revisions to prologue. (DWL and WRB) +C 901106 Changed all specific intrinsics to generic. (WRB) +C Corrected order of sections in prologue and added TYPE +C section. (WRB) +C 920127 Revised PURPOSE section of prologue. (DWL) +C***END PROLOGUE DXADD + DOUBLE PRECISION X, Y, Z + INTEGER IX, IY, IZ + DOUBLE PRECISION RADIX, RADIXL, RAD2L, DLG10R + INTEGER L, L2, KMAX + COMMON /DXBLK2/ RADIX, RADIXL, RAD2L, DLG10R, L, L2, KMAX + SAVE /DXBLK2/ + DOUBLE PRECISION S, T +C +C THE CONDITIONS IMPOSED ON L AND KMAX BY THIS SUBROUTINE +C ARE +C (1) 1 .LT. L .LE. 0.5D0*LOGR(0.5D0*DZERO) +C +C (2) NRADPL .LT. L .LE. KMAX/6 +C +C (3) KMAX .LE. (2**NBITS - 4*L - 1)/2 +C +C THESE CONDITIONS MUST BE MET BY APPROPRIATE CODING +C IN SUBROUTINE DXSET. +C +C***FIRST EXECUTABLE STATEMENT DXADD + IERROR=0 + IF (X.NE.0.0D0) GO TO 10 + Z = Y + IZ = IY + GO TO 220 + 10 IF (Y.NE.0.0D0) GO TO 20 + Z = X + IZ = IX + GO TO 220 + 20 CONTINUE + IF (IX.GE.0 .AND. IY.GE.0) GO TO 40 + IF (IX.LT.0 .AND. IY.LT.0) GO TO 40 + IF (ABS(IX).LE.6*L .AND. ABS(IY).LE.6*L) GO TO 40 + IF (IX.GE.0) GO TO 30 + Z = Y + IZ = IY + GO TO 220 + 30 CONTINUE + Z = X + IZ = IX + GO TO 220 + 40 I = IX - IY + if (I .lt. 0) then + goto 80 + elseif (I .eq. 0) then + goto 50 + else + goto 90 + endif + 50 IF (ABS(X).GT.1.0D0 .AND. ABS(Y).GT.1.0D0) GO TO 60 + IF (ABS(X).LT.1.0D0 .AND. ABS(Y).LT.1.0D0) GO TO 70 + Z = X + Y + IZ = IX + GO TO 220 + 60 S = X/RADIXL + T = Y/RADIXL + Z = S + T + IZ = IX + L + GO TO 220 + 70 S = X*RADIXL + T = Y*RADIXL + Z = S + T + IZ = IX - L + GO TO 220 + 80 S = Y + IS = IY + T = X + GO TO 100 + 90 S = X + IS = IX + T = Y + 100 CONTINUE +C +C AT THIS POINT, THE ONE OF (X,IX) OR (Y,IY) THAT HAS THE +C LARGER AUXILIARY INDEX IS STORED IN (S,IS). THE PRINCIPAL +C PART OF THE OTHER INPUT IS STORED IN T. +C + I1 = ABS(I)/L + I2 = MOD(ABS(I),L) + IF (ABS(T).GE.RADIXL) GO TO 130 + IF (ABS(T).GE.1.0D0) GO TO 120 + IF (RADIXL*ABS(T).GE.1.0D0) GO TO 110 + J = I1 + 1 + T = T*RADIX**(L-I2) + GO TO 140 + 110 J = I1 + T = T*RADIX**(-I2) + GO TO 140 + 120 J = I1 - 1 + IF (J.LT.0) GO TO 110 + T = T*RADIX**(-I2)/RADIXL + GO TO 140 + 130 J = I1 - 2 + IF (J.LT.0) GO TO 120 + T = T*RADIX**(-I2)/RAD2L + 140 CONTINUE +C +C AT THIS POINT, SOME OR ALL OF THE DIFFERENCE IN THE +C AUXILIARY INDICES HAS BEEN USED TO EFFECT A LEFT SHIFT +C OF T. THE SHIFTED VALUE OF T SATISFIES +C +C RADIX**(-2*L) .LE. ABS(T) .LE. 1.0D0 +C +C AND, IF J=0, NO FURTHER SHIFTING REMAINS TO BE DONE. +C + IF (J.EQ.0) GO TO 190 + IF (ABS(S).GE.RADIXL .OR. J.GT.3) GO TO 150 + IF (ABS(S).GE.1.0D0) GO TO (180, 150, 150), J + IF (RADIXL*ABS(S).GE.1.0D0) GO TO (180, 170, 150), J + GO TO (180, 170, 160), J + 150 Z = S + IZ = IS + GO TO 220 + 160 S = S*RADIXL + 170 S = S*RADIXL + 180 S = S*RADIXL + 190 CONTINUE +C +C AT THIS POINT, THE REMAINING DIFFERENCE IN THE +C AUXILIARY INDICES HAS BEEN USED TO EFFECT A RIGHT SHIFT +C OF S. IF THE SHIFTED VALUE OF S WOULD HAVE EXCEEDED +C RADIX**L, THEN (S,IS) IS RETURNED AS THE VALUE OF THE +C SUM. +C + IF (ABS(S).GT.1.0D0 .AND. ABS(T).GT.1.0D0) GO TO 200 + IF (ABS(S).LT.1.0D0 .AND. ABS(T).LT.1.0D0) GO TO 210 + Z = S + T + IZ = IS - J*L + GO TO 220 + 200 S = S/RADIXL + T = T/RADIXL + Z = S + T + IZ = IS - J*L + L + GO TO 220 + 210 S = S*RADIXL + T = T*RADIXL + Z = S + T + IZ = IS - J*L - L + 220 CALL DXADJ(Z, IZ,IERROR) + RETURN + END +*DECK DXADJ + SUBROUTINE DXADJ (X, IX, IERROR) +C***BEGIN PROLOGUE DXADJ +C***PURPOSE To provide double-precision floating-point arithmetic +C with an extended exponent range. +C***LIBRARY SLATEC +C***CATEGORY A3D +C***TYPE DOUBLE PRECISION (XADJ-S, DXADJ-D) +C***KEYWORDS EXTENDED-RANGE DOUBLE-PRECISION ARITHMETIC +C***AUTHOR Lozier, Daniel W., (National Bureau of Standards) +C Smith, John M., (NBS and George Mason University) +C***DESCRIPTION +C DOUBLE PRECISION X +C INTEGER IX +C +C TRANSFORMS (X,IX) SO THAT +C RADIX**(-L) .LE. ABS(X) .LT. RADIX**L. +C ON MOST COMPUTERS THIS TRANSFORMATION DOES +C NOT CHANGE THE MANTISSA OF X PROVIDED RADIX IS +C THE NUMBER BASE OF DOUBLE-PRECISION ARITHMETIC. +C +C***SEE ALSO DXSET +C***REFERENCES (NONE) +C***ROUTINES CALLED XERMSG +C***COMMON BLOCKS DXBLK2 +C***REVISION HISTORY (YYMMDD) +C 820712 DATE WRITTEN +C 881020 Revised to meet SLATEC CML recommendations. (DWL and JMS) +C 901019 Revisions to prologue. (DWL and WRB) +C 901106 Changed all specific intrinsics to generic. (WRB) +C Corrected order of sections in prologue and added TYPE +C section. (WRB) +C CALLs to XERROR changed to CALLs to XERMSG. (WRB) +C 920127 Revised PURPOSE section of prologue. (DWL) +C***END PROLOGUE DXADJ + DOUBLE PRECISION X + INTEGER IX + DOUBLE PRECISION RADIX, RADIXL, RAD2L, DLG10R + INTEGER L, L2, KMAX + COMMON /DXBLK2/ RADIX, RADIXL, RAD2L, DLG10R, L, L2, KMAX + SAVE /DXBLK2/ +C +C THE CONDITION IMPOSED ON L AND KMAX BY THIS SUBROUTINE +C IS +C 2*L .LE. KMAX +C +C THIS CONDITION MUST BE MET BY APPROPRIATE CODING +C IN SUBROUTINE DXSET. +C +C***FIRST EXECUTABLE STATEMENT DXADJ + IERROR=0 + IF (X.EQ.0.0D0) GO TO 50 + IF (ABS(X).GE.1.0D0) GO TO 20 + IF (RADIXL*ABS(X).GE.1.0D0) GO TO 60 + X = X*RAD2L + IF (IX.LT.0) GO TO 10 + IX = IX - L2 + GO TO 70 + 10 IF (IX.LT.-KMAX+L2) GO TO 40 + IX = IX - L2 + GO TO 70 + 20 IF (ABS(X).LT.RADIXL) GO TO 60 + X = X/RAD2L + IF (IX.GT.0) GO TO 30 + IX = IX + L2 + GO TO 70 + 30 IF (IX.GT.KMAX-L2) GO TO 40 + IX = IX + L2 + GO TO 70 + 40 continue +* 40 CALL XERMSG ('SLATEC', 'DXADJ', 'overflow in auxiliary index', +* + 207, 1) + IERROR=207 + RETURN + 50 IX = 0 + 60 IF (ABS(IX).GT.KMAX) GO TO 40 + 70 RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/dxlegf.lo b/modules/elementary_functions/src/fortran/slatec/dxlegf.lo new file mode 100755 index 000000000..2f743b170 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dxlegf.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dxlegf.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dxlegf.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/dyairy.f b/modules/elementary_functions/src/fortran/slatec/dyairy.f new file mode 100755 index 000000000..0893920bf --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dyairy.f @@ -0,0 +1,394 @@ +*DECK DYAIRY + SUBROUTINE DYAIRY (X, RX, C, BI, DBI) +C***BEGIN PROLOGUE DYAIRY +C***SUBSIDIARY +C***PURPOSE Subsidiary to DBESJ and DBESY +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (YAIRY-S, DYAIRY-D) +C***AUTHOR Amos, D. E., (SNLA) +C Daniel, S. L., (SNLA) +C***DESCRIPTION +C +C DYAIRY computes the Airy function BI(X) +C and its derivative DBI(X) for DASYJY +C +C INPUT +C +C X - Argument, computed by DASYJY, X unrestricted +C RX - RX=SQRT(ABS(X)), computed by DASYJY +C C - C=2.*(ABS(X)**1.5)/3., computed by DASYJY +C +C OUTPUT +C BI - Value of function BI(X) +C DBI - Value of the derivative DBI(X) +C +C***SEE ALSO DBESJ, DBESY +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 750101 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 910408 Updated the AUTHOR section. (WRB) +C***END PROLOGUE DYAIRY +C + INTEGER I, J, M1, M1D, M2, M2D, M3, M3D, M4D, N1, N1D, N2, N2D, + 1 N3, N3D, N4D + DOUBLE PRECISION AA,AX,BB,BI,BJN,BJP,BK1,BK2,BK3,BK4,C,CON1,CON2, + 1 CON3, CV, DAA, DBB, DBI, DBJN, DBJP, DBK1, DBK2, DBK3, DBK4, D1, + 2 D2, EX, E1, E2, FPI12, F1, F2, RTRX, RX, SPI12, S1, S2, T, TC, + 3 TEMP1, TEMP2, TT, X + DIMENSION BK1(20), BK2(20), BK3(20), BK4(14) + DIMENSION BJP(19), BJN(19), AA(14), BB(14) + DIMENSION DBK1(21), DBK2(20), DBK3(20), DBK4(14) + DIMENSION DBJP(19), DBJN(19), DAA(14), DBB(14) + SAVE N1, N2, N3, M1, M2, M3, N1D, N2D, N3D, N4D, + 1 M1D, M2D, M3D, M4D, FPI12, SPI12, CON1, CON2, CON3, + 2 BK1, BK2, BK3, BK4, BJN, BJP, AA, BB, DBK1, DBK2, DBK3, DBK4, + 3 DBJP, DBJN, DAA, DBB + DATA N1,N2,N3/20,19,14/ + DATA M1,M2,M3/18,17,12/ + DATA N1D,N2D,N3D,N4D/21,20,19,14/ + DATA M1D,M2D,M3D,M4D/19,18,17,12/ + DATA FPI12,SPI12,CON1,CON2,CON3/ + 1 1.30899693899575D+00, 1.83259571459405D+00, 6.66666666666667D-01, + 2 7.74148278841779D+00, 3.64766105490356D-01/ + DATA BK1(1), BK1(2), BK1(3), BK1(4), BK1(5), BK1(6), + 1 BK1(7), BK1(8), BK1(9), BK1(10), BK1(11), BK1(12), + 2 BK1(13), BK1(14), BK1(15), BK1(16), BK1(17), BK1(18), + 3 BK1(19), BK1(20)/ 2.43202846447449D+00, 2.57132009754685D+00, + 4 1.02802341258616D+00, 3.41958178205872D-01, 8.41978629889284D-02, + 5 1.93877282587962D-02, 3.92687837130335D-03, 6.83302689948043D-04, + 6 1.14611403991141D-04, 1.74195138337086D-05, 2.41223620956355D-06, + 7 3.24525591983273D-07, 4.03509798540183D-08, 4.70875059642296D-09, + 8 5.35367432585889D-10, 5.70606721846334D-11, 5.80526363709933D-12, + 9 5.76338988616388D-13, 5.42103834518071D-14, 4.91857330301677D-15/ + DATA BK2(1), BK2(2), BK2(3), BK2(4), BK2(5), BK2(6), + 1 BK2(7), BK2(8), BK2(9), BK2(10), BK2(11), BK2(12), + 2 BK2(13), BK2(14), BK2(15), BK2(16), BK2(17), BK2(18), + 3 BK2(19), BK2(20)/ 5.74830555784088D-01,-6.91648648376891D-03, + 4 1.97460263052093D-03,-5.24043043868823D-04, 1.22965147239661D-04, + 5-2.27059514462173D-05, 2.23575555008526D-06, 4.15174955023899D-07, + 6-2.84985752198231D-07, 8.50187174775435D-08,-1.70400826891326D-08, + 7 2.25479746746889D-09,-1.09524166577443D-10,-3.41063845099711D-11, + 8 1.11262893886662D-11,-1.75542944241734D-12, 1.36298600401767D-13, + 9 8.76342105755664D-15,-4.64063099157041D-15, 7.78772758732960D-16/ + DATA BK3(1), BK3(2), BK3(3), BK3(4), BK3(5), BK3(6), + 1 BK3(7), BK3(8), BK3(9), BK3(10), BK3(11), BK3(12), + 2 BK3(13), BK3(14), BK3(15), BK3(16), BK3(17), BK3(18), + 3 BK3(19), BK3(20)/ 5.66777053506912D-01, 2.63672828349579D-03, + 4 5.12303351473130D-05, 2.10229231564492D-06, 1.42217095113890D-07, + 5 1.28534295891264D-08, 7.28556219407507D-10,-3.45236157301011D-10, + 6-2.11919115912724D-10,-6.56803892922376D-11,-8.14873160315074D-12, + 7 3.03177845632183D-12, 1.73447220554115D-12, 1.67935548701554D-13, + 8-1.49622868806719D-13,-5.15470458953407D-14, 8.75741841857830D-15, + 9 7.96735553525720D-15,-1.29566137861742D-16,-1.11878794417520D-15/ + DATA BK4(1), BK4(2), BK4(3), BK4(4), BK4(5), BK4(6), + 1 BK4(7), BK4(8), BK4(9), BK4(10), BK4(11), BK4(12), + 2 BK4(13), BK4(14)/ 4.85444386705114D-01,-3.08525088408463D-03, + 3 6.98748404837928D-05,-2.82757234179768D-06, 1.59553313064138D-07, + 4-1.12980692144601D-08, 9.47671515498754D-10,-9.08301736026423D-11, + 5 9.70776206450724D-12,-1.13687527254574D-12, 1.43982917533415D-13, + 6-1.95211019558815D-14, 2.81056379909357D-15,-4.26916444775176D-16/ + DATA BJP(1), BJP(2), BJP(3), BJP(4), BJP(5), BJP(6), + 1 BJP(7), BJP(8), BJP(9), BJP(10), BJP(11), BJP(12), + 2 BJP(13), BJP(14), BJP(15), BJP(16), BJP(17), BJP(18), + 3 BJP(19) / 1.34918611457638D-01,-3.19314588205813D-01, + 4 5.22061946276114D-02, 5.28869112170312D-02,-8.58100756077350D-03, + 5-2.99211002025555D-03, 4.21126741969759D-04, 8.73931830369273D-05, + 6-1.06749163477533D-05,-1.56575097259349D-06, 1.68051151983999D-07, + 7 1.89901103638691D-08,-1.81374004961922D-09,-1.66339134593739D-10, + 8 1.42956335780810D-11, 1.10179811626595D-12,-8.60187724192263D-14, + 9-5.71248177285064D-15, 4.08414552853803D-16/ + DATA BJN(1), BJN(2), BJN(3), BJN(4), BJN(5), BJN(6), + 1 BJN(7), BJN(8), BJN(9), BJN(10), BJN(11), BJN(12), + 2 BJN(13), BJN(14), BJN(15), BJN(16), BJN(17), BJN(18), + 3 BJN(19) / 6.59041673525697D-02,-4.24905910566004D-01, + 4 2.87209745195830D-01, 1.29787771099606D-01,-4.56354317590358D-02, + 5-1.02630175982540D-02, 2.50704671521101D-03, 3.78127183743483D-04, + 6-7.11287583284084D-05,-8.08651210688923D-06, 1.23879531273285D-06, + 7 1.13096815867279D-07,-1.46234283176310D-08,-1.11576315688077D-09, + 8 1.24846618243897D-10, 8.18334132555274D-12,-8.07174877048484D-13, + 9-4.63778618766425D-14, 4.09043399081631D-15/ + DATA AA(1), AA(2), AA(3), AA(4), AA(5), AA(6), + 1 AA(7), AA(8), AA(9), AA(10), AA(11), AA(12), + 2 AA(13), AA(14) /-2.78593552803079D-01, 3.52915691882584D-03, + 3 2.31149677384994D-05,-4.71317842263560D-06, 1.12415907931333D-07, + 4 2.00100301184339D-08,-2.60948075302193D-09, 3.55098136101216D-11, + 5 3.50849978423875D-11,-5.83007187954202D-12, 2.04644828753326D-13, + 6 1.10529179476742D-13,-2.87724778038775D-14, 2.88205111009939D-15/ + DATA BB(1), BB(2), BB(3), BB(4), BB(5), BB(6), + 1 BB(7), BB(8), BB(9), BB(10), BB(11), BB(12), + 2 BB(13), BB(14) /-4.90275424742791D-01,-1.57647277946204D-03, + 3 9.66195963140306D-05,-1.35916080268815D-07,-2.98157342654859D-07, + 4 1.86824767559979D-08, 1.03685737667141D-09,-3.28660818434328D-10, + 5 2.57091410632780D-11, 2.32357655300677D-12,-9.57523279048255D-13, + 6 1.20340828049719D-13, 2.90907716770715D-15,-4.55656454580149D-15/ + DATA DBK1(1), DBK1(2), DBK1(3), DBK1(4), DBK1(5), DBK1(6), + 1 DBK1(7), DBK1(8), DBK1(9), DBK1(10),DBK1(11),DBK1(12), + 2 DBK1(13),DBK1(14),DBK1(15),DBK1(16),DBK1(17),DBK1(18), + 3 DBK1(19),DBK1(20), + 4 DBK1(21) / 2.95926143981893D+00, 3.86774568440103D+00, + 5 1.80441072356289D+00, 5.78070764125328D-01, 1.63011468174708D-01, + 6 3.92044409961855D-02, 7.90964210433812D-03, 1.50640863167338D-03, + 7 2.56651976920042D-04, 3.93826605867715D-05, 5.81097771463818D-06, + 8 7.86881233754659D-07, 9.93272957325739D-08, 1.21424205575107D-08, + 9 1.38528332697707D-09, 1.50190067586758D-10, 1.58271945457594D-11, + 1 1.57531847699042D-12, 1.50774055398181D-13, 1.40594335806564D-14, + 2 1.24942698777218D-15/ + DATA DBK2(1), DBK2(2), DBK2(3), DBK2(4), DBK2(5), DBK2(6), + 1 DBK2(7), DBK2(8), DBK2(9), DBK2(10),DBK2(11),DBK2(12), + 2 DBK2(13),DBK2(14),DBK2(15),DBK2(16),DBK2(17),DBK2(18), + 3 DBK2(19),DBK2(20)/ 5.49756809432471D-01, 9.13556983276901D-03, + 4-2.53635048605507D-03, 6.60423795342054D-04,-1.55217243135416D-04, + 5 3.00090325448633D-05,-3.76454339467348D-06,-1.33291331611616D-07, + 6 2.42587371049013D-07,-8.07861075240228D-08, 1.71092818861193D-08, + 7-2.41087357570599D-09, 1.53910848162371D-10, 2.56465373190630D-11, + 8-9.88581911653212D-12, 1.60877986412631D-12,-1.20952524741739D-13, + 9-1.06978278410820D-14, 5.02478557067561D-15,-8.68986130935886D-16/ + DATA DBK3(1), DBK3(2), DBK3(3), DBK3(4), DBK3(5), DBK3(6), + 1 DBK3(7), DBK3(8), DBK3(9), DBK3(10),DBK3(11),DBK3(12), + 2 DBK3(13),DBK3(14),DBK3(15),DBK3(16),DBK3(17),DBK3(18), + 3 DBK3(19),DBK3(20)/ 5.60598509354302D-01,-3.64870013248135D-03, + 4-5.98147152307417D-05,-2.33611595253625D-06,-1.64571516521436D-07, + 5-2.06333012920569D-08,-4.27745431573110D-09,-1.08494137799276D-09, + 6-2.37207188872763D-10,-2.22132920864966D-11, 1.07238008032138D-11, + 7 5.71954845245808D-12, 7.51102737777835D-13,-3.81912369483793D-13, + 8-1.75870057119257D-13, 6.69641694419084D-15, 2.26866724792055D-14, + 9 2.69898141356743D-15,-2.67133612397359D-15,-6.54121403165269D-16/ + DATA DBK4(1), DBK4(2), DBK4(3), DBK4(4), DBK4(5), DBK4(6), + 1 DBK4(7), DBK4(8), DBK4(9), DBK4(10),DBK4(11),DBK4(12), + 2 DBK4(13),DBK4(14)/ 4.93072999188036D-01, 4.38335419803815D-03, + 3-8.37413882246205D-05, 3.20268810484632D-06,-1.75661979548270D-07, + 4 1.22269906524508D-08,-1.01381314366052D-09, 9.63639784237475D-11, + 5-1.02344993379648D-11, 1.19264576554355D-12,-1.50443899103287D-13, + 6 2.03299052379349D-14,-2.91890652008292D-15, 4.42322081975475D-16/ + DATA DBJP(1), DBJP(2), DBJP(3), DBJP(4), DBJP(5), DBJP(6), + 1 DBJP(7), DBJP(8), DBJP(9), DBJP(10),DBJP(11),DBJP(12), + 2 DBJP(13),DBJP(14),DBJP(15),DBJP(16),DBJP(17),DBJP(18), + 3 DBJP(19) / 1.13140872390745D-01,-2.08301511416328D-01, + 4 1.69396341953138D-02, 2.90895212478621D-02,-3.41467131311549D-03, + 5-1.46455339197417D-03, 1.63313272898517D-04, 3.91145328922162D-05, + 6-3.96757190808119D-06,-6.51846913772395D-07, 5.98707495269280D-08, + 7 7.44108654536549D-09,-6.21241056522632D-10,-6.18768017313526D-11, + 8 4.72323484752324D-12, 3.91652459802532D-13,-2.74985937845226D-14, + 9-1.95036497762750D-15, 1.26669643809444D-16/ + DATA DBJN(1), DBJN(2), DBJN(3), DBJN(4), DBJN(5), DBJN(6), + 1 DBJN(7), DBJN(8), DBJN(9), DBJN(10),DBJN(11),DBJN(12), + 2 DBJN(13),DBJN(14),DBJN(15),DBJN(16),DBJN(17),DBJN(18), + 3 DBJN(19) /-1.88091260068850D-02,-1.47798180826140D-01, + 4 5.46075900433171D-01, 1.52146932663116D-01,-9.58260412266886D-02, + 5-1.63102731696130D-02, 5.75364806680105D-03, 7.12145408252655D-04, + 6-1.75452116846724D-04,-1.71063171685128D-05, 3.24435580631680D-06, + 7 2.61190663932884D-07,-4.03026865912779D-08,-2.76435165853895D-09, + 8 3.59687929062312D-10, 2.14953308456051D-11,-2.41849311903901D-12, + 9-1.28068004920751D-13, 1.26939834401773D-14/ + DATA DAA(1), DAA(2), DAA(3), DAA(4), DAA(5), DAA(6), + 1 DAA(7), DAA(8), DAA(9), DAA(10), DAA(11), DAA(12), + 2 DAA(13), DAA(14)/ 2.77571356944231D-01,-4.44212833419920D-03, + 3 8.42328522190089D-05, 2.58040318418710D-06,-3.42389720217621D-07, + 4 6.24286894709776D-09, 2.36377836844577D-09,-3.16991042656673D-10, + 5 4.40995691658191D-12, 5.18674221093575D-12,-9.64874015137022D-13, + 6 4.90190576608710D-14, 1.77253430678112D-14,-5.55950610442662D-15/ + DATA DBB(1), DBB(2), DBB(3), DBB(4), DBB(5), DBB(6), + 1 DBB(7), DBB(8), DBB(9), DBB(10), DBB(11), DBB(12), + 2 DBB(13), DBB(14)/ 4.91627321104601D-01, 3.11164930427489D-03, + 3 8.23140762854081D-05,-4.61769776172142D-06,-6.13158880534626D-08, + 4 2.87295804656520D-08,-1.81959715372117D-09,-1.44752826642035D-10, + 5 4.53724043420422D-11,-3.99655065847223D-12,-3.24089119830323D-13, + 6 1.62098952568741D-13,-2.40765247974057D-14, 1.69384811284491D-16/ +C***FIRST EXECUTABLE STATEMENT DYAIRY + AX = ABS(X) + RX = SQRT(AX) + C = CON1*AX*RX + IF (X.LT.0.0D0) GO TO 120 + IF (C.GT.8.0D0) GO TO 60 + IF (X.GT.2.5D0) GO TO 30 + T = (X+X-2.5D0)*0.4D0 + TT = T + T + J = N1 + F1 = BK1(J) + F2 = 0.0D0 + DO 10 I=1,M1 + J = J - 1 + TEMP1 = F1 + F1 = TT*F1 - F2 + BK1(J) + F2 = TEMP1 + 10 CONTINUE + BI = T*F1 - F2 + BK1(1) + J = N1D + F1 = DBK1(J) + F2 = 0.0D0 + DO 20 I=1,M1D + J = J - 1 + TEMP1 = F1 + F1 = TT*F1 - F2 + DBK1(J) + F2 = TEMP1 + 20 CONTINUE + DBI = T*F1 - F2 + DBK1(1) + RETURN + 30 CONTINUE + RTRX = SQRT(RX) + T = (X+X-CON2)*CON3 + TT = T + T + J = N1 + F1 = BK2(J) + F2 = 0.0D0 + DO 40 I=1,M1 + J = J - 1 + TEMP1 = F1 + F1 = TT*F1 - F2 + BK2(J) + F2 = TEMP1 + 40 CONTINUE + BI = (T*F1-F2+BK2(1))/RTRX + EX = EXP(C) + BI = BI*EX + J = N2D + F1 = DBK2(J) + F2 = 0.0D0 + DO 50 I=1,M2D + J = J - 1 + TEMP1 = F1 + F1 = TT*F1 - F2 + DBK2(J) + F2 = TEMP1 + 50 CONTINUE + DBI = (T*F1-F2+DBK2(1))*RTRX + DBI = DBI*EX + RETURN +C + 60 CONTINUE + RTRX = SQRT(RX) + T = 16.0D0/C - 1.0D0 + TT = T + T + J = N1 + F1 = BK3(J) + F2 = 0.0D0 + DO 70 I=1,M1 + J = J - 1 + TEMP1 = F1 + F1 = TT*F1 - F2 + BK3(J) + F2 = TEMP1 + 70 CONTINUE + S1 = T*F1 - F2 + BK3(1) + J = N2D + F1 = DBK3(J) + F2 = 0.0D0 + DO 80 I=1,M2D + J = J - 1 + TEMP1 = F1 + F1 = TT*F1 - F2 + DBK3(J) + F2 = TEMP1 + 80 CONTINUE + D1 = T*F1 - F2 + DBK3(1) + TC = C + C + EX = EXP(C) + IF (TC.GT.35.0D0) GO TO 110 + T = 10.0D0/C - 1.0D0 + TT = T + T + J = N3 + F1 = BK4(J) + F2 = 0.0D0 + DO 90 I=1,M3 + J = J - 1 + TEMP1 = F1 + F1 = TT*F1 - F2 + BK4(J) + F2 = TEMP1 + 90 CONTINUE + S2 = T*F1 - F2 + BK4(1) + BI = (S1+EXP(-TC)*S2)/RTRX + BI = BI*EX + J = N4D + F1 = DBK4(J) + F2 = 0.0D0 + DO 100 I=1,M4D + J = J - 1 + TEMP1 = F1 + F1 = TT*F1 - F2 + DBK4(J) + F2 = TEMP1 + 100 CONTINUE + D2 = T*F1 - F2 + DBK4(1) + DBI = RTRX*(D1+EXP(-TC)*D2) + DBI = DBI*EX + RETURN + 110 BI = EX*S1/RTRX + DBI = EX*RTRX*D1 + RETURN +C + 120 CONTINUE + IF (C.GT.5.0D0) GO TO 150 + T = 0.4D0*C - 1.0D0 + TT = T + T + J = N2 + F1 = BJP(J) + E1 = BJN(J) + F2 = 0.0D0 + E2 = 0.0D0 + DO 130 I=1,M2 + J = J - 1 + TEMP1 = F1 + TEMP2 = E1 + F1 = TT*F1 - F2 + BJP(J) + E1 = TT*E1 - E2 + BJN(J) + F2 = TEMP1 + E2 = TEMP2 + 130 CONTINUE + BI = (T*E1-E2+BJN(1)) - AX*(T*F1-F2+BJP(1)) + J = N3D + F1 = DBJP(J) + E1 = DBJN(J) + F2 = 0.0D0 + E2 = 0.0D0 + DO 140 I=1,M3D + J = J - 1 + TEMP1 = F1 + TEMP2 = E1 + F1 = TT*F1 - F2 + DBJP(J) + E1 = TT*E1 - E2 + DBJN(J) + F2 = TEMP1 + E2 = TEMP2 + 140 CONTINUE + DBI = X*X*(T*F1-F2+DBJP(1)) + (T*E1-E2+DBJN(1)) + RETURN +C + 150 CONTINUE + RTRX = SQRT(RX) + T = 10.0D0/C - 1.0D0 + TT = T + T + J = N3 + F1 = AA(J) + E1 = BB(J) + F2 = 0.0D0 + E2 = 0.0D0 + DO 160 I=1,M3 + J = J - 1 + TEMP1 = F1 + TEMP2 = E1 + F1 = TT*F1 - F2 + AA(J) + E1 = TT*E1 - E2 + BB(J) + F2 = TEMP1 + E2 = TEMP2 + 160 CONTINUE + TEMP1 = T*F1 - F2 + AA(1) + TEMP2 = T*E1 - E2 + BB(1) + CV = C - FPI12 + BI = (TEMP1*COS(CV)+TEMP2*SIN(CV))/RTRX + J = N4D + F1 = DAA(J) + E1 = DBB(J) + F2 = 0.0D0 + E2 = 0.0D0 + DO 170 I=1,M4D + J = J - 1 + TEMP1 = F1 + TEMP2 = E1 + F1 = TT*F1 - F2 + DAA(J) + E1 = TT*E1 - E2 + DBB(J) + F2 = TEMP1 + E2 = TEMP2 + 170 CONTINUE + TEMP1 = T*F1 - F2 + DAA(1) + TEMP2 = T*E1 - E2 + DBB(1) + CV = C - SPI12 + DBI = (TEMP1*COS(CV)-TEMP2*SIN(CV))*RTRX + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/dyairy.lo b/modules/elementary_functions/src/fortran/slatec/dyairy.lo new file mode 100755 index 000000000..beea6868e --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/dyairy.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/dyairy.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dyairy.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/fdump.f b/modules/elementary_functions/src/fortran/slatec/fdump.f new file mode 100755 index 000000000..1f44a57a0 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/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/modules/elementary_functions/src/fortran/slatec/fdump.lo b/modules/elementary_functions/src/fortran/slatec/fdump.lo new file mode 100755 index 000000000..9f117ae97 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/fdump.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/fdump.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/fdump.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/gamma.f b/modules/elementary_functions/src/fortran/slatec/gamma.f new file mode 100755 index 000000000..f14946222 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/gamma.f @@ -0,0 +1,282 @@ +CS REAL FUNCTION GAMMA(X) + DOUBLE PRECISION FUNCTION DGAMMACODY(X) +C---------------------------------------------------------------------- +C +C This routine calculates the GAMMA function for a real argument X. +C Computation is based on an algorithm outlined in reference 1. +C The program uses rational functions that approximate the GAMMA +C function to at least 20 significant decimal digits. Coefficients +C for the approximation over the interval (1,2) are unpublished. +C Those for the approximation for X .GE. 12 are from reference 2. +C The accuracy achieved depends on the arithmetic system, the +C compiler, the intrinsic functions, and proper selection of the +C machine-dependent constants. +C +C +C******************************************************************* +C******************************************************************* +C +C Explanation of machine-dependent constants +C +C beta - radix for the floating-point representation +C maxexp - the smallest positive power of beta that overflows +C XBIG - the largest argument for which GAMMA(X) is representable +C in the machine, i.e., the solution to the equation +C GAMMA(XBIG) = beta**maxexp +C XINF - the largest machine representable floating-point number; +C approximately beta**maxexp +C EPS - the smallest positive floating-point number such that +C 1.0+EPS .GT. 1.0 +C XMININ - the smallest positive floating-point number such that +C 1/XMININ is machine representable +C +C Approximate values for some important machines are: +C +C beta maxexp XBIG +C +C CRAY-1 (S.P.) 2 8191 966.961 +C Cyber 180/855 +C under NOS (S.P.) 2 1070 177.803 +C IEEE (IBM/XT, +C SUN, etc.) (S.P.) 2 128 35.040 +C IEEE (IBM/XT, +C SUN, etc.) (D.P.) 2 1024 171.624 +C IBM 3033 (D.P.) 16 63 57.574 +C VAX D-Format (D.P.) 2 127 34.844 +C VAX G-Format (D.P.) 2 1023 171.489 +C +C XINF EPS XMININ +C +C CRAY-1 (S.P.) 5.45E+2465 7.11E-15 1.84E-2466 +C Cyber 180/855 +C under NOS (S.P.) 1.26E+322 3.55E-15 3.14E-294 +C IEEE (IBM/XT, +C SUN, etc.) (S.P.) 3.40E+38 1.19E-7 1.18E-38 +C IEEE (IBM/XT, +C SUN, etc.) (D.P.) 1.79D+308 2.22D-16 2.23D-308 +C IBM 3033 (D.P.) 7.23D+75 2.22D-16 1.39D-76 +C VAX D-Format (D.P.) 1.70D+38 1.39D-17 5.88D-39 +C VAX G-Format (D.P.) 8.98D+307 1.11D-16 1.12D-308 +C +C******************************************************************* +C******************************************************************* +C +C Error returns +C +C The program returns the value XINF for singularities or +C when overflow would occur. The computation is believed +C to be free of underflow and overflow. +C +C +C Intrinsic functions required are: +C +C INT, DBLE, EXP, LOG, REAL, SIN +C +C +C References: "An Overview of Software Development for Special +C Functions", W. J. Cody, Lecture Notes in Mathematics, +C 506, Numerical Analysis Dundee, 1975, G. A. Watson +C (ed.), Springer Verlag, Berlin, 1976. +C +C Computer Approximations, Hart, Et. Al., Wiley and +C sons, New York, 1968. +C +C Latest modification: October 12, 1989 +C +C Authors: W. J. Cody and L. Stoltz +C Applied Mathematics Division +C Argonne National Laboratory +C Argonne, IL 60439 +C +C---------------------------------------------------------------------- +* +* A few modifs from Bruno (25 Feb 2005) from a Serge 's request: +* +* - change the name of this function (DGAMMA -> DGAMMACODY) to avoid conflict with +* the gamma Slatec (file dgamma.f). (in fact thare was no conflict as this +* function was retrieved in the makefile...) +* +* - modify to get "better" values in some cases: +* +* 1/ when x is small we used more completly the equivalent gamma(x) ~ 1/x +* (the original code uses it only if XMININ <= x < eps) +* this lets to get +-Inf for x = +-0 +* 2/ when x is a negative integer return Nan (in place of XINF) +* 3/ when the gamma overflow return Inf (in place of XINF) +* Serge asks me to change this in the Slatec gamma function but I try +* first to do it in the Cody 's gamma... In fact to do a real job an +* exception may be returned (with an integer flag say IERR) in theses +* cases so as to prevent the user depending on the ieee scilab var. +* + INTEGER I,N + LOGICAL PARITY +CS REAL + DOUBLE PRECISION + 1 C,CONV,EPS,FACT,HALF,ONE,P,PI,Q,RES,SQRTPI,SUM,TWELVE, + 2 TWO,X,XBIG,XDEN,XINF,XNUM,Y,Y1,YSQ,Z,ZERO, XMININ + DIMENSION C(7),P(8),Q(8) +C---------------------------------------------------------------------- +C Mathematical constants +C---------------------------------------------------------------------- +CS DATA ONE,HALF,TWELVE,TWO,ZERO/1.0E0,0.5E0,12.0E0,2.0E0,0.0E0/, +CS 1 SQRTPI/0.9189385332046727417803297E0/, +CS 2 PI/3.1415926535897932384626434E0/ + DATA ONE,HALF,TWELVE,TWO,ZERO/1.0D0,0.5D0,12.0D0,2.0D0,0.0D0/, + 1 SQRTPI/0.9189385332046727417803297D0/, + 2 PI/3.1415926535897932384626434D0/ +C---------------------------------------------------------------------- +C Machine dependent parameters +C---------------------------------------------------------------------- +CS DATA XBIG,XMININ,EPS/35.040E0,1.18E-38,1.19E-7/, +CS 1 XINF/3.4E38/ + DATA XBIG,XMININ,EPS/171.624D0,2.23D-308,2.22D-16/, + 1 XINF/1.79D308/ +C---------------------------------------------------------------------- +C Numerator and denominator coefficients for rational minimax +C approximation over (1,2). +C---------------------------------------------------------------------- +CS DATA P/-1.71618513886549492533811E+0,2.47656508055759199108314E+1, +CS 1 -3.79804256470945635097577E+2,6.29331155312818442661052E+2, +CS 2 8.66966202790413211295064E+2,-3.14512729688483675254357E+4, +CS 3 -3.61444134186911729807069E+4,6.64561438202405440627855E+4/ +CS DATA Q/-3.08402300119738975254353E+1,3.15350626979604161529144E+2, +CS 1 -1.01515636749021914166146E+3,-3.10777167157231109440444E+3, +CS 2 2.25381184209801510330112E+4,4.75584627752788110767815E+3, +CS 3 -1.34659959864969306392456E+5,-1.15132259675553483497211E+5/ + DATA P/-1.71618513886549492533811D+0,2.47656508055759199108314D+1, + 1 -3.79804256470945635097577D+2,6.29331155312818442661052D+2, + 2 8.66966202790413211295064D+2,-3.14512729688483675254357D+4, + 3 -3.61444134186911729807069D+4,6.64561438202405440627855D+4/ + DATA Q/-3.08402300119738975254353D+1,3.15350626979604161529144D+2, + 1 -1.01515636749021914166146D+3,-3.10777167157231109440444D+3, + 2 2.25381184209801510330112D+4,4.75584627752788110767815D+3, + 3 -1.34659959864969306392456D+5,-1.15132259675553483497211D+5/ +C---------------------------------------------------------------------- +C Coefficients for minimax approximation over (12, INF). +C---------------------------------------------------------------------- +CS DATA C/-1.910444077728E-03,8.4171387781295E-04, +CS 1 -5.952379913043012E-04,7.93650793500350248E-04, +CS 2 -2.777777777777681622553E-03,8.333333333333333331554247E-02, +CS 3 5.7083835261E-03/ + DATA C/-1.910444077728D-03,8.4171387781295D-04, + 1 -5.952379913043012D-04,7.93650793500350248D-04, + 2 -2.777777777777681622553D-03,8.333333333333333331554247D-02, + 3 5.7083835261D-03/ +C---------------------------------------------------------------------- +C Statement functions for conversion between integer and float +C---------------------------------------------------------------------- +CS CONV(I) = REAL(I) + CONV(I) = DBLE(I) + PARITY = .FALSE. + FACT = ONE + N = 0 + Y = X + + if (abs(Y) .LT. EPS) then +* argument is enough small (to use the equivalent 1/x) + RES = ONE / Y + goto 900 + + ELSE IF (Y .LE. ZERO) THEN +C---------------------------------------------------------------------- +C Argument is negative +C---------------------------------------------------------------------- + Y = -X + Y1 = AINT(Y) + RES = Y - Y1 + IF (RES .NE. ZERO) THEN + IF (Y1 .NE. AINT(Y1*HALF)*TWO) PARITY = .TRUE. + FACT = -PI / SIN(PI*RES) + Y = Y + ONE + ELSE +* RES = XINF +* modif Bruno: return Nan (Y is a negative integer) + CALL returnananfortran(RES) + GO TO 900 + END IF + END IF +C---------------------------------------------------------------------- +C Argument is positive +C---------------------------------------------------------------------- + IF (Y .LT. EPS) THEN +C---------------------------------------------------------------------- +C Argument .LT. EPS +C---------------------------------------------------------------------- +* IF (Y .GE. XMININ) THEN + RES = ONE / Y +* ELSE +* RES = XINF +* GO TO 900 +* END IF + ELSE IF (Y .LT. TWELVE) THEN + Y1 = Y + IF (Y .LT. ONE) THEN +C---------------------------------------------------------------------- +C 0.0 .LT. argument .LT. 1.0 +C---------------------------------------------------------------------- + Z = Y + Y = Y + ONE + ELSE +C---------------------------------------------------------------------- +C 1.0 .LT. argument .LT. 12.0, reduce argument if necessary +C---------------------------------------------------------------------- + N = INT(Y) - 1 + Y = Y - CONV(N) + Z = Y - ONE + END IF +C---------------------------------------------------------------------- +C Evaluate approximation for 1.0 .LT. argument .LT. 2.0 +C---------------------------------------------------------------------- + XNUM = ZERO + XDEN = ONE + DO 260 I = 1, 8 + XNUM = (XNUM + P(I)) * Z + XDEN = XDEN * Z + Q(I) + 260 CONTINUE + RES = XNUM / XDEN + ONE + IF (Y1 .LT. Y) THEN +C---------------------------------------------------------------------- +C Adjust result for case 0.0 .LT. argument .LT. 1.0 +C---------------------------------------------------------------------- + RES = RES / Y1 + ELSE IF (Y1 .GT. Y) THEN +C---------------------------------------------------------------------- +C Adjust result for case 2.0 .LT. argument .LT. 12.0 +C---------------------------------------------------------------------- + DO 290 I = 1, N + RES = RES * Y + Y = Y + ONE + 290 CONTINUE + END IF + ELSE +C---------------------------------------------------------------------- +C Evaluate for argument .GE. 12.0, +C---------------------------------------------------------------------- + IF (Y .LE. XBIG) THEN + YSQ = Y * Y + SUM = C(7) + DO 350 I = 1, 6 + SUM = SUM / YSQ + C(I) + 350 CONTINUE + SUM = SUM/Y - Y + SQRTPI + SUM = SUM + (Y-HALF)*LOG(Y) + RES = EXP(SUM) + ELSE +* RES = XINF +* modif bruno : return an Inf + xfinf = 0.d0 + RES = 1 / xfinf +* end modif bruno + GO TO 900 + END IF + END IF +C---------------------------------------------------------------------- +C Final adjustments and return +C---------------------------------------------------------------------- + IF (PARITY) RES = -RES + IF (FACT .NE. ONE) RES = FACT / RES +CS900 GAMMA = RES + 900 DGAMMACODY = RES + RETURN +C ---------- Last line of GAMMA ---------- + END diff --git a/modules/elementary_functions/src/fortran/slatec/gamma.lo b/modules/elementary_functions/src/fortran/slatec/gamma.lo new file mode 100755 index 000000000..65535ee67 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/gamma.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/gamma.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/gamma.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/initds.f b/modules/elementary_functions/src/fortran/slatec/initds.f new file mode 100755 index 000000000..36eca15f8 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/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/modules/elementary_functions/src/fortran/slatec/initds.lo b/modules/elementary_functions/src/fortran/slatec/initds.lo new file mode 100755 index 000000000..315f93ce0 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/initds.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/initds.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/initds.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/j4save.f b/modules/elementary_functions/src/fortran/slatec/j4save.f new file mode 100755 index 000000000..f5f8a9a22 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/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,6,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/modules/elementary_functions/src/fortran/slatec/j4save.lo b/modules/elementary_functions/src/fortran/slatec/j4save.lo new file mode 100755 index 000000000..0e8ed147d --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/j4save.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/j4save.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/j4save.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/pchim.f b/modules/elementary_functions/src/fortran/slatec/pchim.f new file mode 100755 index 000000000..35c4d21c2 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/pchim.f @@ -0,0 +1,305 @@ + SUBROUTINE DPCHIM(N,X,F,D,INCFD) +* +* This subroutine comes from the slatec / cmlib and has +* been slightly modified for inclusion in scilab : all +* the error treatment has been removed (and so the +* parameter IERR) because this is done by the scilab +* interface. +* +C***BEGIN PROLOGUE DPCHIM +C***DATE WRITTEN 811103 (YYMMDD) +C***REVISION DATE 870707 (YYMMDD) +C***CATEGORY NO. E1B +C***KEYWORDS LIBRARY=SLATEC(PCHIP), +C TYPE=DOUBLE PRECISION(PCHIM-S DPCHIM-D), +C CUBIC HERMITE INTERPOLATION,MONOTONE INTERPOLATION, +C PIECEWISE CUBIC INTERPOLATION +C***AUTHOR FRITSCH, F. N., (LLNL) +C MATHEMATICS AND STATISTICS DIVISION +C LAWRENCE LIVERMORE NATIONAL LABORATORY +C P.O. BOX 808 (L-316) +C LIVERMORE, CA 94550 +C FTS 532-4275, (415) 422-4275 +C***PURPOSE Set derivatives needed to determine a monotone piecewise +C cubic Hermite interpolant to given data. Boundary values +C are provided which are compatible with monotonicity. The +C interpolant will have an extremum at each point where mono- +C tonicity switches direction. (See DPCHIC if user control +C is desired over boundary or switch conditions.) +C***DESCRIPTION +C +C **** Double Precision version of PCHIM **** +C +C DPCHIM: Piecewise Cubic Hermite Interpolation to +C Monotone data. +C +C Sets derivatives needed to determine a monotone piecewise cubic +C Hermite interpolant to the data given in X and F. +C +C Default boundary conditions are provided which are compatible +C with monotonicity. (See DPCHIC if user control of boundary con- +C ditions is desired.) +C +C If the data are only piecewise monotonic, the interpolant will +C have an extremum at each point where monotonicity switches direc- +C tion. (See DPCHIC if user control is desired in such cases.) +C +C To facilitate two-dimensional applications, includes an increment +C between successive values of the F- and D-arrays. +C +C The resulting piecewise cubic Hermite function may be evaluated +C by DPCHFE or DPCHFD. +C +C ---------------------------------------------------------------------- +C +C Calling sequence: +C +C PARAMETER (INCFD = ...) +C INTEGER N, IERR +C DOUBLE PRECISION X(N), F(INCFD,N), D(INCFD,N) +C +C CALL DPCHIM (N, X, F, D, INCFD, IERR) +C +C Parameters: +C +C N -- (input) number of data points. (Error return if N.LT.2 .) +C If N=2, simply does linear interpolation. +C +C X -- (input) real*8 array of independent variable values. The +C elements of X must be strictly increasing: +C X(I-1) .LT. X(I), I = 2(1)N. +C (Error return if not.) +C +C F -- (input) real*8 array of dependent variable values to be +C interpolated. F(1+(I-1)*INCFD) is value corresponding to +C X(I). DPCHIM is designed for monotonic data, but it will +C work for any F-array. It will force extrema at points where +C monotonicity switches direction. If some other treatment of +C switch points is desired, DPCHIC should be used instead. +C ----- +C D -- (output) real*8 array of derivative values at the data +C points. If the data are monotonic, these values will +C determine a monotone cubic Hermite function. +C The value corresponding to X(I) is stored in +C D(1+(I-1)*INCFD), I=1(1)N. +C No other entries in D are changed. +C +C INCFD -- (input) increment between successive values in F and D. +C This argument is provided primarily for 2-D applications. +C (Error return if INCFD.LT.1 .) +C +C IERR -- (output) error flag. --REMOVED IN THIS VERSION-- +C +C***REFERENCES 1. F.N.FRITSCH AND R.E.CARLSON, 'MONOTONE PIECEWISE +C CUBIC INTERPOLATION,' SIAM J.NUMER.ANAL. 17, 2 (APRIL +C 1980), 238-246. +C 2. F.N.FRITSCH AND J.BUTLAND, 'A METHOD FOR CONSTRUCTING +C LOCAL MONOTONE PIECEWISE CUBIC INTERPOLANTS,' SIAM +C J.SCI.STAT.COMPUT.5,2 (JUNE 1984), 300-304. +C***ROUTINES CALLED DPCHST,XERROR ( XERROR is not called in this version ) +C***END PROLOGUE DPCHIM +C +C ---------------------------------------------------------------------- +C +C Change record: +C 82-02-01 1. Introduced DPCHST to reduce possible over/under- +C flow problems. +C 2. Rearranged derivative formula for same reason. +C 82-06-02 1. Modified end conditions to be continuous functions +C of data when monotonicity switches in next interval. +C 2. Modified formulas so end conditions are less prone +C of over/underflow problems. +C 82-08-03 Minor cosmetic changes for release 1. +C 87-07-07 Corrected XERROR calls for d.p. name(s). +C +C ---------------------------------------------------------------------- +C +C Programming notes: +C +C 1. The function DPCHST(ARG1,ARG2) is assumed to return zero if +C either argument is zero, +1 if they are of the same sign, and +C -1 if they are of opposite sign. +C 2. To produce a single precision version, simply: +C a. Change DPCHIM to PCHIM wherever it occurs, +C b. Change DPCHST to PCHST wherever it occurs, +C c. Change all references to the Fortran intrinsics to their +C single precision equivalents, +C d. Change the double precision declarations to real, and +C e. Change the constants ZERO and THREE to single precision. +C +C DECLARE ARGUMENTS. +C + INTEGER N, INCFD + DOUBLE PRECISION X(N), F(INCFD,N), D(INCFD,N) +C +C DECLARE LOCAL VARIABLES. +C + INTEGER I, NLESS1 + DOUBLE PRECISION DEL1, DEL2, DMAX, DMIN, DRAT1, DRAT2, DSAVE, + * H1, H2, HSUM, HSUMT3, THREE, W1, W2, ZERO + external DPCHST + DOUBLE PRECISION DPCHST + DATA ZERO /0.D0/, THREE/3.D0/ + + NLESS1 = N - 1 + H1 = X(2) - X(1) + DEL1 = (F(1,2) - F(1,1))/H1 + DSAVE = DEL1 +C +C SPECIAL CASE N=2 -- USE LINEAR INTERPOLATION. +C +C patch Bruno N was NLESS1 + IF (N .EQ. 2) THEN + D(1,1) = DEL1 + D(1,N) = DEL1 + return + endif + +C +C NORMAL CASE (N .GE. 3). +C + H2 = X(3) - X(2) + DEL2 = (F(1,3) - F(1,2))/H2 +C +C SET D(1) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE +C SHAPE-PRESERVING. +C + HSUM = H1 + H2 + W1 = (H1 + HSUM)/HSUM + W2 = -H1/HSUM + D(1,1) = W1*DEL1 + W2*DEL2 + IF ( DPCHST(D(1,1),DEL1) .LE. ZERO) THEN + D(1,1) = ZERO + ELSE IF ( DPCHST(DEL1,DEL2) .LT. ZERO) THEN +C NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES. + DMAX = THREE*DEL1 + IF (DABS(D(1,1)) .GT. DABS(DMAX)) D(1,1) = DMAX + ENDIF +C +C LOOP THROUGH INTERIOR POINTS. +C + DO 50 I = 2, NLESS1 + IF (I .EQ. 2) GO TO 40 +C + H1 = H2 + H2 = X(I+1) - X(I) + HSUM = H1 + H2 + DEL1 = DEL2 + DEL2 = (F(1,I+1) - F(1,I))/H2 + 40 CONTINUE +C +C SET D(I)=0 UNLESS DATA ARE STRICTLY MONOTONIC. +C + D(1,I) = ZERO + CRES=DPCHST(DEL1,DEL2) + if (CRES .lt. 0) then + goto 42 + elseif (CRES .eq. 0) then + goto 41 + else + goto 45 + endif +C +C COUNT NUMBER OF CHANGES IN DIRECTION OF MONOTONICITY. +C + 41 CONTINUE + IF (DEL2 .EQ. ZERO) GO TO 50 + DSAVE = DEL2 + GO TO 50 +C + 42 CONTINUE + DSAVE = DEL2 + GO TO 50 +C +C USE BRODLIE MODIFICATION OF BUTLAND FORMULA. +C + 45 CONTINUE + HSUMT3 = HSUM+HSUM+HSUM + W1 = (HSUM + H1)/HSUMT3 + W2 = (HSUM + H2)/HSUMT3 + DMAX = DMAX1( DABS(DEL1), DABS(DEL2) ) + DMIN = DMIN1( DABS(DEL1), DABS(DEL2) ) + DRAT1 = DEL1/DMAX + DRAT2 = DEL2/DMAX + D(1,I) = DMIN/(W1*DRAT1 + W2*DRAT2) +C + 50 CONTINUE +C +C SET D(N) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE +C SHAPE-PRESERVING. +C + W1 = -H2/HSUM + W2 = (H2 + HSUM)/HSUM + D(1,N) = W1*DEL1 + W2*DEL2 + IF ( DPCHST(D(1,N),DEL2) .LE. ZERO) THEN + D(1,N) = ZERO + ELSE IF ( DPCHST(DEL1,DEL2) .LT. ZERO) THEN +C NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES. + DMAX = THREE*DEL2 + IF (DABS(D(1,N)) .GT. DABS(DMAX)) D(1,N) = DMAX + ENDIF +C +C NORMAL RETURN. +C + end + + DOUBLE PRECISION FUNCTION DPCHST(ARG1,ARG2) +C***BEGIN PROLOGUE DPCHST +C***REFER TO DPCHCE,DPCHCI,DPCHCS,DPCHIM +C***ROUTINES CALLED (NONE) +C***REVISION DATE 870707 (YYMMDD) +C***DESCRIPTION +C +C DPCHST: DPCHIP Sign-Testing Routine. +C +C +C Returns: +C -1. if ARG1 and ARG2 are of opposite sign. +C 0. if either argument is zero. +C +1. if ARG1 and ARG2 are of the same sign. +C +C The object is to do this without multiplying ARG1*ARG2, to avoid +C possible over/underflow problems. +C +C Fortran intrinsics used: SIGN. +C +C***END PROLOGUE DPCHST +C +C ---------------------------------------------------------------------- +C +C Programmed by: Fred N. Fritsch, FTS 532-4275, (415) 422-4275, +C Mathematics and Statistics Division, +C Lawrence Livermore National Laboratory. +C +C Change record: +C 82-08-05 Converted to SLATEC library version. +C +C ---------------------------------------------------------------------- +C +C Programming notes: +C +C To produce a single precision version, simply: +C a. Change DPCHST to PCHST wherever it occurs, +C b. Change all references to the Fortran intrinsics to their +C single presision equivalents, +C c. Change the double precision declarations to real, and +C d. Change the constants ZERO and ONE to single precision. +C +C DECLARE ARGUMENTS. +C + DOUBLE PRECISION ARG1, ARG2 +C +C DECLARE LOCAL VARIABLES. +C + DOUBLE PRECISION ONE, ZERO + DATA ZERO /0.D0/, ONE/1.D0/ +C +C PERFORM THE TEST. +C +C***FIRST EXECUTABLE STATEMENT DPCHST + DPCHST = DSIGN(ONE,ARG1) * DSIGN(ONE,ARG2) + IF ((ARG1.EQ.ZERO) .OR. (ARG2.EQ.ZERO)) DPCHST = ZERO +C + RETURN +C------------- LAST LINE OF DPCHST FOLLOWS ----------------------------- + END diff --git a/modules/elementary_functions/src/fortran/slatec/pchim.lo b/modules/elementary_functions/src/fortran/slatec/pchim.lo new file mode 100755 index 000000000..444556b91 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/pchim.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/pchim.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/pchim.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/slatec_f.rc b/modules/elementary_functions/src/fortran/slatec/slatec_f.rc new file mode 100755 index 000000000..cc63510db --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/slatec_f.rc @@ -0,0 +1,96 @@ +// Microsoft Visual C++ generated resource script. +// + + +#define APSTUDIO_READONLY_SYMBOLS +///////////////////////////////////////////////////////////////////////////// +// +// Generated from the TEXTINCLUDE 2 resource. +// +//#include "afxres.h" +#define APSTUDIO_HIDDEN_SYMBOLS +#include "windows.h" +///////////////////////////////////////////////////////////////////////////// +#undef APSTUDIO_READONLY_SYMBOLS + +///////////////////////////////////////////////////////////////////////////// +// French (France) resources + +#if !defined(AFX_RESOURCE_DLL) || defined(AFX_TARG_FRA) +#ifdef _WIN32 +LANGUAGE LANG_FRENCH, SUBLANG_FRENCH +#pragma code_page(1252) +#endif //_WIN32 + +#ifdef APSTUDIO_INVOKED +///////////////////////////////////////////////////////////////////////////// +// +// TEXTINCLUDE +// + +1 TEXTINCLUDE +BEGIN + "resource.h\0" +END + +3 TEXTINCLUDE +BEGIN + "\r\n" + "\0" +END + +#endif // APSTUDIO_INVOKED + + +///////////////////////////////////////////////////////////////////////////// +// +// Version +// + +VS_VERSION_INFO VERSIONINFO + FILEVERSION 5,5,2,0 + PRODUCTVERSION 5,5,2,0 + FILEFLAGSMASK 0x17L +#ifdef _DEBUG + FILEFLAGS 0x1L +#else + FILEFLAGS 0x0L +#endif + FILEOS 0x4L + FILETYPE 0x2L + FILESUBTYPE 0x0L +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "040c04b0" + BEGIN + VALUE "FileDescription", "slatec_f module" + VALUE "FileVersion", "5, 5, 2, 0" + VALUE "InternalName", "slatec_f module" + VALUE "LegalCopyright", "Copyright (C) 2017" + VALUE "OriginalFilename", "slatec_f.dll" + VALUE "ProductName", "slatec_f module" + VALUE "ProductVersion", "5, 5, 2, 0" + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x40c, 1200 + END +END + +#endif // French (France) resources +///////////////////////////////////////////////////////////////////////////// + + + +#ifndef APSTUDIO_INVOKED +///////////////////////////////////////////////////////////////////////////// +// +// Generated from the TEXTINCLUDE 3 resource. +// + + +///////////////////////////////////////////////////////////////////////////// +#endif // not APSTUDIO_INVOKED + diff --git a/modules/elementary_functions/src/fortran/slatec/slatec_f.vfproj b/modules/elementary_functions/src/fortran/slatec/slatec_f.vfproj new file mode 100755 index 000000000..8f67bb81b --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/slatec_f.vfproj @@ -0,0 +1,184 @@ +<?xml version="1.0" encoding="UTF-8"?> +<VisualStudioProject ProjectType="typeDynamicLibrary" ProjectCreator="Intel Fortran" Keyword="Dll" Version="11.0" ProjectIdGuid="{EAF0949C-28D2-497C-954F-FC13B32FF2F3}"> + <Platforms> + <Platform Name="Win32"/> + <Platform Name="x64"/></Platforms> + <Configurations> + <Configuration Name="Debug|Win32" OutputDirectory="$(SolutionDir)bin\" IntermediateDirectory="$(ProjectDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary"> + <Tool Name="VFFortranCompilerTool" SuppressStartupBanner="true" DebugInformationFormat="debugEnabled" Optimization="optimizeDisabled" AdditionalIncludeDirectories="../../../../core/includes" PreprocessorDefinitions="WIN32;FORDLL" AlternateParameterSyntax="false" F77RuntimeCompatibility="true" FPS4Libs="false" CallingConvention="callConventionCRef" ExternalNameUnderscore="true" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" RuntimeLibrary="rtMultiThreadedDebugDLL"/> + <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin\$(ProjectName).dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" ModuleDefinitionFile="slatec_f.def" GenerateDebugInformation="true" SubSystem="subSystemWindows" ImportLibrary="$(SolutionDir)bin\$(ProjectName).lib" LinkDLL="true" AdditionalDependencies="../../../../../bin/lapack.lib core.lib elementary_functions_f.lib elementary_functions.lib output_stream.lib elementary_functions_f.lib"/> + <Tool Name="VFResourceCompilerTool"/> + <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/> + <Tool Name="VFCustomBuildTool"/> + <Tool Name="VFPreLinkEventTool" CommandLine="setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .." Description="Build $(ProjectName).def"/> + <Tool Name="VFPreBuildEventTool" CommandLine="lib /DEF:"$(InputDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)Elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)Elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)Elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)Elementary_functions.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)Output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)Output_stream.lib" 1>NUL 2>NUL" Description="Build dependencies"/> + <Tool Name="VFPostBuildEventTool"/> + <Tool Name="VFManifestTool" SuppressStartupBanner="true"/></Configuration> + <Configuration Name="Release|Win32" OutputDirectory="$(SolutionDir)bin\" IntermediateDirectory="$(ProjectDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary"> + <Tool Name="VFFortranCompilerTool" SuppressStartupBanner="true" AdditionalIncludeDirectories="../../../../core/includes" PreprocessorDefinitions="WIN32;FORDLL" AlternateParameterSyntax="false" F77RuntimeCompatibility="true" FPS4Libs="false" CallingConvention="callConventionCRef" ExternalNameUnderscore="true" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" RuntimeLibrary="rtMultiThreadedDLL"/> + <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin\$(ProjectName).dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" ModuleDefinitionFile="slatec_f.def" SubSystem="subSystemWindows" ImportLibrary="$(SolutionDir)bin\$(ProjectName).lib" LinkDLL="true" AdditionalDependencies="../../../../../bin/lapack.lib core.lib elementary_functions_f.lib elementary_functions.lib output_stream.lib elementary_functions_f.lib"/> + <Tool Name="VFResourceCompilerTool"/> + <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/> + <Tool Name="VFCustomBuildTool"/> + <Tool Name="VFPreLinkEventTool" CommandLine="setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .." Description="Build $(ProjectName).def"/> + <Tool Name="VFPreBuildEventTool" CommandLine="lib /DEF:"$(InputDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)Elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)Elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)Elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)Elementary_functions.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)Output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)Output_stream.lib" 1>NUL 2>NUL" Description="Build dependencies"/> + <Tool Name="VFPostBuildEventTool"/> + <Tool Name="VFManifestTool" SuppressStartupBanner="true"/></Configuration> + <Configuration Name="Debug|x64" OutputDirectory="$(SolutionDir)bin\" IntermediateDirectory="$(ProjectDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary"> + <Tool Name="VFFortranCompilerTool" SuppressStartupBanner="true" DebugInformationFormat="debugEnabled" Optimization="optimizeDisabled" AdditionalIncludeDirectories="../../../../core/includes" PreprocessorDefinitions="WIN32;FORDLL" AlternateParameterSyntax="false" F77RuntimeCompatibility="true" FPS4Libs="false" CallingConvention="callConventionCRef" ExternalNameUnderscore="true" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" RuntimeLibrary="rtMultiThreadedDebugDLL"/> + <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin\$(ProjectName).dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" ModuleDefinitionFile="slatec_f.def" GenerateDebugInformation="true" SubSystem="subSystemWindows" ImportLibrary="$(SolutionDir)bin\$(ProjectName).lib" LinkDLL="true" AdditionalDependencies="../../../../../bin/lapack.lib core.lib elementary_functions_f.lib elementary_functions.lib output_stream.lib elementary_functions_f.lib"/> + <Tool Name="VFResourceCompilerTool"/> + <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/> + <Tool Name="VFCustomBuildTool"/> + <Tool Name="VFPreLinkEventTool" CommandLine="setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .." Description="Build $(ProjectName).def"/> + <Tool Name="VFPreBuildEventTool" CommandLine="lib /DEF:"$(InputDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)Elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)Elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)Elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)Elementary_functions.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)Output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)Output_stream.lib" 1>NUL 2>NUL" Description="Build dependencies"/> + <Tool Name="VFPostBuildEventTool"/> + <Tool Name="VFManifestTool" SuppressStartupBanner="true"/></Configuration> + <Configuration Name="Release|x64" OutputDirectory="$(SolutionDir)bin\" IntermediateDirectory="$(ProjectDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary"> + <Tool Name="VFFortranCompilerTool" SuppressStartupBanner="true" AdditionalIncludeDirectories="../../../../core/includes" PreprocessorDefinitions="WIN32;FORDLL" AlternateParameterSyntax="false" F77RuntimeCompatibility="true" FPS4Libs="false" CallingConvention="callConventionCRef" ExternalNameUnderscore="true" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" RuntimeLibrary="rtMultiThreadedDLL"/> + <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin\$(ProjectName).dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" ModuleDefinitionFile="slatec_f.def" SubSystem="subSystemWindows" ImportLibrary="$(SolutionDir)bin\$(ProjectName).lib" LinkDLL="true" AdditionalDependencies="../../../../../bin/lapack.lib core.lib elementary_functions_f.lib elementary_functions.lib output_stream.lib elementary_functions_f.lib"/> + <Tool Name="VFResourceCompilerTool"/> + <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/> + <Tool Name="VFCustomBuildTool"/> + <Tool Name="VFPreLinkEventTool" CommandLine="setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .." Description="Build $(ProjectName).def"/> + <Tool Name="VFPreBuildEventTool" CommandLine="lib /DEF:"$(InputDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)Elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)Elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)Elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)Elementary_functions.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)Output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)Output_stream.lib" 1>NUL 2>NUL" Description="Build dependencies"/> + <Tool Name="VFPostBuildEventTool"/> + <Tool Name="VFManifestTool" SuppressStartupBanner="true"/></Configuration></Configurations> + <Files> + <Filter Name="Header Files" Filter="fi;fd"/> + <Filter Name="Library Dependencies"> + <File RelativePath=".\core_import.def"/> + <File RelativePath=".\Elementary_functions_f_Import.def"/> + <File RelativePath=".\Elementary_functions_Import.def"/> + <File RelativePath=".\Output_stream_Import.def"/></Filter> + <Filter Name="Resource Files" Filter="rc;ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe"> + <File RelativePath=".\slatec_f.rc"/></Filter> + <Filter Name="Source Files" Filter="f90;for;f;fpp;ftn;def;odl;idl"> + <File RelativePath=".\balanc.f"/> + <File RelativePath="d9b0mp.f"/> + <File RelativePath="d9b1mp.f"/> + <File RelativePath="d9knus.f"/> + <File RelativePath="d9lgmc.f"/> + <File RelativePath="dasyik.f"/> + <File RelativePath="dasyjy.f"/> + <File RelativePath="dbdiff.f"/> + <File RelativePath="dbesi.f"/> + <File RelativePath="dbesi0.f"/> + <File RelativePath="dbesi1.f"/> + <File RelativePath="dbesj.f"/> + <File RelativePath="dbesj0.f"/> + <File RelativePath="dbesj1.f"/> + <File RelativePath="dbesk.f"/> + <File RelativePath="dbesk0.f"/> + <File RelativePath="dbesk1.f"/> + <File RelativePath="dbesy.f"/> + <File RelativePath="dbesy0.f"/> + <File RelativePath="dbesy1.f"/> + <File RelativePath="dbkias.f"/> + <File RelativePath="dbkisr.f"/> + <File RelativePath="dbsi0e.f"/> + <File RelativePath="dbsi1e.f"/> + <File RelativePath="dbsk0e.f"/> + <File RelativePath="dbsk1e.f"/> + <File RelativePath="dbskes.f"/> + <File RelativePath="dbskin.f"/> + <File RelativePath="dbsknu.f"/> + <File RelativePath="dbsynu.f"/> + <File RelativePath="dcsevl.f"/> + <File RelativePath="dexint.f"/> + <File RelativePath="dgamlm.f"/> + <File RelativePath="dgamln.f"/> + <File RelativePath="dgamma.f"/> + <File RelativePath="dgamrn.f"/> + <File RelativePath="dhkseq.f"/> + <File RelativePath="djairy.f"/> + <File RelativePath="dlngam.f"/> + <File RelativePath="dpsixn.f"/> + <File RelativePath=".\dtensbs.f"/> + <File RelativePath="dxlegf.f"/> + <File RelativePath="dyairy.f"/> + <File RelativePath="fdump.f"/> + <File RelativePath="gamma.f"/> + <File RelativePath="initds.f"/> + <File RelativePath="j4save.f"/> + <File RelativePath=".\pchim.f"/> + <File RelativePath="xercnt.f"/> + <File RelativePath="xermsg.f"/> + <File RelativePath="xerprn.f"/> + <File RelativePath="xersve.f"/> + <File RelativePath="xgetua.f"/> + <File RelativePath="zabs.f"/> + <File RelativePath="zacai.f"/> + <File RelativePath="zacon.f"/> + <File RelativePath="zairy.f"/> + <File RelativePath="zasyi.f"/> + <File RelativePath="zbesh.f"/> + <File RelativePath="zbesi.f"/> + <File RelativePath="zbesj.f"/> + <File RelativePath="zbesk.f"/> + <File RelativePath="zbesy.f"/> + <File RelativePath="zbinu.f"/> + <File RelativePath="zbknu.f"/> + <File RelativePath="zbuni.f"/> + <File RelativePath="zbunk.f"/> + <File RelativePath="zdiv.f"/> + <File RelativePath="zexp.f"/> + <File RelativePath="zkscl.f"/> + <File RelativePath="zlog.f"/> + <File RelativePath="zmlri.f"/> + <File RelativePath="zmlt.f"/> + <File RelativePath="zrati.f"/> + <File RelativePath="zs1s2.f"/> + <File RelativePath="zseri.f"/> + <File RelativePath="zshch.f"/> + <File RelativePath="zsqrt.f"/> + <File RelativePath="zuchk.f"/> + <File RelativePath="zunhj.f"/> + <File RelativePath="zuni1.f"/> + <File RelativePath="zuni2.f"/> + <File RelativePath="zunik.f"/> + <File RelativePath="zunk1.f"/> + <File RelativePath="zunk2.f"/> + <File RelativePath="zuoik.f"/> + <File RelativePath="zwrsk.f"/></Filter></Files> + <Globals/></VisualStudioProject> diff --git a/modules/elementary_functions/src/fortran/slatec/slatec_f2c.vcxproj b/modules/elementary_functions/src/fortran/slatec/slatec_f2c.vcxproj new file mode 100755 index 000000000..ffa4f4433 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/slatec_f2c.vcxproj @@ -0,0 +1,457 @@ +<?xml version="1.0" encoding="utf-8"?> +<Project DefaultTargets="Build" ToolsVersion="4.0" xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <ItemGroup Label="ProjectConfigurations"> + <ProjectConfiguration Include="Debug|Win32"> + <Configuration>Debug</Configuration> + <Platform>Win32</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Debug|x64"> + <Configuration>Debug</Configuration> + <Platform>x64</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Release|Win32"> + <Configuration>Release</Configuration> + <Platform>Win32</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Release|x64"> + <Configuration>Release</Configuration> + <Platform>x64</Platform> + </ProjectConfiguration> + </ItemGroup> + <PropertyGroup Label="Globals"> + <ProjectName>slatec_f</ProjectName> + <ProjectGuid>{EAF0949C-28D2-497C-954F-FC13B32FF2F3}</ProjectGuid> + <RootNamespace>slatec_f2c</RootNamespace> + <Keyword>Win32Proj</Keyword> + </PropertyGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.Default.props" /> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>Unicode</CharacterSet> + <WholeProgramOptimization>true</WholeProgramOptimization> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>Unicode</CharacterSet> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>Unicode</CharacterSet> + <WholeProgramOptimization>true</WholeProgramOptimization> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>Unicode</CharacterSet> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.props" /> + <ImportGroup Label="ExtensionSettings"> + <Import Project="..\..\..\..\..\Visual-Studio-settings\f2c.props" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <PropertyGroup Label="UserMacros" /> + <PropertyGroup> + <_ProjectFileVersion>10.0.30319.1</_ProjectFileVersion> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">true</LinkIncremental> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">true</LinkIncremental> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">false</LinkIncremental> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Release|x64'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Release|x64'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Release|x64'">false</LinkIncremental> + </PropertyGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'"> + <PreBuildEvent> + <Message>Build core.lib (dependencies)</Message> + <Command>lib /DEF:"$(ProjectDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)Elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)Elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)Elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)Elementary_functions.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)Output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)Output_stream.lib" 1>NUL 2>NUL +</Command> + </PreBuildEvent> + <ClCompile> + <Optimization>Disabled</Optimization> + <AdditionalIncludeDirectories>../../../../../libs/f2c;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>WIN32;_DEBUG;_WINDOWS;_USRDLL;SLATEC_F2C_EXPORTS;FORDLL;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDebugDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + </ClCompile> + <PreLinkEvent> + <Message>Build $(ProjectName).def</Message> + <Command>setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .. +</Command> + </PreLinkEvent> + <Link> + <AdditionalOptions>/ignore:4049 %(AdditionalOptions)</AdditionalOptions> + <AdditionalDependencies>core.lib;elementary_functions_f.lib;elementary_functions.lib;output_stream.lib;../../../../../bin/lapack.lib;../../../../../bin/libf2c.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <ModuleDefinitionFile>slatec_f.def</ModuleDefinitionFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX86</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + <LinkTimeCodeGeneration>Default</LinkTimeCodeGeneration> + </Link> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'"> + <PreBuildEvent> + <Message>Build core.lib (dependencies)</Message> + <Command>lib /DEF:"$(ProjectDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)Elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)Elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)Elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)Elementary_functions.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)Output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)Output_stream.lib" 1>NUL 2>NUL +</Command> + </PreBuildEvent> + <Midl> + <TargetEnvironment>X64</TargetEnvironment> + </Midl> + <ClCompile> + <Optimization>Disabled</Optimization> + <AdditionalIncludeDirectories>../../../../../libs/f2c;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>WIN32;_DEBUG;_WINDOWS;_USRDLL;SLATEC_F2C_EXPORTS;FORDLL;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDebugDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + </ClCompile> + <PreLinkEvent> + <Message>Build $(ProjectName).def</Message> + <Command>setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .. +</Command> + </PreLinkEvent> + <Link> + <AdditionalOptions>/ignore:4049 %(AdditionalOptions)</AdditionalOptions> + <AdditionalDependencies>core.lib;elementary_functions_f.lib;elementary_functions.lib;output_stream.lib;../../../../../bin/lapack.lib;../../../../../bin/libf2c.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <ModuleDefinitionFile>slatec_f.def</ModuleDefinitionFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX64</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + <LinkTimeCodeGeneration>Default</LinkTimeCodeGeneration> + </Link> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'"> + <PreBuildEvent> + <Message>Build core.lib (dependencies)</Message> + <Command>lib /DEF:"$(ProjectDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)Elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)Elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)Elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)Elementary_functions.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)Output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)Output_stream.lib" 1>NUL 2>NUL +</Command> + </PreBuildEvent> + <ClCompile> + <WholeProgramOptimization>false</WholeProgramOptimization> + <AdditionalIncludeDirectories>../../../../../libs/f2c;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>WIN32;NDEBUG;_WINDOWS;_USRDLL;SLATEC_F2C_EXPORTS;FORDLL;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + <MultiProcessorCompilation>true</MultiProcessorCompilation> + </ClCompile> + <PreLinkEvent> + <Message>Build $(ProjectName).def</Message> + <Command>setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .. +</Command> + </PreLinkEvent> + <Link> + <AdditionalOptions>/ignore:4049 %(AdditionalOptions)</AdditionalOptions> + <AdditionalDependencies>core.lib;elementary_functions_f.lib;elementary_functions.lib;output_stream.lib;../../../../../bin/lapack.lib;../../../../../bin/libf2c.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <ModuleDefinitionFile>slatec_f.def</ModuleDefinitionFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <OptimizeReferences>true</OptimizeReferences> + <EnableCOMDATFolding>true</EnableCOMDATFolding> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX86</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + <LinkTimeCodeGeneration>Default</LinkTimeCodeGeneration> + </Link> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'"> + <PreBuildEvent> + <Message>Build core.lib (dependencies)</Message> + <Command>lib /DEF:"$(ProjectDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)Elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)Elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)Elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)Elementary_functions.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)Output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)Output_stream.lib" 1>NUL 2>NUL +</Command> + </PreBuildEvent> + <Midl> + <TargetEnvironment>X64</TargetEnvironment> + </Midl> + <ClCompile> + <WholeProgramOptimization>false</WholeProgramOptimization> + <AdditionalIncludeDirectories>../../../../../libs/f2c;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>WIN32;NDEBUG;_WINDOWS;_USRDLL;SLATEC_F2C_EXPORTS;FORDLL;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + <MultiProcessorCompilation>true</MultiProcessorCompilation> + </ClCompile> + <PreLinkEvent> + <Message>Build $(ProjectName).def</Message> + <Command>setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .. +</Command> + </PreLinkEvent> + <Link> + <AdditionalOptions>/ignore:4049 %(AdditionalOptions)</AdditionalOptions> + <AdditionalDependencies>core.lib;elementary_functions_f.lib;elementary_functions.lib;output_stream.lib;../../../../../bin/lapack.lib;../../../../../bin/libf2c.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <ModuleDefinitionFile>slatec_f.def</ModuleDefinitionFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <OptimizeReferences>true</OptimizeReferences> + <EnableCOMDATFolding>true</EnableCOMDATFolding> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX64</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + <LinkTimeCodeGeneration>Default</LinkTimeCodeGeneration> + </Link> + </ItemDefinitionGroup> + <ItemGroup> + <ClCompile Include="balanc.c" /> + <ClCompile Include="common_f2c.c" /> + <ClCompile Include="d9b0mp.c" /> + <ClCompile Include="d9b1mp.c" /> + <ClCompile Include="d9knus.c" /> + <ClCompile Include="d9lgmc.c" /> + <ClCompile Include="dasyik.c" /> + <ClCompile Include="dasyjy.c" /> + <ClCompile Include="dbdiff.c" /> + <ClCompile Include="dbesi.c" /> + <ClCompile Include="dbesi0.c" /> + <ClCompile Include="dbesi1.c" /> + <ClCompile Include="dbesj.c" /> + <ClCompile Include="dbesj0.c" /> + <ClCompile Include="dbesj1.c" /> + <ClCompile Include="dbesk.c" /> + <ClCompile Include="dbesk0.c" /> + <ClCompile Include="dbesk1.c" /> + <ClCompile Include="dbesy.c" /> + <ClCompile Include="dbesy0.c" /> + <ClCompile Include="dbesy1.c" /> + <ClCompile Include="dbkias.c" /> + <ClCompile Include="dbkisr.c" /> + <ClCompile Include="dbsi0e.c" /> + <ClCompile Include="dbsi1e.c" /> + <ClCompile Include="dbsk0e.c" /> + <ClCompile Include="dbsk1e.c" /> + <ClCompile Include="dbskes.c" /> + <ClCompile Include="dbskin.c" /> + <ClCompile Include="dbsknu.c" /> + <ClCompile Include="dbsynu.c" /> + <ClCompile Include="dcsevl.c" /> + <ClCompile Include="dexint.c" /> + <ClCompile Include="dgamlm.c" /> + <ClCompile Include="dgamln.c" /> + <ClCompile Include="dgamma.c" /> + <ClCompile Include="dgamrn.c" /> + <ClCompile Include="dhkseq.c" /> + <ClCompile Include="djairy.c" /> + <ClCompile Include="dlngam.c" /> + <ClCompile Include="dpsixn.c" /> + <ClCompile Include="dtensbs.c" /> + <ClCompile Include="dxlegf.c" /> + <ClCompile Include="dyairy.c" /> + <ClCompile Include="fdump.c" /> + <ClCompile Include="gamma.c" /> + <ClCompile Include="initds.c" /> + <ClCompile Include="j4save.c" /> + <ClCompile Include="pchim.c" /> + <ClCompile Include="xercnt.c" /> + <ClCompile Include="xermsg.c" /> + <ClCompile Include="xerprn.c" /> + <ClCompile Include="xersve.c" /> + <ClCompile Include="xgetua.c" /> + <ClCompile Include="zabs.c" /> + <ClCompile Include="zacai.c" /> + <ClCompile Include="zacon.c" /> + <ClCompile Include="zairy.c" /> + <ClCompile Include="zasyi.c" /> + <ClCompile Include="zbesh.c" /> + <ClCompile Include="zbesi.c" /> + <ClCompile Include="zbesj.c" /> + <ClCompile Include="zbesk.c" /> + <ClCompile Include="zbesy.c" /> + <ClCompile Include="zbinu.c" /> + <ClCompile Include="zbknu.c" /> + <ClCompile Include="zbuni.c" /> + <ClCompile Include="zbunk.c" /> + <ClCompile Include="zdiv.c" /> + <ClCompile Include="zexp.c" /> + <ClCompile Include="zkscl.c" /> + <ClCompile Include="zlog.c" /> + <ClCompile Include="zmlri.c" /> + <ClCompile Include="zmlt.c" /> + <ClCompile Include="zrati.c" /> + <ClCompile Include="zs1s2.c" /> + <ClCompile Include="zseri.c" /> + <ClCompile Include="zshch.c" /> + <ClCompile Include="zsqrt.c" /> + <ClCompile Include="zuchk.c" /> + <ClCompile Include="zunhj.c" /> + <ClCompile Include="zuni1.c" /> + <ClCompile Include="zuni2.c" /> + <ClCompile Include="zunik.c" /> + <ClCompile Include="zunk1.c" /> + <ClCompile Include="zunk2.c" /> + <ClCompile Include="zuoik.c" /> + <ClCompile Include="zwrsk.c" /> + </ItemGroup> + <ItemGroup> + <f2c_rule Include="balanc.f" /> + <f2c_rule Include="d9b0mp.f" /> + <f2c_rule Include="d9b1mp.f" /> + <f2c_rule Include="d9knus.f" /> + <f2c_rule Include="d9lgmc.f" /> + <f2c_rule Include="dasyik.f" /> + <f2c_rule Include="dasyjy.f" /> + <f2c_rule Include="dbdiff.f" /> + <f2c_rule Include="dbesi.f" /> + <f2c_rule Include="dbesi0.f" /> + <f2c_rule Include="dbesi1.f" /> + <f2c_rule Include="dbesj.f" /> + <f2c_rule Include="dbesj0.f" /> + <f2c_rule Include="dbesj1.f" /> + <f2c_rule Include="dbesk.f" /> + <f2c_rule Include="dbesk0.f" /> + <f2c_rule Include="dbesk1.f" /> + <f2c_rule Include="dbesy.f" /> + <f2c_rule Include="dbesy0.f" /> + <f2c_rule Include="dbesy1.f" /> + <f2c_rule Include="dbkias.f" /> + <f2c_rule Include="dbkisr.f" /> + <f2c_rule Include="dbsi0e.f" /> + <f2c_rule Include="dbsi1e.f" /> + <f2c_rule Include="dbsk0e.f" /> + <f2c_rule Include="dbsk1e.f" /> + <f2c_rule Include="dbskes.f" /> + <f2c_rule Include="dbskin.f" /> + <f2c_rule Include="dbsknu.f" /> + <f2c_rule Include="dbsynu.f" /> + <f2c_rule Include="dcsevl.f" /> + <f2c_rule Include="dexint.f" /> + <f2c_rule Include="dgamlm.f" /> + <f2c_rule Include="dgamln.f" /> + <f2c_rule Include="dgamma.f" /> + <f2c_rule Include="dgamrn.f" /> + <f2c_rule Include="dhkseq.f" /> + <f2c_rule Include="djairy.f" /> + <f2c_rule Include="dlngam.f" /> + <f2c_rule Include="dpsixn.f" /> + <f2c_rule Include="dtensbs.f" /> + <f2c_rule Include="dxlegf.f" /> + <f2c_rule Include="dyairy.f" /> + <f2c_rule Include="fdump.f" /> + <f2c_rule Include="gamma.f" /> + <f2c_rule Include="initds.f" /> + <f2c_rule Include="j4save.f" /> + <f2c_rule Include="pchim.f" /> + <f2c_rule Include="xercnt.f" /> + <f2c_rule Include="xermsg.f" /> + <f2c_rule Include="xerprn.f" /> + <f2c_rule Include="xersve.f" /> + <f2c_rule Include="xgetua.f" /> + <f2c_rule Include="zabs.f" /> + <f2c_rule Include="zacai.f" /> + <f2c_rule Include="zacon.f" /> + <f2c_rule Include="zairy.f" /> + <f2c_rule Include="zasyi.f" /> + <f2c_rule Include="zbesh.f" /> + <f2c_rule Include="zbesi.f" /> + <f2c_rule Include="zbesj.f" /> + <f2c_rule Include="zbesk.f" /> + <f2c_rule Include="zbesy.f" /> + <f2c_rule Include="zbinu.f" /> + <f2c_rule Include="zbknu.f" /> + <f2c_rule Include="zbuni.f" /> + <f2c_rule Include="zbunk.f" /> + <f2c_rule Include="zdiv.f" /> + <f2c_rule Include="zexp.f" /> + <f2c_rule Include="zkscl.f" /> + <f2c_rule Include="zlog.f" /> + <f2c_rule Include="zmlri.f" /> + <f2c_rule Include="zmlt.f" /> + <f2c_rule Include="zrati.f" /> + <f2c_rule Include="zs1s2.f" /> + <f2c_rule Include="zseri.f" /> + <f2c_rule Include="zshch.f" /> + <f2c_rule Include="zsqrt.f" /> + <f2c_rule Include="zuchk.f" /> + <f2c_rule Include="zunhj.f" /> + <f2c_rule Include="zuni1.f" /> + <f2c_rule Include="zuni2.f" /> + <f2c_rule Include="zunik.f" /> + <f2c_rule Include="zunk1.f" /> + <f2c_rule Include="zunk2.f" /> + <f2c_rule Include="zuoik.f" /> + <f2c_rule Include="zwrsk.f" /> + </ItemGroup> + <ItemGroup> + <ProjectReference Include="..\..\..\..\..\tools\Dumpexts\Dumpexts.vcxproj"> + <Project>{3170e4c2-1173-4264-a222-7ee8ccb3ddf7}</Project> + <ReferenceOutputAssembly>false</ReferenceOutputAssembly> + </ProjectReference> + </ItemGroup> + <ItemGroup> + <None Include="Elementary_functions_f_Import.def" /> + <None Include="Elementary_functions_Import.def" /> + <None Include="core_import.def" /> + <None Include="Output_stream_Import.def" /> + </ItemGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.targets" /> + <ImportGroup Label="ExtensionTargets"> + <Import Project="..\..\..\..\..\Visual-Studio-settings\f2c.targets" /> + </ImportGroup> +</Project>
\ No newline at end of file diff --git a/modules/elementary_functions/src/fortran/slatec/slatec_f2c.vcxproj.filters b/modules/elementary_functions/src/fortran/slatec/slatec_f2c.vcxproj.filters new file mode 100755 index 000000000..32d47a45c --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/slatec_f2c.vcxproj.filters @@ -0,0 +1,566 @@ +<?xml version="1.0" encoding="utf-8"?> +<Project ToolsVersion="4.0" xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <ItemGroup> + <Filter Include="Source Files"> + <UniqueIdentifier>{4FC737F1-C7A5-4376-A066-2A32D752A2FF}</UniqueIdentifier> + <Extensions>cpp;c;cc;cxx;def;odl;idl;hpj;bat;asm;asmx</Extensions> + </Filter> + <Filter Include="Header Files"> + <UniqueIdentifier>{93995380-89BD-4b04-88EB-625FBE52EBFB}</UniqueIdentifier> + <Extensions>h;hpp;hxx;hm;inl;inc;xsd</Extensions> + </Filter> + <Filter Include="Resource Files"> + <UniqueIdentifier>{67DA6AB6-F800-4c08-8B7A-83BB121AAD01}</UniqueIdentifier> + <Extensions>rc;ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe;resx;tiff;tif;png;wav</Extensions> + </Filter> + <Filter Include="Fortran Files"> + <UniqueIdentifier>{7dd1223c-31ad-4a51-a8be-fe39aaa3d3cc}</UniqueIdentifier> + </Filter> + <Filter Include="Libraries Dependencies"> + <UniqueIdentifier>{40bb1e28-08a9-4709-8544-1d4e4d6f98aa}</UniqueIdentifier> + </Filter> + </ItemGroup> + <ItemGroup> + <ClCompile Include="balanc.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="common_f2c.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="d9b0mp.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="d9b1mp.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="d9knus.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="d9lgmc.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dasyik.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dasyjy.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dbdiff.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dbesi.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dbesi0.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dbesi1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dbesj.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dbesj0.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dbesj1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dbesk.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dbesk0.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dbesk1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dbesy.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dbesy0.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dbesy1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dbkias.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dbkisr.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dbsi0e.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dbsi1e.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dbsk0e.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dbsk1e.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dbskes.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dbskin.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dbsknu.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dbsynu.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dcsevl.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dexint.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dgamlm.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dgamln.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dgamma.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dgamrn.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dhkseq.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="djairy.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dlngam.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dpsixn.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dtensbs.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dxlegf.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dyairy.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="fdump.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="gamma.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="initds.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="j4save.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="pchim.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="xercnt.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="xermsg.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="xerprn.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="xersve.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="xgetua.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zabs.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zacai.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zacon.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zairy.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zasyi.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zbesh.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zbesi.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zbesj.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zbesk.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zbesy.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zbinu.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zbknu.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zbuni.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zbunk.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zdiv.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zexp.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zkscl.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zlog.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zmlri.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zmlt.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zrati.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zs1s2.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zseri.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zshch.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zsqrt.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zuchk.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zunhj.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zuni1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zuni2.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zunik.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zunk1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zunk2.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zuoik.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zwrsk.c"> + <Filter>Source Files</Filter> + </ClCompile> + </ItemGroup> + <ItemGroup> + <f2c_rule Include="balanc.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="d9b0mp.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="d9b1mp.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="d9knus.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="d9lgmc.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dasyik.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dasyjy.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dbdiff.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dbesi.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dbesi0.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dbesi1.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dbesj.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dbesj0.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dbesj1.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dbesk.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dbesk0.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dbesk1.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dbesy.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dbesy0.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dbesy1.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dbkias.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dbkisr.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dbsi0e.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dbsi1e.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dbsk0e.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dbsk1e.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dbskes.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dbskin.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dbsknu.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dbsynu.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dcsevl.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dexint.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dgamlm.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dgamln.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dgamma.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dgamrn.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dhkseq.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="djairy.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dlngam.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dpsixn.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dtensbs.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dxlegf.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="dyairy.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="fdump.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="gamma.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="initds.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="j4save.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="pchim.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="xercnt.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="xermsg.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="xerprn.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="xersve.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="xgetua.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zabs.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zacai.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zacon.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zairy.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zasyi.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zbesh.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zbesi.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zbesj.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zbesk.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zbesy.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zbinu.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zbknu.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zbuni.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zbunk.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zdiv.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zexp.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zkscl.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zlog.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zmlri.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zmlt.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zrati.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zs1s2.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zseri.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zshch.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zsqrt.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zuchk.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zunhj.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zuni1.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zuni2.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zunik.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zunk1.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zunk2.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zuoik.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + <f2c_rule Include="zwrsk.f"> + <Filter>Fortran Files</Filter> + </f2c_rule> + </ItemGroup> + <ItemGroup> + <None Include="Elementary_functions_f_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="Elementary_functions_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="core_import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="Output_stream_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + </ItemGroup> +</Project>
\ No newline at end of file diff --git a/modules/elementary_functions/src/fortran/slatec/xercnt.f b/modules/elementary_functions/src/fortran/slatec/xercnt.f new file mode 100755 index 000000000..06c82ab18 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/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/modules/elementary_functions/src/fortran/slatec/xercnt.lo b/modules/elementary_functions/src/fortran/slatec/xercnt.lo new file mode 100755 index 000000000..d1f74ef01 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/xercnt.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/xercnt.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/xercnt.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/xermsg.f b/modules/elementary_functions/src/fortran/slatec/xermsg.f new file mode 100755 index 000000000..46c83ec07 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/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/modules/elementary_functions/src/fortran/slatec/xermsg.lo b/modules/elementary_functions/src/fortran/slatec/xermsg.lo new file mode 100755 index 000000000..88f8469bf --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/xermsg.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/xermsg.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/xermsg.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/xerprn.f b/modules/elementary_functions/src/fortran/slatec/xerprn.f new file mode 100755 index 000000000..f78379bd0 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/xerprn.f @@ -0,0 +1,233 @@ +*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 + include 'stack.h' + 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) = ' ' +C THREE NEXT LINES REPLACED FOR SCILAB INTERFACE +CSTD DO 40 I=1,NUNIT +CSTD WRITE(IU(I), '(A)') CBUFF(1:LPREF+1) +CSTD 40 CONTINUE + CALL BASOUT(IO,WTE,CBUFF(1:LPREF+1)) + 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 +C THREE NEXT LINES REPLACED FOR SCILAB INTERFACE +CSTD DO 60 I=1,NUNIT +CSTD WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE) +CSTD 60 CONTINUE + CALL BASOUT(IO,WTE,CBUFF(1:LPREF+LPIECE)) +C + IF (NEXTC .LE. LENMSG) GO TO 50 + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/xerprn.lo b/modules/elementary_functions/src/fortran/slatec/xerprn.lo new file mode 100755 index 000000000..f1afa6023 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/xerprn.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/xerprn.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/xerprn.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/xersve.f b/modules/elementary_functions/src/fortran/slatec/xersve.f new file mode 100755 index 000000000..f525687c3 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/xersve.f @@ -0,0 +1,172 @@ +*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 + include 'stack.h' + PARAMETER (LENTAB=10) + + CHARACTER*(*) LIBRAR, SUBROU, MESSG + CHARACTER*8 LIBTAB(LENTAB), SUBTAB(LENTAB), LIB, SUB + CHARACTER*20 MESTAB(LENTAB), MES + CHARACTER*148 CBUFF + 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 BASOUT(IO,WTE,'0 ERROR MESSAGE SUMMARY') + CALL BASOUT(IO,WTE, + + ' LIBRARY SUBROUTINE MESSAGE START NERR'// + + ' LEVEL COUNT') + DO 10 I = 1,NMSG + WRITE (CBUFF,9010) LIBTAB(I), SUBTAB(I), MESTAB(I), + * NERTAB(I),LEVTAB(I),KOUNT(I) + CALL BASOUT(IO,WTE,CBUFF) + 10 CONTINUE + IF (KOUNTX.NE.0) then + WRITE (CBUFF,9020) KOUNTX + CALL BASOUT(IO,WTE,CBUFF) + ENDIF + CALL BASOUT(IO,WTE,' ') + +CSTD CALL XGETUA (LUN, NUNIT) +CSTD DO 20 KUNIT = 1,NUNIT +CSTD IUNIT = LUN(KUNIT) +CSTD IF (IUNIT.EQ.0) IUNIT = I1MACH(4) +CSTDC +CSTDC Print the table header. +CSTDC +CSTD WRITE (IUNIT,9000) +CSTDC +CSTDC Print body of table. +CSTDC +CSTD DO 10 I = 1,NMSG +CSTD WRITE (IUNIT,9010) LIBTAB(I), SUBTAB(I), MESTAB(I), +CSTD * NERTAB(I),LEVTAB(I),KOUNT(I) +CSTD 10 CONTINUE +CSTDC +CSTDC Print number of other errors. +CSTDC +CSTD IF (KOUNTX.NE.0) WRITE (IUNIT,9020) KOUNTX +CSTD WRITE (IUNIT,9030) +CSTD 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/modules/elementary_functions/src/fortran/slatec/xersve.lo b/modules/elementary_functions/src/fortran/slatec/xersve.lo new file mode 100755 index 000000000..2bc7ff3f7 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/xersve.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/xersve.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/xersve.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/xgetua.f b/modules/elementary_functions/src/fortran/slatec/xgetua.f new file mode 100755 index 000000000..2e7db0212 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/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/modules/elementary_functions/src/fortran/slatec/xgetua.lo b/modules/elementary_functions/src/fortran/slatec/xgetua.lo new file mode 100755 index 000000000..414a836c2 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/xgetua.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/xgetua.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/xgetua.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zabs.f b/modules/elementary_functions/src/fortran/slatec/zabs.f new file mode 100755 index 000000000..67a615385 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zabs.f @@ -0,0 +1,41 @@ +*DECK ZABS + DOUBLE PRECISION FUNCTION ZABS (ZR, ZI) +C***BEGIN PROLOGUE ZABS +C***SUBSIDIARY +C***PURPOSE Subsidiary to ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZAIRY and +C ZBIRY +C***LIBRARY SLATEC +C***TYPE ALL (ZABS-A) +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C ZABS COMPUTES THE ABSOLUTE VALUE OR MAGNITUDE OF A DOUBLE +C PRECISION COMPLEX VARIABLE CMPLX(ZR,ZI) +C +C***SEE ALSO ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZBIRY +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 910415 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE ZABS + DOUBLE PRECISION ZR, ZI, U, V, Q, S +C***FIRST EXECUTABLE STATEMENT ZABS + U = ABS(ZR) + V = ABS(ZI) + S = U + V +C----------------------------------------------------------------------- +C S*1.0D0 MAKES AN UNNORMALIZED UNDERFLOW ON CDC MACHINES INTO A +C TRUE FLOATING ZERO +C----------------------------------------------------------------------- + S = S*1.0D+0 + IF (S.EQ.0.0D+0) GO TO 20 + IF (U.GT.V) GO TO 10 + Q = U/V + ZABS = V*SQRT(1.D+0+Q*Q) + RETURN + 10 Q = V/U + ZABS = U*SQRT(1.D+0+Q*Q) + RETURN + 20 ZABS = 0.0D+0 + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zabs.lo b/modules/elementary_functions/src/fortran/slatec/zabs.lo new file mode 100755 index 000000000..d40694c20 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zabs.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zabs.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zabs.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zacai.f b/modules/elementary_functions/src/fortran/slatec/zacai.f new file mode 100755 index 000000000..05208a714 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zacai.f @@ -0,0 +1,111 @@ +*DECK ZACAI + SUBROUTINE ZACAI (ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, RL, TOL, + + ELIM, ALIM) +C***BEGIN PROLOGUE ZACAI +C***SUBSIDIARY +C***PURPOSE Subsidiary to ZAIRY +C***LIBRARY SLATEC +C***TYPE ALL (CACAI-A, ZACAI-A) +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C ZACAI APPLIES THE ANALYTIC CONTINUATION FORMULA +C +C K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) +C MP=PI*MR*CMPLX(0.0,1.0) +C +C TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT +C HALF Z PLANE FOR USE WITH ZAIRY WHERE FNU=1/3 OR 2/3 AND N=1. +C ZACAI IS THE SAME AS ZACON WITH THE PARTS FOR LARGER ORDERS AND +C RECURRENCE REMOVED. A RECURSIVE CALL TO ZACON CAN RESULT IF ZACON +C IS CALLED FROM ZAIRY. +C +C***SEE ALSO ZAIRY +C***ROUTINES CALLED D1MACH, ZABS, ZASYI, ZBKNU, ZMLRI, ZS1S2, ZSERI +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 910415 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE ZACAI +C COMPLEX CSGN,CSPN,C1,C2,Y,Z,ZN,CY + DOUBLE PRECISION ALIM, ARG, ASCLE, AZ, CSGNR, CSGNI, CSPNR, + * CSPNI, C1R, C1I, C2R, C2I, CYR, CYI, DFNU, ELIM, FMR, FNU, PI, + * RL, SGN, TOL, YY, YR, YI, ZR, ZI, ZNR, ZNI, D1MACH, ZABS + INTEGER INU, IUF, KODE, MR, N, NN, NW, NZ + DIMENSION YR(N), YI(N), CYR(2), CYI(2) + EXTERNAL ZABS + DATA PI / 3.14159265358979324D0 / +C***FIRST EXECUTABLE STATEMENT ZACAI + NZ = 0 + ZNR = -ZR + ZNI = -ZI + AZ = ZABS(ZR,ZI) + NN = N + DFNU = FNU + (N-1) + IF (AZ.LE.2.0D0) GO TO 10 + IF (AZ*AZ*0.25D0.GT.DFNU+1.0D0) GO TO 20 + 10 CONTINUE +C----------------------------------------------------------------------- +C POWER SERIES FOR THE I FUNCTION +C----------------------------------------------------------------------- + CALL ZSERI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, TOL, ELIM, ALIM) + GO TO 40 + 20 CONTINUE + IF (AZ.LT.RL) GO TO 30 +C----------------------------------------------------------------------- +C ASYMPTOTIC EXPANSION FOR LARGE Z FOR THE I FUNCTION +C----------------------------------------------------------------------- + CALL ZASYI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, RL, TOL, ELIM, + * ALIM) + IF (NW.LT.0) GO TO 80 + GO TO 40 + 30 CONTINUE +C----------------------------------------------------------------------- +C MILLER ALGORITHM NORMALIZED BY THE SERIES FOR THE I FUNCTION +C----------------------------------------------------------------------- + CALL ZMLRI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, TOL) + IF(NW.LT.0) GO TO 80 + 40 CONTINUE +C----------------------------------------------------------------------- +C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION +C----------------------------------------------------------------------- + CALL ZBKNU(ZNR, ZNI, FNU, KODE, 1, CYR, CYI, NW, TOL, ELIM, ALIM) + IF (NW.NE.0) GO TO 80 + FMR = MR + SGN = -DSIGN(PI,FMR) + CSGNR = 0.0D0 + CSGNI = SGN + IF (KODE.EQ.1) GO TO 50 + YY = -ZNI + CSGNR = -CSGNI*SIN(YY) + CSGNI = CSGNI*COS(YY) + 50 CONTINUE +C----------------------------------------------------------------------- +C CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE +C WHEN FNU IS LARGE +C----------------------------------------------------------------------- + INU = FNU + ARG = (FNU-INU)*SGN + CSPNR = COS(ARG) + CSPNI = SIN(ARG) + IF (MOD(INU,2).EQ.0) GO TO 60 + CSPNR = -CSPNR + CSPNI = -CSPNI + 60 CONTINUE + C1R = CYR(1) + C1I = CYI(1) + C2R = YR(1) + C2I = YI(1) + IF (KODE.EQ.1) GO TO 70 + IUF = 0 + ASCLE = 1.0D+3*D1MACH(1)/TOL + CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) + NZ = NZ + NW + 70 CONTINUE + YR(1) = CSPNR*C1R - CSPNI*C1I + CSGNR*C2R - CSGNI*C2I + YI(1) = CSPNR*C1I + CSPNI*C1R + CSGNR*C2I + CSGNI*C2R + RETURN + 80 CONTINUE + NZ = -1 + IF(NW.EQ.(-2)) NZ=-2 + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zacai.lo b/modules/elementary_functions/src/fortran/slatec/zacai.lo new file mode 100755 index 000000000..5b10665ff --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zacai.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zacai.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zacai.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zacon.f b/modules/elementary_functions/src/fortran/slatec/zacon.f new file mode 100755 index 000000000..6c2450a8a --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zacon.f @@ -0,0 +1,215 @@ +*DECK ZACON + SUBROUTINE ZACON (ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, RL, FNUL, + + TOL, ELIM, ALIM) +C***BEGIN PROLOGUE ZACON +C***SUBSIDIARY +C***PURPOSE Subsidiary to ZBESH and ZBESK +C***LIBRARY SLATEC +C***TYPE ALL (CACON-A, ZACON-A) +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C ZACON APPLIES THE ANALYTIC CONTINUATION FORMULA +C +C K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) +C MP=PI*MR*CMPLX(0.0,1.0) +C +C TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT +C HALF Z PLANE +C +C***SEE ALSO ZBESH, ZBESK +C***ROUTINES CALLED D1MACH, ZABS, ZBINU, ZBKNU, ZMLT, ZS1S2 +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 910415 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE ZACON +C COMPLEX CK,CONE,CSCL,CSCR,CSGN,CSPN,CY,CZERO,C1,C2,RZ,SC1,SC2,ST, +C *S1,S2,Y,Z,ZN + DOUBLE PRECISION ALIM, ARG, ASCLE, AS2, AZN, BRY, BSCLE, CKI, + * CKR, CONER, CPN, CSCL, CSCR, CSGNI, CSGNR, CSPNI, CSPNR, + * CSR, CSRR, CSSR, CYI, CYR, C1I, C1M, C1R, C2I, C2R, ELIM, FMR, + * FN, FNU, FNUL, PI, PTI, PTR, RAZN, RL, RZI, RZR, SC1I, SC1R, + * SC2I, SC2R, SGN, SPN, STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, + * YY, ZEROR, ZI, ZNI, ZNR, ZR, D1MACH, ZABS + INTEGER I, INU, IUF, KFLAG, KODE, MR, N, NN, NW, NZ + DIMENSION YR(N), YI(N), CYR(2), CYI(2), CSSR(3), CSRR(3), BRY(3) + EXTERNAL ZABS + DATA PI / 3.14159265358979324D0 / + DATA ZEROR,CONER / 0.0D0,1.0D0 / +C***FIRST EXECUTABLE STATEMENT ZACON + NZ = 0 + ZNR = -ZR + ZNI = -ZI + NN = N + CALL ZBINU(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, RL, FNUL, TOL, + * ELIM, ALIM) + IF (NW.LT.0) GO TO 90 +C----------------------------------------------------------------------- +C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION +C----------------------------------------------------------------------- + NN = MIN(2,N) + CALL ZBKNU(ZNR, ZNI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM) + IF (NW.NE.0) GO TO 90 + S1R = CYR(1) + S1I = CYI(1) + FMR = MR + SGN = -DSIGN(PI,FMR) + CSGNR = ZEROR + CSGNI = SGN + IF (KODE.EQ.1) GO TO 10 + YY = -ZNI + CPN = COS(YY) + SPN = SIN(YY) + CALL ZMLT(CSGNR, CSGNI, CPN, SPN, CSGNR, CSGNI) + 10 CONTINUE +C----------------------------------------------------------------------- +C CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE +C WHEN FNU IS LARGE +C----------------------------------------------------------------------- + INU = FNU + ARG = (FNU-INU)*SGN + CPN = COS(ARG) + SPN = SIN(ARG) + CSPNR = CPN + CSPNI = SPN + IF (MOD(INU,2).EQ.0) GO TO 20 + CSPNR = -CSPNR + CSPNI = -CSPNI + 20 CONTINUE + IUF = 0 + C1R = S1R + C1I = S1I + C2R = YR(1) + C2I = YI(1) + ASCLE = 1.0D+3*D1MACH(1)/TOL + IF (KODE.EQ.1) GO TO 30 + CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) + NZ = NZ + NW + SC1R = C1R + SC1I = C1I + 30 CONTINUE + CALL ZMLT(CSPNR, CSPNI, C1R, C1I, STR, STI) + CALL ZMLT(CSGNR, CSGNI, C2R, C2I, PTR, PTI) + YR(1) = STR + PTR + YI(1) = STI + PTI + IF (N.EQ.1) RETURN + CSPNR = -CSPNR + CSPNI = -CSPNI + S2R = CYR(2) + S2I = CYI(2) + C1R = S2R + C1I = S2I + C2R = YR(2) + C2I = YI(2) + IF (KODE.EQ.1) GO TO 40 + CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) + NZ = NZ + NW + SC2R = C1R + SC2I = C1I + 40 CONTINUE + CALL ZMLT(CSPNR, CSPNI, C1R, C1I, STR, STI) + CALL ZMLT(CSGNR, CSGNI, C2R, C2I, PTR, PTI) + YR(2) = STR + PTR + YI(2) = STI + PTI + IF (N.EQ.2) RETURN + CSPNR = -CSPNR + CSPNI = -CSPNI + AZN = ZABS(ZNR,ZNI) + RAZN = 1.0D0/AZN + STR = ZNR*RAZN + STI = -ZNI*RAZN + RZR = (STR+STR)*RAZN + RZI = (STI+STI)*RAZN + FN = FNU + 1.0D0 + CKR = FN*RZR + CKI = FN*RZI +C----------------------------------------------------------------------- +C SCALE NEAR EXPONENT EXTREMES DURING RECURRENCE ON K FUNCTIONS +C----------------------------------------------------------------------- + CSCL = 1.0D0/TOL + CSCR = TOL + CSSR(1) = CSCL + CSSR(2) = CONER + CSSR(3) = CSCR + CSRR(1) = CSCR + CSRR(2) = CONER + CSRR(3) = CSCL + BRY(1) = ASCLE + BRY(2) = 1.0D0/ASCLE + BRY(3) = D1MACH(2) + AS2 = ZABS(S2R,S2I) + KFLAG = 2 + IF (AS2.GT.BRY(1)) GO TO 50 + KFLAG = 1 + GO TO 60 + 50 CONTINUE + IF (AS2.LT.BRY(2)) GO TO 60 + KFLAG = 3 + 60 CONTINUE + BSCLE = BRY(KFLAG) + S1R = S1R*CSSR(KFLAG) + S1I = S1I*CSSR(KFLAG) + S2R = S2R*CSSR(KFLAG) + S2I = S2I*CSSR(KFLAG) + CSR = CSRR(KFLAG) + DO 80 I=3,N + STR = S2R + STI = S2I + S2R = CKR*STR - CKI*STI + S1R + S2I = CKR*STI + CKI*STR + S1I + S1R = STR + S1I = STI + C1R = S2R*CSR + C1I = S2I*CSR + STR = C1R + STI = C1I + C2R = YR(I) + C2I = YI(I) + IF (KODE.EQ.1) GO TO 70 + IF (IUF.LT.0) GO TO 70 + CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) + NZ = NZ + NW + SC1R = SC2R + SC1I = SC2I + SC2R = C1R + SC2I = C1I + IF (IUF.NE.3) GO TO 70 + IUF = -4 + S1R = SC1R*CSSR(KFLAG) + S1I = SC1I*CSSR(KFLAG) + S2R = SC2R*CSSR(KFLAG) + S2I = SC2I*CSSR(KFLAG) + STR = SC2R + STI = SC2I + 70 CONTINUE + PTR = CSPNR*C1R - CSPNI*C1I + PTI = CSPNR*C1I + CSPNI*C1R + YR(I) = PTR + CSGNR*C2R - CSGNI*C2I + YI(I) = PTI + CSGNR*C2I + CSGNI*C2R + CKR = CKR + RZR + CKI = CKI + RZI + CSPNR = -CSPNR + CSPNI = -CSPNI + IF (KFLAG.GE.3) GO TO 80 + PTR = ABS(C1R) + PTI = ABS(C1I) + C1M = MAX(PTR,PTI) + IF (C1M.LE.BSCLE) GO TO 80 + KFLAG = KFLAG + 1 + BSCLE = BRY(KFLAG) + S1R = S1R*CSR + S1I = S1I*CSR + S2R = STR + S2I = STI + S1R = S1R*CSSR(KFLAG) + S1I = S1I*CSSR(KFLAG) + S2R = S2R*CSSR(KFLAG) + S2I = S2I*CSSR(KFLAG) + CSR = CSRR(KFLAG) + 80 CONTINUE + RETURN + 90 CONTINUE + NZ = -1 + IF(NW.EQ.(-2)) NZ=-2 + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zacon.lo b/modules/elementary_functions/src/fortran/slatec/zacon.lo new file mode 100755 index 000000000..5302f7d24 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zacon.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zacon.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zacon.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zairy.f b/modules/elementary_functions/src/fortran/slatec/zairy.f new file mode 100755 index 000000000..435df5d76 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zairy.f @@ -0,0 +1,404 @@ +*DECK ZAIRY + SUBROUTINE ZAIRY (ZR, ZI, ID, KODE, AIR, AII, NZ, IERR) +C***BEGIN PROLOGUE ZAIRY +C***PURPOSE Compute the Airy function Ai(z) or its derivative dAi/dz +C for complex argument z. A scaling option is available +C to help avoid underflow and overflow. +C***LIBRARY SLATEC +C***CATEGORY C10D +C***TYPE COMPLEX (CAIRY-C, ZAIRY-C) +C***KEYWORDS AIRY FUNCTION, BESSEL FUNCTION OF ORDER ONE THIRD, +C BESSEL FUNCTION OF ORDER TWO THIRDS +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C ***A DOUBLE PRECISION ROUTINE*** +C On KODE=1, ZAIRY computes the complex Airy function Ai(z) +C or its derivative dAi/dz on ID=0 or ID=1 respectively. On +C KODE=2, a scaling option exp(zeta)*Ai(z) or exp(zeta)*dAi/dz +C is provided to remove the exponential decay in -pi/3<arg(z) +C <pi/3 and the exponential growth in pi/3<abs(arg(z))<pi where +C zeta=(2/3)*z**(3/2). +C +C While the Airy functions Ai(z) and dAi/dz are analytic in +C the whole z-plane, the corresponding scaled functions defined +C for KODE=2 have a cut along the negative real axis. +C +C Input +C ZR - DOUBLE PRECISION real part of argument Z +C ZI - DOUBLE PRECISION imag part of argument Z +C ID - Order of derivative, ID=0 or ID=1 +C KODE - A parameter to indicate the scaling option +C KODE=1 returns +C AI=Ai(z) on ID=0 +C AI=dAi/dz on ID=1 +C at z=Z +C =2 returns +C AI=exp(zeta)*Ai(z) on ID=0 +C AI=exp(zeta)*dAi/dz on ID=1 +C at z=Z where zeta=(2/3)*z**(3/2) +C +C Output +C AIR - DOUBLE PRECISION real part of result +C AII - DOUBLE PRECISION imag part of result +C NZ - Underflow indicator +C NZ=0 Normal return +C NZ=1 AI=0 due to underflow in +C -pi/3<arg(Z)<pi/3 on KODE=1 +C IERR - Error flag +C IERR=0 Normal return - COMPUTATION COMPLETED +C IERR=1 Input error - NO COMPUTATION +C IERR=2 Overflow - NO COMPUTATION +C (Re(Z) too large with KODE=1) +C IERR=3 Precision warning - COMPUTATION COMPLETED +C (Result has less than half precision) +C IERR=4 Precision error - NO COMPUTATION +C (Result has no precision) +C IERR=5 Algorithmic error - NO COMPUTATION +C (Termination condition not met) +C +C *Long Description: +C +C Ai(z) and dAi/dz are computed from K Bessel functions by +C +C Ai(z) = c*sqrt(z)*K(1/3,zeta) +C dAi/dz = -c* z *K(2/3,zeta) +C c = 1/(pi*sqrt(3)) +C zeta = (2/3)*z**(3/2) +C +C when abs(z)>1 and from power series when abs(z)<=1. +C +C In most complex variable computation, one must evaluate ele- +C mentary functions. When the magnitude of Z is large, losses +C of significance by argument reduction occur. Consequently, if +C the magnitude of ZETA=(2/3)*Z**(3/2) exceeds U1=SQRT(0.5/UR), +C then losses exceeding half precision are likely and an error +C flag IERR=3 is triggered where UR=MAX(D1MACH(4),1.0D-18) is +C double precision unit roundoff limited to 18 digits precision. +C Also, if the magnitude of ZETA is larger than U2=0.5/UR, then +C all significance is lost and IERR=4. In order to use the INT +C function, ZETA must be further restricted not to exceed +C U3=I1MACH(9)=LARGEST INTEGER. Thus, the magnitude of ZETA +C must be restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, +C and U3 are approximately 2.0E+3, 4.2E+6, 2.1E+9 in single +C precision and 4.7E+7, 2.3E+15, 2.1E+9 in double precision. +C This makes U2 limiting is single precision and U3 limiting +C in double precision. This means that the magnitude of Z +C cannot exceed approximately 3.4E+4 in single precision and +C 2.1E+6 in double precision. This also means that one can +C expect to retain, in the worst cases on 32-bit machines, +C no digits in single precision and only 6 digits in double +C precision. +C +C The approximate relative error in the magnitude of a complex +C Bessel function can be expressed as P*10**S where P=MAX(UNIT +C ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- +C sents the increase in error due to argument reduction in the +C elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), +C ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF +C ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may +C have only absolute accuracy. This is most likely to occur +C when one component (in magnitude) is larger than the other by +C several orders of magnitude. If one component is 10**K larger +C than the other, then one can expect only MAX(ABS(LOG10(P))-K, +C 0) significant digits; or, stated another way, when K exceeds +C the exponent of P, no significant digits remain in the smaller +C component. However, the phase angle retains absolute accuracy +C because, in complex arithmetic with precision P, the smaller +C component will not (as a rule) decrease below P times the +C magnitude of the larger component. In these extreme cases, +C the principal phase angle is on the order of +P, -P, PI/2-P, +C or -PI/2+P. +C +C***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- +C matical Functions, National Bureau of Standards +C Applied Mathematics Series 55, U. S. Department +C of Commerce, Tenth Printing (1972) or later. +C 2. D. E. Amos, Computation of Bessel Functions of +C Complex Argument and Large Order, Report SAND83-0643, +C Sandia National Laboratories, Albuquerque, NM, May +C 1983. +C 3. D. E. Amos, A Subroutine Package for Bessel Functions +C of a Complex Argument and Nonnegative Order, Report +C SAND85-1018, Sandia National Laboratory, Albuquerque, +C NM, May 1985. +C 4. D. E. Amos, A portable package for Bessel functions +C of a complex argument and nonnegative order, ACM +C Transactions on Mathematical Software, 12 (September +C 1986), pp. 265-273. +C +C***ROUTINES CALLED D1MACH, I1MACH, ZABS, ZACAI, ZBKNU, ZEXP, ZSQRT +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 890801 REVISION DATE from Version 3.2 +C 910415 Prologue converted to Version 4.0 format. (BAB) +C 920128 Category corrected. (WRB) +C 920811 Prologue revised. (DWL) +C 930122 Added ZEXP and ZSQRT to EXTERNAL statement. (RWC) +C***END PROLOGUE ZAIRY +C COMPLEX AI,CONE,CSQ,CY,S1,S2,TRM1,TRM2,Z,ZTA,Z3 + DOUBLE PRECISION AA, AD, AII, AIR, AK, ALIM, ATRM, AZ, AZ3, BK, + * CC, CK, COEF, CONEI, CONER, CSQI, CSQR, CYI, CYR, C1, C2, DIG, + * DK, D1, D2, ELIM, FID, FNU, PTR, RL, R1M5, SFAC, STI, STR, + * S1I, S1R, S2I, S2R, TOL, TRM1I, TRM1R, TRM2I, TRM2R, TTH, ZEROI, + * ZEROR, ZI, ZR, ZTAI, ZTAR, Z3I, Z3R, D1MACH, ZABS, ALAZ, BB + INTEGER ID, IERR, IFLAG, K, KODE, K1, K2, MR, NN, NZ, I1MACH + DIMENSION CYR(1), CYI(1) + EXTERNAL ZABS, ZEXP, ZSQRT + DATA TTH, C1, C2, COEF /6.66666666666666667D-01, + * 3.55028053887817240D-01,2.58819403792806799D-01, + * 1.83776298473930683D-01/ + DATA ZEROR, ZEROI, CONER, CONEI /0.0D0,0.0D0,1.0D0,0.0D0/ +C***FIRST EXECUTABLE STATEMENT ZAIRY + IERR = 0 + NZ=0 + IF (ID.LT.0 .OR. ID.GT.1) IERR=1 + IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 + IF (IERR.NE.0) RETURN + AZ = ZABS(ZR,ZI) + TOL = MAX(D1MACH(4),1.0D-18) + FID = ID + IF (AZ.GT.1.0D0) GO TO 70 +C----------------------------------------------------------------------- +C POWER SERIES FOR ABS(Z).LE.1. +C----------------------------------------------------------------------- + S1R = CONER + S1I = CONEI + S2R = CONER + S2I = CONEI + IF (AZ.LT.TOL) GO TO 170 + AA = AZ*AZ + IF (AA.LT.TOL/AZ) GO TO 40 + TRM1R = CONER + TRM1I = CONEI + TRM2R = CONER + TRM2I = CONEI + ATRM = 1.0D0 + STR = ZR*ZR - ZI*ZI + STI = ZR*ZI + ZI*ZR + Z3R = STR*ZR - STI*ZI + Z3I = STR*ZI + STI*ZR + AZ3 = AZ*AA + AK = 2.0D0 + FID + BK = 3.0D0 - FID - FID + CK = 4.0D0 - FID + DK = 3.0D0 + FID + FID + D1 = AK*DK + D2 = BK*CK + AD = MIN(D1,D2) + AK = 24.0D0 + 9.0D0*FID + BK = 30.0D0 - 9.0D0*FID + DO 30 K=1,25 + STR = (TRM1R*Z3R-TRM1I*Z3I)/D1 + TRM1I = (TRM1R*Z3I+TRM1I*Z3R)/D1 + TRM1R = STR + S1R = S1R + TRM1R + S1I = S1I + TRM1I + STR = (TRM2R*Z3R-TRM2I*Z3I)/D2 + TRM2I = (TRM2R*Z3I+TRM2I*Z3R)/D2 + TRM2R = STR + S2R = S2R + TRM2R + S2I = S2I + TRM2I + ATRM = ATRM*AZ3/AD + D1 = D1 + AK + D2 = D2 + BK + AD = MIN(D1,D2) + IF (ATRM.LT.TOL*AD) GO TO 40 + AK = AK + 18.0D0 + BK = BK + 18.0D0 + 30 CONTINUE + 40 CONTINUE + IF (ID.EQ.1) GO TO 50 + AIR = S1R*C1 - C2*(ZR*S2R-ZI*S2I) + AII = S1I*C1 - C2*(ZR*S2I+ZI*S2R) + IF (KODE.EQ.1) RETURN + CALL ZSQRT(ZR, ZI, STR, STI) + ZTAR = TTH*(ZR*STR-ZI*STI) + ZTAI = TTH*(ZR*STI+ZI*STR) + CALL ZEXP(ZTAR, ZTAI, STR, STI) + PTR = AIR*STR - AII*STI + AII = AIR*STI + AII*STR + AIR = PTR + RETURN + 50 CONTINUE + AIR = -S2R*C2 + AII = -S2I*C2 + IF (AZ.LE.TOL) GO TO 60 + STR = ZR*S1R - ZI*S1I + STI = ZR*S1I + ZI*S1R + CC = C1/(1.0D0+FID) + AIR = AIR + CC*(STR*ZR-STI*ZI) + AII = AII + CC*(STR*ZI+STI*ZR) + 60 CONTINUE + IF (KODE.EQ.1) RETURN + CALL ZSQRT(ZR, ZI, STR, STI) + ZTAR = TTH*(ZR*STR-ZI*STI) + ZTAI = TTH*(ZR*STI+ZI*STR) + CALL ZEXP(ZTAR, ZTAI, STR, STI) + PTR = STR*AIR - STI*AII + AII = STR*AII + STI*AIR + AIR = PTR + RETURN +C----------------------------------------------------------------------- +C CASE FOR ABS(Z).GT.1.0 +C----------------------------------------------------------------------- + 70 CONTINUE + FNU = (1.0D0+FID)/3.0D0 +C----------------------------------------------------------------------- +C SET PARAMETERS RELATED TO MACHINE CONSTANTS. +C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0D-18. +C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. +C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND +C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR +C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. +C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. +C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). +C----------------------------------------------------------------------- + K1 = I1MACH(15) + K2 = I1MACH(16) + R1M5 = D1MACH(5) + K = MIN(ABS(K1),ABS(K2)) + ELIM = 2.303D0*(K*R1M5-3.0D0) + K1 = I1MACH(14) - 1 + AA = R1M5*K1 + DIG = MIN(AA,18.0D0) + AA = AA*2.303D0 + ALIM = ELIM + MAX(-AA,-41.45D0) + RL = 1.2D0*DIG + 3.0D0 + ALAZ = LOG(AZ) +C----------------------------------------------------------------------- +C TEST FOR PROPER RANGE +C----------------------------------------------------------------------- + AA=0.5D0/TOL + BB=I1MACH(9)*0.5D0 + AA=MIN(AA,BB) + AA=AA**TTH + IF (AZ.GT.AA) GO TO 260 + AA=SQRT(AA) + IF (AZ.GT.AA) IERR=3 + CALL ZSQRT(ZR, ZI, CSQR, CSQI) + ZTAR = TTH*(ZR*CSQR-ZI*CSQI) + ZTAI = TTH*(ZR*CSQI+ZI*CSQR) +C----------------------------------------------------------------------- +C RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL +C----------------------------------------------------------------------- + IFLAG = 0 + SFAC = 1.0D0 + AK = ZTAI + IF (ZR.GE.0.0D0) GO TO 80 + BK = ZTAR + CK = -ABS(BK) + ZTAR = CK + ZTAI = AK + 80 CONTINUE + IF (ZI.NE.0.0D0) GO TO 90 + IF (ZR.GT.0.0D0) GO TO 90 + ZTAR = 0.0D0 + ZTAI = AK + 90 CONTINUE + AA = ZTAR + IF (AA.GE.0.0D0 .AND. ZR.GT.0.0D0) GO TO 110 + IF (KODE.EQ.2) GO TO 100 +C----------------------------------------------------------------------- +C OVERFLOW TEST +C----------------------------------------------------------------------- + IF (AA.GT.(-ALIM)) GO TO 100 + AA = -AA + 0.25D0*ALAZ + IFLAG = 1 + SFAC = TOL + IF (AA.GT.ELIM) GO TO 270 + 100 CONTINUE +C----------------------------------------------------------------------- +C CBKNU AND CACON RETURN EXP(ZTA)*K(FNU,ZTA) ON KODE=2 +C----------------------------------------------------------------------- + MR = 1 + IF (ZI.LT.0.0D0) MR = -1 + CALL ZACAI(ZTAR, ZTAI, FNU, KODE, MR, 1, CYR, CYI, NN, RL, TOL, + * ELIM, ALIM) + IF (NN.LT.0) GO TO 280 + NZ = NZ + NN + GO TO 130 + 110 CONTINUE + IF (KODE.EQ.2) GO TO 120 +C----------------------------------------------------------------------- +C UNDERFLOW TEST +C----------------------------------------------------------------------- + IF (AA.LT.ALIM) GO TO 120 + AA = -AA - 0.25D0*ALAZ + IFLAG = 2 + SFAC = 1.0D0/TOL + IF (AA.LT.(-ELIM)) GO TO 210 + 120 CONTINUE + CALL ZBKNU(ZTAR, ZTAI, FNU, KODE, 1, CYR, CYI, NZ, TOL, ELIM, + * ALIM) + 130 CONTINUE + S1R = CYR(1)*COEF + S1I = CYI(1)*COEF + IF (IFLAG.NE.0) GO TO 150 + IF (ID.EQ.1) GO TO 140 + AIR = CSQR*S1R - CSQI*S1I + AII = CSQR*S1I + CSQI*S1R + RETURN + 140 CONTINUE + AIR = -(ZR*S1R-ZI*S1I) + AII = -(ZR*S1I+ZI*S1R) + RETURN + 150 CONTINUE + S1R = S1R*SFAC + S1I = S1I*SFAC + IF (ID.EQ.1) GO TO 160 + STR = S1R*CSQR - S1I*CSQI + S1I = S1R*CSQI + S1I*CSQR + S1R = STR + AIR = S1R/SFAC + AII = S1I/SFAC + RETURN + 160 CONTINUE + STR = -(S1R*ZR-S1I*ZI) + S1I = -(S1R*ZI+S1I*ZR) + S1R = STR + AIR = S1R/SFAC + AII = S1I/SFAC + RETURN + 170 CONTINUE + AA = 1.0D+3*D1MACH(1) + S1R = ZEROR + S1I = ZEROI + IF (ID.EQ.1) GO TO 190 + IF (AZ.LE.AA) GO TO 180 + S1R = C2*ZR + S1I = C2*ZI + 180 CONTINUE + AIR = C1 - S1R + AII = -S1I + RETURN + 190 CONTINUE + AIR = -C2 + AII = 0.0D0 + AA = SQRT(AA) + IF (AZ.LE.AA) GO TO 200 + S1R = 0.5D0*(ZR*ZR-ZI*ZI) + S1I = ZR*ZI + 200 CONTINUE + AIR = AIR + C1*S1R + AII = AII + C1*S1I + RETURN + 210 CONTINUE + NZ = 1 + AIR = ZEROR + AII = ZEROI + RETURN + 270 CONTINUE + NZ = 0 + IERR=2 + RETURN + 280 CONTINUE + IF(NN.EQ.(-1)) GO TO 270 + NZ=0 + IERR=5 + RETURN + 260 CONTINUE + IERR=4 + NZ=0 + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zairy.lo b/modules/elementary_functions/src/fortran/slatec/zairy.lo new file mode 100755 index 000000000..75107fe5e --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zairy.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zairy.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zairy.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zasyi.f b/modules/elementary_functions/src/fortran/slatec/zasyi.f new file mode 100755 index 000000000..8ae99ffe4 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zasyi.f @@ -0,0 +1,177 @@ +*DECK ZASYI + SUBROUTINE ZASYI (ZR, ZI, FNU, KODE, N, YR, YI, NZ, RL, TOL, ELIM, + + ALIM) +C***BEGIN PROLOGUE ZASYI +C***SUBSIDIARY +C***PURPOSE Subsidiary to ZBESI and ZBESK +C***LIBRARY SLATEC +C***TYPE ALL (CASYI-A, ZASYI-A) +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C ZASYI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY +C MEANS OF THE ASYMPTOTIC EXPANSION FOR LARGE ABS(Z) IN THE +C REGION ABS(Z).GT.MAX(RL,FNU*FNU/2). NZ=0 IS A NORMAL RETURN. +C NZ.LT.0 INDICATES AN OVERFLOW ON KODE=1. +C +C***SEE ALSO ZBESI, ZBESK +C***ROUTINES CALLED D1MACH, ZABS, ZDIV, ZEXP, ZMLT, ZSQRT +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 910415 Prologue converted to Version 4.0 format. (BAB) +C 930122 Added ZEXP and ZSQRT to EXTERNAL statement. (RWC) +C***END PROLOGUE ZASYI +C COMPLEX AK1,CK,CONE,CS1,CS2,CZ,CZERO,DK,EZ,P1,RZ,S2,Y,Z + DOUBLE PRECISION AA, AEZ, AK, AK1I, AK1R, ALIM, ARG, ARM, ATOL, + * AZ, BB, BK, CKI, CKR, CONEI, CONER, CS1I, CS1R, CS2I, CS2R, CZI, + * CZR, DFNU, DKI, DKR, DNU2, ELIM, EZI, EZR, FDN, FNU, PI, P1I, + * P1R, RAZ, RL, RTPI, RTR1, RZI, RZR, S, SGN, SQK, STI, STR, S2I, + * S2R, TOL, TZI, TZR, YI, YR, ZEROI, ZEROR, ZI, ZR, D1MACH, ZABS + INTEGER I, IB, IL, INU, J, JL, K, KODE, KODED, M, N, NN, NZ + DIMENSION YR(N), YI(N) + EXTERNAL ZABS, ZEXP, ZSQRT + DATA PI, RTPI /3.14159265358979324D0 , 0.159154943091895336D0 / + DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / +C***FIRST EXECUTABLE STATEMENT ZASYI + NZ = 0 + AZ = ZABS(ZR,ZI) + ARM = 1.0D+3*D1MACH(1) + RTR1 = SQRT(ARM) + IL = MIN(2,N) + DFNU = FNU + (N-IL) +C----------------------------------------------------------------------- +C OVERFLOW TEST +C----------------------------------------------------------------------- + RAZ = 1.0D0/AZ + STR = ZR*RAZ + STI = -ZI*RAZ + AK1R = RTPI*STR*RAZ + AK1I = RTPI*STI*RAZ + CALL ZSQRT(AK1R, AK1I, AK1R, AK1I) + CZR = ZR + CZI = ZI + IF (KODE.NE.2) GO TO 10 + CZR = ZEROR + CZI = ZI + 10 CONTINUE + IF (ABS(CZR).GT.ELIM) GO TO 100 + DNU2 = DFNU + DFNU + KODED = 1 + IF ((ABS(CZR).GT.ALIM) .AND. (N.GT.2)) GO TO 20 + KODED = 0 + CALL ZEXP(CZR, CZI, STR, STI) + CALL ZMLT(AK1R, AK1I, STR, STI, AK1R, AK1I) + 20 CONTINUE + FDN = 0.0D0 + IF (DNU2.GT.RTR1) FDN = DNU2*DNU2 + EZR = ZR*8.0D0 + EZI = ZI*8.0D0 +C----------------------------------------------------------------------- +C WHEN Z IS IMAGINARY, THE ERROR TEST MUST BE MADE RELATIVE TO THE +C FIRST RECIPROCAL POWER SINCE THIS IS THE LEADING TERM OF THE +C EXPANSION FOR THE IMAGINARY PART. +C----------------------------------------------------------------------- + AEZ = 8.0D0*AZ + S = TOL/AEZ + JL = RL+RL + 2 + P1R = ZEROR + P1I = ZEROI + IF (ZI.EQ.0.0D0) GO TO 30 +C----------------------------------------------------------------------- +C CALCULATE EXP(PI*(0.5+FNU+N-IL)*I) TO MINIMIZE LOSSES OF +C SIGNIFICANCE WHEN FNU OR N IS LARGE +C----------------------------------------------------------------------- + INU = FNU + ARG = (FNU-INU)*PI + INU = INU + N - IL + AK = -SIN(ARG) + BK = COS(ARG) + IF (ZI.LT.0.0D0) BK = -BK + P1R = AK + P1I = BK + IF (MOD(INU,2).EQ.0) GO TO 30 + P1R = -P1R + P1I = -P1I + 30 CONTINUE + DO 70 K=1,IL + SQK = FDN - 1.0D0 + ATOL = S*ABS(SQK) + SGN = 1.0D0 + CS1R = CONER + CS1I = CONEI + CS2R = CONER + CS2I = CONEI + CKR = CONER + CKI = CONEI + AK = 0.0D0 + AA = 1.0D0 + BB = AEZ + DKR = EZR + DKI = EZI + DO 40 J=1,JL + CALL ZDIV(CKR, CKI, DKR, DKI, STR, STI) + CKR = STR*SQK + CKI = STI*SQK + CS2R = CS2R + CKR + CS2I = CS2I + CKI + SGN = -SGN + CS1R = CS1R + CKR*SGN + CS1I = CS1I + CKI*SGN + DKR = DKR + EZR + DKI = DKI + EZI + AA = AA*ABS(SQK)/BB + BB = BB + AEZ + AK = AK + 8.0D0 + SQK = SQK - AK + IF (AA.LE.ATOL) GO TO 50 + 40 CONTINUE + GO TO 110 + 50 CONTINUE + S2R = CS1R + S2I = CS1I + IF (ZR+ZR.GE.ELIM) GO TO 60 + TZR = ZR + ZR + TZI = ZI + ZI + CALL ZEXP(-TZR, -TZI, STR, STI) + CALL ZMLT(STR, STI, P1R, P1I, STR, STI) + CALL ZMLT(STR, STI, CS2R, CS2I, STR, STI) + S2R = S2R + STR + S2I = S2I + STI + 60 CONTINUE + FDN = FDN + 8.0D0*DFNU + 4.0D0 + P1R = -P1R + P1I = -P1I + M = N - IL + K + YR(M) = S2R*AK1R - S2I*AK1I + YI(M) = S2R*AK1I + S2I*AK1R + 70 CONTINUE + IF (N.LE.2) RETURN + NN = N + K = NN - 2 + AK = K + STR = ZR*RAZ + STI = -ZI*RAZ + RZR = (STR+STR)*RAZ + RZI = (STI+STI)*RAZ + IB = 3 + DO 80 I=IB,NN + YR(K) = (AK+FNU)*(RZR*YR(K+1)-RZI*YI(K+1)) + YR(K+2) + YI(K) = (AK+FNU)*(RZR*YI(K+1)+RZI*YR(K+1)) + YI(K+2) + AK = AK - 1.0D0 + K = K - 1 + 80 CONTINUE + IF (KODED.EQ.0) RETURN + CALL ZEXP(CZR, CZI, CKR, CKI) + DO 90 I=1,NN + STR = YR(I)*CKR - YI(I)*CKI + YI(I) = YR(I)*CKI + YI(I)*CKR + YR(I) = STR + 90 CONTINUE + RETURN + 100 CONTINUE + NZ = -1 + RETURN + 110 CONTINUE + NZ=-2 + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zasyi.lo b/modules/elementary_functions/src/fortran/slatec/zasyi.lo new file mode 100755 index 000000000..93df9724b --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zasyi.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zasyi.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zasyi.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zbesh.f b/modules/elementary_functions/src/fortran/slatec/zbesh.f new file mode 100755 index 000000000..dfa5da9fc --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zbesh.f @@ -0,0 +1,351 @@ +*DECK ZBESH + SUBROUTINE ZBESH (ZR, ZI, FNU, KODE, M, N, CYR, CYI, NZ, IERR) +C***BEGIN PROLOGUE ZBESH +C***PURPOSE Compute a sequence of the Hankel functions H(m,a,z) +C for superscript m=1 or 2, real nonnegative orders a=b, +C b+1,... where b>0, and nonzero complex argument z. A +C scaling option is available to help avoid overflow. +C***LIBRARY SLATEC +C***CATEGORY C10A4 +C***TYPE COMPLEX (CBESH-C, ZBESH-C) +C***KEYWORDS BESSEL FUNCTIONS OF COMPLEX ARGUMENT, +C BESSEL FUNCTIONS OF THE THIRD KIND, H BESSEL FUNCTIONS, +C HANKEL FUNCTIONS +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C ***A DOUBLE PRECISION ROUTINE*** +C On KODE=1, ZBESH computes an N member sequence of complex +C Hankel (Bessel) functions CY(L)=H(M,FNU+L-1,Z) for super- +C script M=1 or 2, real nonnegative orders FNU+L-1, L=1,..., +C N, and complex nonzero Z in the cut plane -pi<arg(Z)<=pi +C where Z=ZR+i*ZI. On KODE=2, CBESH returns the scaled +C functions +C +C CY(L) = H(M,FNU+L-1,Z)*exp(-(3-2*M)*Z*i), i**2=-1 +C +C which removes the exponential behavior in both the upper +C and lower half planes. Definitions and notation are found +C in the NBS Handbook of Mathematical Functions (Ref. 1). +C +C Input +C ZR - DOUBLE PRECISION real part of nonzero argument Z +C ZI - DOUBLE PRECISION imag part of nonzero argument Z +C FNU - DOUBLE PRECISION initial order, FNU>=0 +C KODE - A parameter to indicate the scaling option +C KODE=1 returns +C CY(L)=H(M,FNU+L-1,Z), L=1,...,N +C =2 returns +C CY(L)=H(M,FNU+L-1,Z)*exp(-(3-2M)*Z*i), +C L=1,...,N +C M - Superscript of Hankel function, M=1 or 2 +C N - Number of terms in the sequence, N>=1 +C +C Output +C CYR - DOUBLE PRECISION real part of result vector +C CYI - DOUBLE PRECISION imag part of result vector +C NZ - Number of underflows set to zero +C NZ=0 Normal return +C NZ>0 CY(L)=0 for NZ values of L (if M=1 and +C Im(Z)>0 or if M=2 and Im(Z)<0, then +C CY(L)=0 for L=1,...,NZ; in the com- +C plementary half planes, the underflows +C may not be in an uninterrupted sequence) +C IERR - Error flag +C IERR=0 Normal return - COMPUTATION COMPLETED +C IERR=1 Input error - NO COMPUTATION +C IERR=2 Overflow - NO COMPUTATION +C (abs(Z) too small and/or FNU+N-1 +C too large) +C IERR=3 Precision warning - COMPUTATION COMPLETED +C (Result has half precision or less +C because abs(Z) or FNU+N-1 is large) +C IERR=4 Precision error - NO COMPUTATION +C (Result has no precision because +C abs(Z) or FNU+N-1 is too large) +C IERR=5 Algorithmic error - NO COMPUTATION +C (Termination condition not met) +C +C *Long Description: +C +C The computation is carried out by the formula +C +C H(m,a,z) = (1/t)*exp(-a*t)*K(a,z*exp(-t)) +C t = (3-2*m)*i*pi/2 +C +C where the K Bessel function is computed as described in the +C prologue to CBESK. +C +C Exponential decay of H(m,a,z) occurs in the upper half z +C plane for m=1 and the lower half z plane for m=2. Exponential +C growth occurs in the complementary half planes. Scaling +C by exp(-(3-2*m)*z*i) removes the exponential behavior in the +C whole z plane as z goes to infinity. +C +C For negative orders, the formula +C +C H(m,-a,z) = H(m,a,z)*exp((3-2*m)*a*pi*i) +C +C can be used. +C +C In most complex variable computation, one must evaluate ele- +C mentary functions. When the magnitude of Z or FNU+N-1 is +C large, losses of significance by argument reduction occur. +C Consequently, if either one exceeds U1=SQRT(0.5/UR), then +C losses exceeding half precision are likely and an error flag +C IERR=3 is triggered where UR=MAX(D1MACH(4),1.0D-18) is double +C precision unit roundoff limited to 18 digits precision. Also, +C if either is larger than U2=0.5/UR, then all significance is +C lost and IERR=4. In order to use the INT function, arguments +C must be further restricted not to exceed the largest machine +C integer, U3=I1MACH(9). Thus, the magnitude of Z and FNU+N-1 +C is restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, and +C U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision +C and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision. This +C makes U2 limiting in single precision and U3 limiting in +C double precision. This means that one can expect to retain, +C in the worst cases on IEEE machines, no digits in single pre- +C cision and only 6 digits in double precision. Similar con- +C siderations hold for other machines. +C +C The approximate relative error in the magnitude of a complex +C Bessel function can be expressed as P*10**S where P=MAX(UNIT +C ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- +C sents the increase in error due to argument reduction in the +C elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), +C ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF +C ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may +C have only absolute accuracy. This is most likely to occur +C when one component (in magnitude) is larger than the other by +C several orders of magnitude. If one component is 10**K larger +C than the other, then one can expect only MAX(ABS(LOG10(P))-K, +C 0) significant digits; or, stated another way, when K exceeds +C the exponent of P, no significant digits remain in the smaller +C component. However, the phase angle retains absolute accuracy +C because, in complex arithmetic with precision P, the smaller +C component will not (as a rule) decrease below P times the +C magnitude of the larger component. In these extreme cases, +C the principal phase angle is on the order of +P, -P, PI/2-P, +C or -PI/2+P. +C +C***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- +C matical Functions, National Bureau of Standards +C Applied Mathematics Series 55, U. S. Department +C of Commerce, Tenth Printing (1972) or later. +C 2. D. E. Amos, Computation of Bessel Functions of +C Complex Argument, Report SAND83-0086, Sandia National +C Laboratories, Albuquerque, NM, May 1983. +C 3. D. E. Amos, Computation of Bessel Functions of +C Complex Argument and Large Order, Report SAND83-0643, +C Sandia National Laboratories, Albuquerque, NM, May +C 1983. +C 4. D. E. Amos, A Subroutine Package for Bessel Functions +C of a Complex Argument and Nonnegative Order, Report +C SAND85-1018, Sandia National Laboratory, Albuquerque, +C NM, May 1985. +C 5. D. E. Amos, A portable package for Bessel functions +C of a complex argument and nonnegative order, ACM +C Transactions on Mathematical Software, 12 (September +C 1986), pp. 265-273. +C +C***ROUTINES CALLED D1MACH, I1MACH, ZABS, ZACON, ZBKNU, ZBUNK, ZUOIK +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 890801 REVISION DATE from Version 3.2 +C 910415 Prologue converted to Version 4.0 format. (BAB) +C 920128 Category corrected. (WRB) +C 920811 Prologue revised. (DWL) +C***END PROLOGUE ZBESH +C +C COMPLEX CY,Z,ZN,ZT,CSGN + DOUBLE PRECISION AA, ALIM, ALN, ARG, AZ, CYI, CYR, DIG, ELIM, + * FMM, FN, FNU, FNUL, HPI, RHPI, RL, R1M5, SGN, STR, TOL, UFL, ZI, + * ZNI, ZNR, ZR, ZTI, D1MACH, ZABS, BB, ASCLE, RTOL, ATOL, STI, + * CSGNR, CSGNI + INTEGER I, IERR, INU, INUH, IR, K, KODE, K1, K2, M, + * MM, MR, N, NN, NUF, NW, NZ, I1MACH + DIMENSION CYR(N), CYI(N) + EXTERNAL ZABS +C + DATA HPI /1.57079632679489662D0/ +C +C***FIRST EXECUTABLE STATEMENT ZBESH + IERR = 0 + NZ=0 + IF (ZR.EQ.0.0D0 .AND. ZI.EQ.0.0D0) IERR=1 + IF (FNU.LT.0.0D0) IERR=1 + IF (M.LT.1 .OR. M.GT.2) IERR=1 + IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 + IF (N.LT.1) IERR=1 + IF (IERR.NE.0) RETURN + NN = N +C----------------------------------------------------------------------- +C SET PARAMETERS RELATED TO MACHINE CONSTANTS. +C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. +C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. +C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND +C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR +C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. +C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. +C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). +C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU +C----------------------------------------------------------------------- + TOL = MAX(D1MACH(4),1.0D-18) + K1 = I1MACH(15) + K2 = I1MACH(16) + R1M5 = D1MACH(5) + K = MIN(ABS(K1),ABS(K2)) + ELIM = 2.303D0*(K*R1M5-3.0D0) + K1 = I1MACH(14) - 1 + AA = R1M5*K1 + DIG = MIN(AA,18.0D0) + AA = AA*2.303D0 + ALIM = ELIM + MAX(-AA,-41.45D0) + FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) + RL = 1.2D0*DIG + 3.0D0 + FN = FNU + (NN-1) + MM = 3 - M - M + FMM = MM + ZNR = FMM*ZI + ZNI = -FMM*ZR +C----------------------------------------------------------------------- +C TEST FOR PROPER RANGE +C----------------------------------------------------------------------- + AZ = ZABS(ZR,ZI) + AA = 0.5D0/TOL + BB = I1MACH(9)*0.5D0 + AA = MIN(AA,BB) + IF (AZ.GT.AA) GO TO 260 + IF (FN.GT.AA) GO TO 260 + AA = SQRT(AA) + IF (AZ.GT.AA) IERR=3 + IF (FN.GT.AA) IERR=3 +C----------------------------------------------------------------------- +C OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE +C----------------------------------------------------------------------- + UFL = D1MACH(1)*1.0D+3 + IF (AZ.LT.UFL) GO TO 230 + IF (FNU.GT.FNUL) GO TO 90 + IF (FN.LE.1.0D0) GO TO 70 + IF (FN.GT.2.0D0) GO TO 60 + IF (AZ.GT.TOL) GO TO 70 + ARG = 0.5D0*AZ + ALN = -FN*LOG(ARG) + IF (ALN.GT.ELIM) GO TO 230 + GO TO 70 + 60 CONTINUE + CALL ZUOIK(ZNR, ZNI, FNU, KODE, 2, NN, CYR, CYI, NUF, TOL, ELIM, + * ALIM) + IF (NUF.LT.0) GO TO 230 + NZ = NZ + NUF + NN = NN - NUF +C----------------------------------------------------------------------- +C HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK +C IF NUF=NN, THEN CY(I)=CZERO FOR ALL I +C----------------------------------------------------------------------- + IF (NN.EQ.0) GO TO 140 + 70 CONTINUE + IF ((ZNR.LT.0.0D0) .OR. (ZNR.EQ.0.0D0 .AND. ZNI.LT.0.0D0 .AND. + * M.EQ.2)) GO TO 80 +C----------------------------------------------------------------------- +C RIGHT HALF PLANE COMPUTATION, XN.GE.0. .AND. (XN.NE.0. .OR. +C YN.GE.0. .OR. M=1) +C----------------------------------------------------------------------- + CALL ZBKNU(ZNR, ZNI, FNU, KODE, NN, CYR, CYI, NZ, TOL, ELIM, ALIM) + GO TO 110 +C----------------------------------------------------------------------- +C LEFT HALF PLANE COMPUTATION +C----------------------------------------------------------------------- + 80 CONTINUE + MR = -MM + CALL ZACON(ZNR, ZNI, FNU, KODE, MR, NN, CYR, CYI, NW, RL, FNUL, + * TOL, ELIM, ALIM) + IF (NW.LT.0) GO TO 240 + NZ=NW + GO TO 110 + 90 CONTINUE +C----------------------------------------------------------------------- +C UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU.GT.FNUL +C----------------------------------------------------------------------- + MR = 0 + IF ((ZNR.GE.0.0D0) .AND. (ZNR.NE.0.0D0 .OR. ZNI.GE.0.0D0 .OR. + * M.NE.2)) GO TO 100 + MR = -MM + IF (ZNR.NE.0.0D0 .OR. ZNI.GE.0.0D0) GO TO 100 + ZNR = -ZNR + ZNI = -ZNI + 100 CONTINUE + CALL ZBUNK(ZNR, ZNI, FNU, KODE, MR, NN, CYR, CYI, NW, TOL, ELIM, + * ALIM) + IF (NW.LT.0) GO TO 240 + NZ = NZ + NW + 110 CONTINUE +C----------------------------------------------------------------------- +C H(M,FNU,Z) = -FMM*(I/HPI)*(ZT**FNU)*K(FNU,-Z*ZT) +C +C ZT=EXP(-FMM*HPI*I) = CMPLX(0.0,-FMM), FMM=3-2*M, M=1,2 +C----------------------------------------------------------------------- + SGN = DSIGN(HPI,-FMM) +C----------------------------------------------------------------------- +C CALCULATE EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE +C WHEN FNU IS LARGE +C----------------------------------------------------------------------- + INU = FNU + INUH = INU/2 + IR = INU - 2*INUH + ARG = (FNU-(INU-IR))*SGN + RHPI = 1.0D0/SGN +C ZNI = RHPI*COS(ARG) +C ZNR = -RHPI*SIN(ARG) + CSGNI = RHPI*COS(ARG) + CSGNR = -RHPI*SIN(ARG) + IF (MOD(INUH,2).EQ.0) GO TO 120 +C ZNR = -ZNR +C ZNI = -ZNI + CSGNR = -CSGNR + CSGNI = -CSGNI + 120 CONTINUE + ZTI = -FMM + RTOL = 1.0D0/TOL + ASCLE = UFL*RTOL + DO 130 I=1,NN +C STR = CYR(I)*ZNR - CYI(I)*ZNI +C CYI(I) = CYR(I)*ZNI + CYI(I)*ZNR +C CYR(I) = STR +C STR = -ZNI*ZTI +C ZNI = ZNR*ZTI +C ZNR = STR + AA = CYR(I) + BB = CYI(I) + ATOL = 1.0D0 + IF (MAX(ABS(AA),ABS(BB)).GT.ASCLE) GO TO 135 + AA = AA*RTOL + BB = BB*RTOL + ATOL = TOL + 135 CONTINUE + STR = AA*CSGNR - BB*CSGNI + STI = AA*CSGNI + BB*CSGNR + CYR(I) = STR*ATOL + CYI(I) = STI*ATOL + STR = -CSGNI*ZTI + CSGNI = CSGNR*ZTI + CSGNR = STR + 130 CONTINUE + RETURN + 140 CONTINUE + IF (ZNR.LT.0.0D0) GO TO 230 + RETURN + 230 CONTINUE + NZ=0 + IERR=2 + RETURN + 240 CONTINUE + IF(NW.EQ.(-1)) GO TO 230 + NZ=0 + IERR=5 + RETURN + 260 CONTINUE + NZ=0 + IERR=4 + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zbesh.lo b/modules/elementary_functions/src/fortran/slatec/zbesh.lo new file mode 100755 index 000000000..ac46b188f --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zbesh.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zbesh.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zbesh.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zbesi.f b/modules/elementary_functions/src/fortran/slatec/zbesi.f new file mode 100755 index 000000000..1b48549c5 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zbesi.f @@ -0,0 +1,276 @@ +*DECK ZBESI + SUBROUTINE ZBESI (ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR) +C***BEGIN PROLOGUE ZBESI +C***PURPOSE Compute a sequence of the Bessel functions I(a,z) for +C complex argument z and real nonnegative orders a=b,b+1, +C b+2,... where b>0. A scaling option is available to +C help avoid overflow. +C***LIBRARY SLATEC +C***CATEGORY C10B4 +C***TYPE COMPLEX (CBESI-C, ZBESI-C) +C***KEYWORDS BESSEL FUNCTIONS OF COMPLEX ARGUMENT, I BESSEL FUNCTIONS, +C MODIFIED BESSEL FUNCTIONS +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C ***A DOUBLE PRECISION ROUTINE*** +C On KODE=1, ZBESI computes an N-member sequence of complex +C Bessel functions CY(L)=I(FNU+L-1,Z) for real nonnegative +C orders FNU+L-1, L=1,...,N and complex Z in the cut plane +C -pi<arg(Z)<=pi where Z=ZR+i*ZI. On KODE=2, CBESI returns +C the scaled functions +C +C CY(L) = exp(-abs(X))*I(FNU+L-1,Z), L=1,...,N and X=Re(Z) +C +C which removes the exponential growth in both the left and +C right half-planes as Z goes to infinity. +C +C Input +C ZR - DOUBLE PRECISION real part of argument Z +C ZI - DOUBLE PRECISION imag part of argument Z +C FNU - DOUBLE PRECISION initial order, FNU>=0 +C KODE - A parameter to indicate the scaling option +C KODE=1 returns +C CY(L)=I(FNU+L-1,Z), L=1,...,N +C =2 returns +C CY(L)=exp(-abs(X))*I(FNU+L-1,Z), L=1,...,N +C where X=Re(Z) +C N - Number of terms in the sequence, N>=1 +C +C Output +C CYR - DOUBLE PRECISION real part of result vector +C CYI - DOUBLE PRECISION imag part of result vector +C NZ - Number of underflows set to zero +C NZ=0 Normal return +C NZ>0 CY(L)=0, L=N-NZ+1,...,N +C IERR - Error flag +C IERR=0 Normal return - COMPUTATION COMPLETED +C IERR=1 Input error - NO COMPUTATION +C IERR=2 Overflow - NO COMPUTATION +C (Re(Z) too large on KODE=1) +C IERR=3 Precision warning - COMPUTATION COMPLETED +C (Result has half precision or less +C because abs(Z) or FNU+N-1 is large) +C IERR=4 Precision error - NO COMPUTATION +C (Result has no precision because +C abs(Z) or FNU+N-1 is too large) +C IERR=5 Algorithmic error - NO COMPUTATION +C (Termination condition not met) +C +C *Long Description: +C +C The computation of I(a,z) is carried out by the power series +C for small abs(z), the asymptotic expansion for large abs(z), +C the Miller algorithm normalized by the Wronskian and a +C Neumann series for intermediate magnitudes of z, and the +C uniform asymptotic expansions for I(a,z) and J(a,z) for +C large orders a. Backward recurrence is used to generate +C sequences or reduce orders when necessary. +C +C The calculations above are done in the right half plane and +C continued into the left half plane by the formula +C +C I(a,z*exp(t)) = exp(t*a)*I(a,z), Re(z)>0 +C t = i*pi or -i*pi +C +C For negative orders, the formula +C +C I(-a,z) = I(a,z) + (2/pi)*sin(pi*a)*K(a,z) +C +C can be used. However, for large orders close to integers the +C the function changes radically. When a is a large positive +C integer, the magnitude of I(-a,z)=I(a,z) is a large +C negative power of ten. But when a is not an integer, +C K(a,z) dominates in magnitude with a large positive power of +C ten and the most that the second term can be reduced is by +C unit roundoff from the coefficient. Thus, wide changes can +C occur within unit roundoff of a large integer for a. Here, +C large means a>abs(z). +C +C In most complex variable computation, one must evaluate ele- +C mentary functions. When the magnitude of Z or FNU+N-1 is +C large, losses of significance by argument reduction occur. +C Consequently, if either one exceeds U1=SQRT(0.5/UR), then +C losses exceeding half precision are likely and an error flag +C IERR=3 is triggered where UR=MAX(D1MACH(4),1.0D-18) is double +C precision unit roundoff limited to 18 digits precision. Also, +C if either is larger than U2=0.5/UR, then all significance is +C lost and IERR=4. In order to use the INT function, arguments +C must be further restricted not to exceed the largest machine +C integer, U3=I1MACH(9). Thus, the magnitude of Z and FNU+N-1 +C is restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, and +C U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision +C and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision. This +C makes U2 limiting in single precision and U3 limiting in +C double precision. This means that one can expect to retain, +C in the worst cases on IEEE machines, no digits in single pre- +C cision and only 6 digits in double precision. Similar con- +C siderations hold for other machines. +C +C The approximate relative error in the magnitude of a complex +C Bessel function can be expressed as P*10**S where P=MAX(UNIT +C ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- +C sents the increase in error due to argument reduction in the +C elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), +C ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF +C ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may +C have only absolute accuracy. This is most likely to occur +C when one component (in magnitude) is larger than the other by +C several orders of magnitude. If one component is 10**K larger +C than the other, then one can expect only MAX(ABS(LOG10(P))-K, +C 0) significant digits; or, stated another way, when K exceeds +C the exponent of P, no significant digits remain in the smaller +C component. However, the phase angle retains absolute accuracy +C because, in complex arithmetic with precision P, the smaller +C component will not (as a rule) decrease below P times the +C magnitude of the larger component. In these extreme cases, +C the principal phase angle is on the order of +P, -P, PI/2-P, +C or -PI/2+P. +C +C***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- +C matical Functions, National Bureau of Standards +C Applied Mathematics Series 55, U. S. Department +C of Commerce, Tenth Printing (1972) or later. +C 2. D. E. Amos, Computation of Bessel Functions of +C Complex Argument, Report SAND83-0086, Sandia National +C Laboratories, Albuquerque, NM, May 1983. +C 3. D. E. Amos, Computation of Bessel Functions of +C Complex Argument and Large Order, Report SAND83-0643, +C Sandia National Laboratories, Albuquerque, NM, May +C 1983. +C 4. D. E. Amos, A Subroutine Package for Bessel Functions +C of a Complex Argument and Nonnegative Order, Report +C SAND85-1018, Sandia National Laboratory, Albuquerque, +C NM, May 1985. +C 5. D. E. Amos, A portable package for Bessel functions +C of a complex argument and nonnegative order, ACM +C Transactions on Mathematical Software, 12 (September +C 1986), pp. 265-273. +C +C***ROUTINES CALLED D1MACH, I1MACH, ZABS, ZBINU +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 890801 REVISION DATE from Version 3.2 +C 910415 Prologue converted to Version 4.0 format. (BAB) +C 920128 Category corrected. (WRB) +C 920811 Prologue revised. (DWL) +C***END PROLOGUE ZBESI +C COMPLEX CONE,CSGN,CW,CY,CZERO,Z,ZN + DOUBLE PRECISION AA, ALIM, ARG, CONEI, CONER, CSGNI, CSGNR, CYI, + * CYR, DIG, ELIM, FNU, FNUL, PI, RL, R1M5, STR, TOL, ZI, ZNI, ZNR, + * ZR, D1MACH, AZ, BB, FN, ZABS, ASCLE, RTOL, ATOL, STI + INTEGER I, IERR, INU, K, KODE, K1,K2,N,NZ,NN, I1MACH + DIMENSION CYR(N), CYI(N) + EXTERNAL ZABS + DATA PI /3.14159265358979324D0/ + DATA CONER, CONEI /1.0D0,0.0D0/ +C +C***FIRST EXECUTABLE STATEMENT ZBESI + IERR = 0 + NZ=0 + IF (FNU.LT.0.0D0) IERR=1 + IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 + IF (N.LT.1) IERR=1 + IF (IERR.NE.0) RETURN +C----------------------------------------------------------------------- +C SET PARAMETERS RELATED TO MACHINE CONSTANTS. +C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. +C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. +C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND +C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR +C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. +C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. +C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). +C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU. +C----------------------------------------------------------------------- + TOL = MAX(D1MACH(4),1.0D-18) + K1 = I1MACH(15) + K2 = I1MACH(16) + R1M5 = D1MACH(5) + K = MIN(ABS(K1),ABS(K2)) + ELIM = 2.303D0*(K*R1M5-3.0D0) + K1 = I1MACH(14) - 1 + AA = R1M5*K1 + DIG = MIN(AA,18.0D0) + AA = AA*2.303D0 + ALIM = ELIM + MAX(-AA,-41.45D0) + RL = 1.2D0*DIG + 3.0D0 + FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) +C----------------------------------------------------------------------- +C TEST FOR PROPER RANGE +C----------------------------------------------------------------------- + AZ = ZABS(ZR,ZI) + FN = FNU+(N-1) + AA = 0.5D0/TOL + BB=I1MACH(9)*0.5D0 + AA = MIN(AA,BB) + IF (AZ.GT.AA) GO TO 260 + IF (FN.GT.AA) GO TO 260 + AA = SQRT(AA) + IF (AZ.GT.AA) IERR=3 + IF (FN.GT.AA) IERR=3 + ZNR = ZR + ZNI = ZI + CSGNR = CONER + CSGNI = CONEI + IF (ZR.GE.0.0D0) GO TO 40 + ZNR = -ZR + ZNI = -ZI +C----------------------------------------------------------------------- +C CALCULATE CSGN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE +C WHEN FNU IS LARGE +C----------------------------------------------------------------------- + INU = FNU + ARG = (FNU-INU)*PI + IF (ZI.LT.0.0D0) ARG = -ARG + CSGNR = COS(ARG) + CSGNI = SIN(ARG) + IF (MOD(INU,2).EQ.0) GO TO 40 + CSGNR = -CSGNR + CSGNI = -CSGNI + 40 CONTINUE + CALL ZBINU(ZNR, ZNI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL, TOL, + * ELIM, ALIM) + IF (NZ.LT.0) GO TO 120 + IF (ZR.GE.0.0D0) RETURN +C----------------------------------------------------------------------- +C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE +C----------------------------------------------------------------------- + NN = N - NZ + IF (NN.EQ.0) RETURN + RTOL = 1.0D0/TOL + ASCLE = D1MACH(1)*RTOL*1.0D+3 + DO 50 I=1,NN +C STR = CYR(I)*CSGNR - CYI(I)*CSGNI +C CYI(I) = CYR(I)*CSGNI + CYI(I)*CSGNR +C CYR(I) = STR + AA = CYR(I) + BB = CYI(I) + ATOL = 1.0D0 + IF (MAX(ABS(AA),ABS(BB)).GT.ASCLE) GO TO 55 + AA = AA*RTOL + BB = BB*RTOL + ATOL = TOL + 55 CONTINUE + STR = AA*CSGNR - BB*CSGNI + STI = AA*CSGNI + BB*CSGNR + CYR(I) = STR*ATOL + CYI(I) = STI*ATOL + CSGNR = -CSGNR + CSGNI = -CSGNI + 50 CONTINUE + RETURN + 120 CONTINUE + IF(NZ.EQ.(-2)) GO TO 130 + NZ = 0 + IERR=2 + RETURN + 130 CONTINUE + NZ=0 + IERR=5 + RETURN + 260 CONTINUE + NZ=0 + IERR=4 + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zbesi.lo b/modules/elementary_functions/src/fortran/slatec/zbesi.lo new file mode 100755 index 000000000..572ade086 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zbesi.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zbesi.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zbesi.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zbesj.f b/modules/elementary_functions/src/fortran/slatec/zbesj.f new file mode 100755 index 000000000..bdc22a58d --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zbesj.f @@ -0,0 +1,276 @@ +*DECK ZBESJ + SUBROUTINE ZBESJ (ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR) +C***BEGIN PROLOGUE ZBESJ +C***PURPOSE Compute a sequence of the Bessel functions J(a,z) for +C complex argument z and real nonnegative orders a=b,b+1, +C b+2,... where b>0. A scaling option is available to +C help avoid overflow. +C***LIBRARY SLATEC +C***CATEGORY C10A4 +C***TYPE COMPLEX (CBESJ-C, ZBESJ-C) +C***KEYWORDS BESSEL FUNCTIONS OF COMPLEX ARGUMENT, +C BESSEL FUNCTIONS OF THE FIRST KIND, J BESSEL FUNCTIONS +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C ***A DOUBLE PRECISION ROUTINE*** +C On KODE=1, ZBESJ computes an N member sequence of complex +C Bessel functions CY(L)=J(FNU+L-1,Z) for real nonnegative +C orders FNU+L-1, L=1,...,N and complex Z in the cut plane +C -pi<arg(Z)<=pi where Z=ZR+i*ZI. On KODE=2, CBESJ returns +C the scaled functions +C +C CY(L) = exp(-abs(Y))*J(FNU+L-1,Z), L=1,...,N and Y=Im(Z) +C +C which remove the exponential growth in both the upper and +C lower half planes as Z goes to infinity. Definitions and +C notation are found in the NBS Handbook of Mathematical +C Functions (Ref. 1). +C +C Input +C ZR - DOUBLE PRECISION real part of argument Z +C ZI - DOUBLE PRECISION imag part of argument Z +C FNU - DOUBLE PRECISION initial order, FNU>=0 +C KODE - A parameter to indicate the scaling option +C KODE=1 returns +C CY(L)=J(FNU+L-1,Z), L=1,...,N +C =2 returns +C CY(L)=J(FNU+L-1,Z)*exp(-abs(Y)), L=1,...,N +C where Y=Im(Z) +C N - Number of terms in the sequence, N>=1 +C +C Output +C CYR - DOUBLE PRECISION real part of result vector +C CYI - DOUBLE PRECISION imag part of result vector +C NZ - Number of underflows set to zero +C NZ=0 Normal return +C NZ>0 CY(L)=0, L=N-NZ+1,...,N +C IERR - Error flag +C IERR=0 Normal return - COMPUTATION COMPLETED +C IERR=1 Input error - NO COMPUTATION +C IERR=2 Overflow - NO COMPUTATION +C (Im(Z) too large on KODE=1) +C IERR=3 Precision warning - COMPUTATION COMPLETED +C (Result has half precision or less +C because abs(Z) or FNU+N-1 is large) +C IERR=4 Precision error - NO COMPUTATION +C (Result has no precision because +C abs(Z) or FNU+N-1 is too large) +C IERR=5 Algorithmic error - NO COMPUTATION +C (Termination condition not met) +C +C *Long Description: +C +C The computation is carried out by the formulae +C +C J(a,z) = exp( a*pi*i/2)*I(a,-i*z), Im(z)>=0 +C +C J(a,z) = exp(-a*pi*i/2)*I(a, i*z), Im(z)<0 +C +C where the I Bessel function is computed as described in the +C prologue to CBESI. +C +C For negative orders, the formula +C +C J(-a,z) = J(a,z)*cos(a*pi) - Y(a,z)*sin(a*pi) +C +C can be used. However, for large orders close to integers, the +C the function changes radically. When a is a large positive +C integer, the magnitude of J(-a,z)=J(a,z)*cos(a*pi) is a +C large negative power of ten. But when a is not an integer, +C Y(a,z) dominates in magnitude with a large positive power of +C ten and the most that the second term can be reduced is by +C unit roundoff from the coefficient. Thus, wide changes can +C occur within unit roundoff of a large integer for a. Here, +C large means a>abs(z). +C +C In most complex variable computation, one must evaluate ele- +C mentary functions. When the magnitude of Z or FNU+N-1 is +C large, losses of significance by argument reduction occur. +C Consequently, if either one exceeds U1=SQRT(0.5/UR), then +C losses exceeding half precision are likely and an error flag +C IERR=3 is triggered where UR=MAX(D1MACH(4),1.0D-18) is double +C precision unit roundoff limited to 18 digits precision. Also, +C if either is larger than U2=0.5/UR, then all significance is +C lost and IERR=4. In order to use the INT function, arguments +C must be further restricted not to exceed the largest machine +C integer, U3=I1MACH(9). Thus, the magnitude of Z and FNU+N-1 +C is restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, and +C U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision +C and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision. This +C makes U2 limiting in single precision and U3 limiting in +C double precision. This means that one can expect to retain, +C in the worst cases on IEEE machines, no digits in single pre- +C cision and only 6 digits in double precision. Similar con- +C siderations hold for other machines. +C +C The approximate relative error in the magnitude of a complex +C Bessel function can be expressed as P*10**S where P=MAX(UNIT +C ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- +C sents the increase in error due to argument reduction in the +C elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), +C ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF +C ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may +C have only absolute accuracy. This is most likely to occur +C when one component (in magnitude) is larger than the other by +C several orders of magnitude. If one component is 10**K larger +C than the other, then one can expect only MAX(ABS(LOG10(P))-K, +C 0) significant digits; or, stated another way, when K exceeds +C the exponent of P, no significant digits remain in the smaller +C component. However, the phase angle retains absolute accuracy +C because, in complex arithmetic with precision P, the smaller +C component will not (as a rule) decrease below P times the +C magnitude of the larger component. In these extreme cases, +C the principal phase angle is on the order of +P, -P, PI/2-P, +C or -PI/2+P. +C +C***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- +C matical Functions, National Bureau of Standards +C Applied Mathematics Series 55, U. S. Department +C of Commerce, Tenth Printing (1972) or later. +C 2. D. E. Amos, Computation of Bessel Functions of +C Complex Argument, Report SAND83-0086, Sandia National +C Laboratories, Albuquerque, NM, May 1983. +C 3. D. E. Amos, Computation of Bessel Functions of +C Complex Argument and Large Order, Report SAND83-0643, +C Sandia National Laboratories, Albuquerque, NM, May +C 1983. +C 4. D. E. Amos, A Subroutine Package for Bessel Functions +C of a Complex Argument and Nonnegative Order, Report +C SAND85-1018, Sandia National Laboratory, Albuquerque, +C NM, May 1985. +C 5. D. E. Amos, A portable package for Bessel functions +C of a complex argument and nonnegative order, ACM +C Transactions on Mathematical Software, 12 (September +C 1986), pp. 265-273. +C +C***ROUTINES CALLED D1MACH, I1MACH, ZABS, ZBINU +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 890801 REVISION DATE from Version 3.2 +C 910415 Prologue converted to Version 4.0 format. (BAB) +C 920128 Category corrected. (WRB) +C 920811 Prologue revised. (DWL) +C***END PROLOGUE ZBESJ +C +C COMPLEX CI,CSGN,CY,Z,ZN + DOUBLE PRECISION AA, ALIM, ARG, CII, CSGNI, CSGNR, CYI, CYR, DIG, + * ELIM, FNU, FNUL, HPI, RL, R1M5, STR, TOL, ZI, ZNI, ZNR, ZR, + * D1MACH, BB, FN, AZ, ZABS, ASCLE, RTOL, ATOL, STI + INTEGER I, IERR, INU, INUH, IR, K, KODE, K1, K2, N, NL, NZ, I1MACH + DIMENSION CYR(N), CYI(N) + EXTERNAL ZABS + DATA HPI /1.57079632679489662D0/ +C +C***FIRST EXECUTABLE STATEMENT ZBESJ + IERR = 0 + NZ=0 + IF (FNU.LT.0.0D0) IERR=1 + IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 + IF (N.LT.1) IERR=1 + IF (IERR.NE.0) RETURN +C----------------------------------------------------------------------- +C SET PARAMETERS RELATED TO MACHINE CONSTANTS. +C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. +C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. +C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND +C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR +C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. +C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. +C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). +C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU. +C----------------------------------------------------------------------- + TOL = MAX(D1MACH(4),1.0D-18) + K1 = I1MACH(15) + K2 = I1MACH(16) + R1M5 = D1MACH(5) + K = MIN(ABS(K1),ABS(K2)) + ELIM = 2.303D0*(K*R1M5-3.0D0) + K1 = I1MACH(14) - 1 + AA = R1M5*K1 + DIG = MIN(AA,18.0D0) + AA = AA*2.303D0 + ALIM = ELIM + MAX(-AA,-41.45D0) + RL = 1.2D0*DIG + 3.0D0 + FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) +C----------------------------------------------------------------------- +C TEST FOR PROPER RANGE +C----------------------------------------------------------------------- + AZ = ZABS(ZR,ZI) + FN = FNU+(N-1) + AA = 0.5D0/TOL + BB = I1MACH(9)*0.5D0 + AA = MIN(AA,BB) + IF (AZ.GT.AA) GO TO 260 + IF (FN.GT.AA) GO TO 260 + AA = SQRT(AA) + IF (AZ.GT.AA) IERR=3 + IF (FN.GT.AA) IERR=3 +C----------------------------------------------------------------------- +C CALCULATE CSGN=EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE +C WHEN FNU IS LARGE +C----------------------------------------------------------------------- + CII = 1.0D0 + INU = FNU + INUH = INU/2 + IR = INU - 2*INUH + ARG = (FNU-(INU-IR))*HPI + CSGNR = COS(ARG) + CSGNI = SIN(ARG) + IF (MOD(INUH,2).EQ.0) GO TO 40 + CSGNR = -CSGNR + CSGNI = -CSGNI + 40 CONTINUE +C----------------------------------------------------------------------- +C ZN IS IN THE RIGHT HALF PLANE +C----------------------------------------------------------------------- + ZNR = ZI + ZNI = -ZR + IF (ZI.GE.0.0D0) GO TO 50 + ZNR = -ZNR + ZNI = -ZNI + CSGNI = -CSGNI + CII = -CII + 50 CONTINUE + CALL ZBINU(ZNR, ZNI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL, TOL, + * ELIM, ALIM) + IF (NZ.LT.0) GO TO 130 + NL = N - NZ + IF (NL.EQ.0) RETURN + RTOL = 1.0D0/TOL + ASCLE = D1MACH(1)*RTOL*1.0D+3 + DO 60 I=1,NL +C STR = CYR(I)*CSGNR - CYI(I)*CSGNI +C CYI(I) = CYR(I)*CSGNI + CYI(I)*CSGNR +C CYR(I) = STR + AA = CYR(I) + BB = CYI(I) + ATOL = 1.0D0 + IF (MAX(ABS(AA),ABS(BB)).GT.ASCLE) GO TO 55 + AA = AA*RTOL + BB = BB*RTOL + ATOL = TOL + 55 CONTINUE + STR = AA*CSGNR - BB*CSGNI + STI = AA*CSGNI + BB*CSGNR + CYR(I) = STR*ATOL + CYI(I) = STI*ATOL + STR = -CSGNI*CII + CSGNI = CSGNR*CII + CSGNR = STR + 60 CONTINUE + RETURN + 130 CONTINUE + IF(NZ.EQ.(-2)) GO TO 140 + NZ = 0 + IERR = 2 + RETURN + 140 CONTINUE + NZ=0 + IERR=5 + RETURN + 260 CONTINUE + NZ=0 + IERR=4 + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zbesj.lo b/modules/elementary_functions/src/fortran/slatec/zbesj.lo new file mode 100755 index 000000000..0fe8fadfe --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zbesj.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zbesj.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zbesj.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zbesk.f b/modules/elementary_functions/src/fortran/slatec/zbesk.f new file mode 100755 index 000000000..670b9f01d --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zbesk.f @@ -0,0 +1,286 @@ +*DECK ZBESK + SUBROUTINE ZBESK (ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR) +C***BEGIN PROLOGUE ZBESK +C***PURPOSE Compute a sequence of the Bessel functions K(a,z) for +C complex argument z and real nonnegative orders a=b,b+1, +C b+2,... where b>0. A scaling option is available to +C help avoid overflow. +C***LIBRARY SLATEC +C***CATEGORY C10B4 +C***TYPE COMPLEX (CBESK-C, ZBESK-C) +C***KEYWORDS BESSEL FUNCTIONS OF COMPLEX ARGUMENT, K BESSEL FUNCTIONS, +C MODIFIED BESSEL FUNCTIONS +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C ***A DOUBLE PRECISION ROUTINE*** +C On KODE=1, ZBESK computes an N member sequence of complex +C Bessel functions CY(L)=K(FNU+L-1,Z) for real nonnegative +C orders FNU+L-1, L=1,...,N and complex Z.NE.0 in the cut +C plane -pi<arg(Z)<=pi where Z=ZR+i*ZI. On KODE=2, CBESJ +C returns the scaled functions +C +C CY(L) = exp(Z)*K(FNU+L-1,Z), L=1,...,N +C +C which remove the exponential growth in both the left and +C right half planes as Z goes to infinity. Definitions and +C notation are found in the NBS Handbook of Mathematical +C Functions (Ref. 1). +C +C Input +C ZR - DOUBLE PRECISION real part of nonzero argument Z +C ZI - DOUBLE PRECISION imag part of nonzero argument Z +C FNU - DOUBLE PRECISION initial order, FNU>=0 +C KODE - A parameter to indicate the scaling option +C KODE=1 returns +C CY(L)=K(FNU+L-1,Z), L=1,...,N +C =2 returns +C CY(L)=K(FNU+L-1,Z)*EXP(Z), L=1,...,N +C N - Number of terms in the sequence, N>=1 +C +C Output +C CYR - DOUBLE PRECISION real part of result vector +C CYI - DOUBLE PRECISION imag part of result vector +C NZ - Number of underflows set to zero +C NZ=0 Normal return +C NZ>0 CY(L)=0 for NZ values of L (if Re(Z)>0 +C then CY(L)=0 for L=1,...,NZ; in the +C complementary half plane the underflows +C may not be in an uninterrupted sequence) +C IERR - Error flag +C IERR=0 Normal return - COMPUTATION COMPLETED +C IERR=1 Input error - NO COMPUTATION +C IERR=2 Overflow - NO COMPUTATION +C (abs(Z) too small and/or FNU+N-1 +C too large) +C IERR=3 Precision warning - COMPUTATION COMPLETED +C (Result has half precision or less +C because abs(Z) or FNU+N-1 is large) +C IERR=4 Precision error - NO COMPUTATION +C (Result has no precision because +C abs(Z) or FNU+N-1 is too large) +C IERR=5 Algorithmic error - NO COMPUTATION +C (Termination condition not met) +C +C *Long Description: +C +C Equations of the reference are implemented to compute K(a,z) +C for small orders a and a+1 in the right half plane Re(z)>=0. +C Forward recurrence generates higher orders. The formula +C +C K(a,z*exp((t)) = exp(-t)*K(a,z) - t*I(a,z), Re(z)>0 +C t = i*pi or -i*pi +C +C continues K to the left half plane. +C +C For large orders, K(a,z) is computed by means of its uniform +C asymptotic expansion. +C +C For negative orders, the formula +C +C K(-a,z) = K(a,z) +C +C can be used. +C +C CBESK assumes that a significant digit sinh function is +C available. +C +C In most complex variable computation, one must evaluate ele- +C mentary functions. When the magnitude of Z or FNU+N-1 is +C large, losses of significance by argument reduction occur. +C Consequently, if either one exceeds U1=SQRT(0.5/UR), then +C losses exceeding half precision are likely and an error flag +C IERR=3 is triggered where UR=MAX(D1MACH(4),1.0D-18) is double +C precision unit roundoff limited to 18 digits precision. Also, +C if either is larger than U2=0.5/UR, then all significance is +C lost and IERR=4. In order to use the INT function, arguments +C must be further restricted not to exceed the largest machine +C integer, U3=I1MACH(9). Thus, the magnitude of Z and FNU+N-1 +C is restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, and +C U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision +C and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision. This +C makes U2 limiting in single precision and U3 limiting in +C double precision. This means that one can expect to retain, +C in the worst cases on IEEE machines, no digits in single pre- +C cision and only 6 digits in double precision. Similar con- +C siderations hold for other machines. +C +C The approximate relative error in the magnitude of a complex +C Bessel function can be expressed as P*10**S where P=MAX(UNIT +C ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- +C sents the increase in error due to argument reduction in the +C elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), +C ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF +C ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may +C have only absolute accuracy. This is most likely to occur +C when one component (in magnitude) is larger than the other by +C several orders of magnitude. If one component is 10**K larger +C than the other, then one can expect only MAX(ABS(LOG10(P))-K, +C 0) significant digits; or, stated another way, when K exceeds +C the exponent of P, no significant digits remain in the smaller +C component. However, the phase angle retains absolute accuracy +C because, in complex arithmetic with precision P, the smaller +C component will not (as a rule) decrease below P times the +C magnitude of the larger component. In these extreme cases, +C the principal phase angle is on the order of +P, -P, PI/2-P, +C or -PI/2+P. +C +C***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- +C matical Functions, National Bureau of Standards +C Applied Mathematics Series 55, U. S. Department +C of Commerce, Tenth Printing (1972) or later. +C 2. D. E. Amos, Computation of Bessel Functions of +C Complex Argument, Report SAND83-0086, Sandia National +C Laboratories, Albuquerque, NM, May 1983. +C 3. D. E. Amos, Computation of Bessel Functions of +C Complex Argument and Large Order, Report SAND83-0643, +C Sandia National Laboratories, Albuquerque, NM, May +C 1983. +C 4. D. E. Amos, A Subroutine Package for Bessel Functions +C of a Complex Argument and Nonnegative Order, Report +C SAND85-1018, Sandia National Laboratory, Albuquerque, +C NM, May 1985. +C 5. D. E. Amos, A portable package for Bessel functions +C of a complex argument and nonnegative order, ACM +C Transactions on Mathematical Software, 12 (September +C 1986), pp. 265-273. +C +C***ROUTINES CALLED D1MACH, I1MACH, ZABS, ZACON, ZBKNU, ZBUNK, ZUOIK +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 890801 REVISION DATE from Version 3.2 +C 910415 Prologue converted to Version 4.0 format. (BAB) +C 920128 Category corrected. (WRB) +C 920811 Prologue revised. (DWL) +C***END PROLOGUE ZBESK +C +C COMPLEX CY,Z + DOUBLE PRECISION AA, ALIM, ALN, ARG, AZ, CYI, CYR, DIG, ELIM, FN, + * FNU, FNUL, RL, R1M5, TOL, UFL, ZI, ZR, D1MACH, ZABS, BB + INTEGER IERR, K, KODE, K1, K2, MR, N, NN, NUF, NW, NZ, I1MACH + DIMENSION CYR(N), CYI(N) + EXTERNAL ZABS +C***FIRST EXECUTABLE STATEMENT ZBESK + IERR = 0 + NZ=0 + IF (ZI.EQ.0.0E0 .AND. ZR.EQ.0.0E0) IERR=1 + IF (FNU.LT.0.0D0) IERR=1 + IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 + IF (N.LT.1) IERR=1 + IF (IERR.NE.0) RETURN + NN = N +C----------------------------------------------------------------------- +C SET PARAMETERS RELATED TO MACHINE CONSTANTS. +C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. +C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. +C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND +C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR +C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. +C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. +C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). +C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU +C----------------------------------------------------------------------- + TOL = MAX(D1MACH(4),1.0D-18) + K1 = I1MACH(15) + K2 = I1MACH(16) + R1M5 = D1MACH(5) + K = MIN(ABS(K1),ABS(K2)) + ELIM = 2.303D0*(K*R1M5-3.0D0) + K1 = I1MACH(14) - 1 + AA = R1M5*K1 + DIG = MIN(AA,18.0D0) + AA = AA*2.303D0 + ALIM = ELIM + MAX(-AA,-41.45D0) + FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) + RL = 1.2D0*DIG + 3.0D0 +C----------------------------------------------------------------------- +C TEST FOR PROPER RANGE +C----------------------------------------------------------------------- + AZ = ZABS(ZR,ZI) + FN = FNU + (NN-1) + AA = 0.5D0/TOL + BB = I1MACH(9)*0.5D0 + AA = MIN(AA,BB) + IF (AZ.GT.AA) GO TO 260 + IF (FN.GT.AA) GO TO 260 + AA = SQRT(AA) + IF (AZ.GT.AA) IERR=3 + IF (FN.GT.AA) IERR=3 +C----------------------------------------------------------------------- +C OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE +C----------------------------------------------------------------------- +C UFL = EXP(-ELIM) + UFL = D1MACH(1)*1.0D+3 + IF (AZ.LT.UFL) GO TO 180 + IF (FNU.GT.FNUL) GO TO 80 + IF (FN.LE.1.0D0) GO TO 60 + IF (FN.GT.2.0D0) GO TO 50 + IF (AZ.GT.TOL) GO TO 60 + ARG = 0.5D0*AZ + ALN = -FN*LOG(ARG) + IF (ALN.GT.ELIM) GO TO 180 + GO TO 60 + 50 CONTINUE + CALL ZUOIK(ZR, ZI, FNU, KODE, 2, NN, CYR, CYI, NUF, TOL, ELIM, + * ALIM) + IF (NUF.LT.0) GO TO 180 + NZ = NZ + NUF + NN = NN - NUF +C----------------------------------------------------------------------- +C HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK +C IF NUF=NN, THEN CY(I)=CZERO FOR ALL I +C----------------------------------------------------------------------- + IF (NN.EQ.0) GO TO 100 + 60 CONTINUE + IF (ZR.LT.0.0D0) GO TO 70 +C----------------------------------------------------------------------- +C RIGHT HALF PLANE COMPUTATION, REAL(Z).GE.0. +C----------------------------------------------------------------------- + CALL ZBKNU(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM) + IF (NW.LT.0) GO TO 200 + NZ=NW + RETURN +C----------------------------------------------------------------------- +C LEFT HALF PLANE COMPUTATION +C PI/2.LT.ARG(Z).LE.PI AND -PI.LT.ARG(Z).LT.-PI/2. +C----------------------------------------------------------------------- + 70 CONTINUE + IF (NZ.NE.0) GO TO 180 + MR = 1 + IF (ZI.LT.0.0D0) MR = -1 + CALL ZACON(ZR, ZI, FNU, KODE, MR, NN, CYR, CYI, NW, RL, FNUL, + * TOL, ELIM, ALIM) + IF (NW.LT.0) GO TO 200 + NZ=NW + RETURN +C----------------------------------------------------------------------- +C UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU.GT.FNUL +C----------------------------------------------------------------------- + 80 CONTINUE + MR = 0 + IF (ZR.GE.0.0D0) GO TO 90 + MR = 1 + IF (ZI.LT.0.0D0) MR = -1 + 90 CONTINUE + CALL ZBUNK(ZR, ZI, FNU, KODE, MR, NN, CYR, CYI, NW, TOL, ELIM, + * ALIM) + IF (NW.LT.0) GO TO 200 + NZ = NZ + NW + RETURN + 100 CONTINUE + IF (ZR.LT.0.0D0) GO TO 180 + RETURN + 180 CONTINUE + NZ = 0 + IERR=2 + RETURN + 200 CONTINUE + IF(NW.EQ.(-1)) GO TO 180 + NZ=0 + IERR=5 + RETURN + 260 CONTINUE + NZ=0 + IERR=4 + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zbesk.lo b/modules/elementary_functions/src/fortran/slatec/zbesk.lo new file mode 100755 index 000000000..04e2b4267 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zbesk.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zbesk.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zbesk.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zbesy.f b/modules/elementary_functions/src/fortran/slatec/zbesy.f new file mode 100755 index 000000000..911217ac2 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zbesy.f @@ -0,0 +1,254 @@ +*DECK ZBESY + SUBROUTINE ZBESY (ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, CWRKR, + + CWRKI, IERR) +C***BEGIN PROLOGUE ZBESY +C***PURPOSE Compute a sequence of the Bessel functions Y(a,z) for +C complex argument z and real nonnegative orders a=b,b+1, +C b+2,... where b>0. A scaling option is available to +C help avoid overflow. +C***LIBRARY SLATEC +C***CATEGORY C10A4 +C***TYPE COMPLEX (CBESY-C, ZBESY-C) +C***KEYWORDS BESSEL FUNCTIONS OF COMPLEX ARGUMENT, +C BESSEL FUNCTIONS OF SECOND KIND, WEBER'S FUNCTION, +C Y BESSEL FUNCTIONS +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C ***A DOUBLE PRECISION ROUTINE*** +C On KODE=1, ZBESY computes an N member sequence of complex +C Bessel functions CY(L)=Y(FNU+L-1,Z) for real nonnegative +C orders FNU+L-1, L=1,...,N and complex Z in the cut plane +C -pi<arg(Z)<=pi where Z=ZR+i*ZI. On KODE=2, CBESY returns +C the scaled functions +C +C CY(L) = exp(-abs(Y))*Y(FNU+L-1,Z), L=1,...,N, Y=Im(Z) +C +C which remove the exponential growth in both the upper and +C lower half planes as Z goes to infinity. Definitions and +C notation are found in the NBS Handbook of Mathematical +C Functions (Ref. 1). +C +C Input +C ZR - DOUBLE PRECISION real part of nonzero argument Z +C ZI - DOUBLE PRECISION imag part of nonzero argument Z +C FNU - DOUBLE PRECISION initial order, FNU>=0 +C KODE - A parameter to indicate the scaling option +C KODE=1 returns +C CY(L)=Y(FNU+L-1,Z), L=1,...,N +C =2 returns +C CY(L)=Y(FNU+L-1,Z)*exp(-abs(Y)), L=1,...,N +C where Y=Im(Z) +C N - Number of terms in the sequence, N>=1 +C CWRKR - DOUBLE PRECISION work vector of dimension N +C CWRKI - DOUBLE PRECISION work vector of dimension N +C +C Output +C CYR - DOUBLE PRECISION real part of result vector +C CYI - DOUBLE PRECISION imag part of result vector +C NZ - Number of underflows set to zero +C NZ=0 Normal return +C NZ>0 CY(L)=0 for NZ values of L, usually on +C KODE=2 (the underflows may not be in an +C uninterrupted sequence) +C IERR - Error flag +C IERR=0 Normal return - COMPUTATION COMPLETED +C IERR=1 Input error - NO COMPUTATION +C IERR=2 Overflow - NO COMPUTATION +C (abs(Z) too small and/or FNU+N-1 +C too large) +C IERR=3 Precision warning - COMPUTATION COMPLETED +C (Result has half precision or less +C because abs(Z) or FNU+N-1 is large) +C IERR=4 Precision error - NO COMPUTATION +C (Result has no precision because +C abs(Z) or FNU+N-1 is too large) +C IERR=5 Algorithmic error - NO COMPUTATION +C (Termination condition not met) +C +C *Long Description: +C +C The computation is carried out by the formula +C +C Y(a,z) = (H(1,a,z) - H(2,a,z))/(2*i) +C +C where the Hankel functions are computed as described in CBESH. +C +C For negative orders, the formula +C +C Y(-a,z) = Y(a,z)*cos(a*pi) + J(a,z)*sin(a*pi) +C +C can be used. However, for large orders close to half odd +C integers the function changes radically. When a is a large +C positive half odd integer, the magnitude of Y(-a,z)=J(a,z)* +C sin(a*pi) is a large negative power of ten. But when a is +C not a half odd integer, Y(a,z) dominates in magnitude with a +C large positive power of ten and the most that the second term +C can be reduced is by unit roundoff from the coefficient. +C Thus, wide changes can occur within unit roundoff of a large +C half odd integer. Here, large means a>abs(z). +C +C In most complex variable computation, one must evaluate ele- +C mentary functions. When the magnitude of Z or FNU+N-1 is +C large, losses of significance by argument reduction occur. +C Consequently, if either one exceeds U1=SQRT(0.5/UR), then +C losses exceeding half precision are likely and an error flag +C IERR=3 is triggered where UR=MAX(D1MACH(4),1.0D-18) is double +C precision unit roundoff limited to 18 digits precision. Also, +C if either is larger than U2=0.5/UR, then all significance is +C lost and IERR=4. In order to use the INT function, arguments +C must be further restricted not to exceed the largest machine +C integer, U3=I1MACH(9). Thus, the magnitude of Z and FNU+N-1 +C is restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, and +C U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision +C and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision. This +C makes U2 limiting in single precision and U3 limiting in +C double precision. This means that one can expect to retain, +C in the worst cases on IEEE machines, no digits in single pre- +C cision and only 6 digits in double precision. Similar con- +C siderations hold for other machines. +C +C The approximate relative error in the magnitude of a complex +C Bessel function can be expressed as P*10**S where P=MAX(UNIT +C ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- +C sents the increase in error due to argument reduction in the +C elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), +C ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF +C ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may +C have only absolute accuracy. This is most likely to occur +C when one component (in magnitude) is larger than the other by +C several orders of magnitude. If one component is 10**K larger +C than the other, then one can expect only MAX(ABS(LOG10(P))-K, +C 0) significant digits; or, stated another way, when K exceeds +C the exponent of P, no significant digits remain in the smaller +C component. However, the phase angle retains absolute accuracy +C because, in complex arithmetic with precision P, the smaller +C component will not (as a rule) decrease below P times the +C magnitude of the larger component. In these extreme cases, +C the principal phase angle is on the order of +P, -P, PI/2-P, +C or -PI/2+P. +C +C***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- +C matical Functions, National Bureau of Standards +C Applied Mathematics Series 55, U. S. Department +C of Commerce, Tenth Printing (1972) or later. +C 2. D. E. Amos, Computation of Bessel Functions of +C Complex Argument, Report SAND83-0086, Sandia National +C Laboratories, Albuquerque, NM, May 1983. +C 3. D. E. Amos, Computation of Bessel Functions of +C Complex Argument and Large Order, Report SAND83-0643, +C Sandia National Laboratories, Albuquerque, NM, May +C 1983. +C 4. D. E. Amos, A Subroutine Package for Bessel Functions +C of a Complex Argument and Nonnegative Order, Report +C SAND85-1018, Sandia National Laboratory, Albuquerque, +C NM, May 1985. +C 5. D. E. Amos, A portable package for Bessel functions +C of a complex argument and nonnegative order, ACM +C Transactions on Mathematical Software, 12 (September +C 1986), pp. 265-273. +C +C***ROUTINES CALLED D1MACH, I1MACH, ZBESH +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 890801 REVISION DATE from Version 3.2 +C 910415 Prologue converted to Version 4.0 format. (BAB) +C 920128 Category corrected. (WRB) +C 920811 Prologue revised. (DWL) +C***END PROLOGUE ZBESY +C +C COMPLEX CWRK,CY,C1,C2,EX,HCI,Z,ZU,ZV + DOUBLE PRECISION CWRKI, CWRKR, CYI, CYR, C1I, C1R, C2I, C2R, + * ELIM, EXI, EXR, EY, FNU, HCII, STI, STR, TAY, ZI, ZR, + * D1MACH, ASCLE, RTOL, ATOL, AA, BB, TOL, R1M5 + INTEGER I, IERR, K, KODE, K1, K2, N, NZ, NZ1, NZ2, I1MACH + DIMENSION CYR(N), CYI(N), CWRKR(N), CWRKI(N) +C***FIRST EXECUTABLE STATEMENT ZBESY + IERR = 0 + NZ=0 + IF (ZR.EQ.0.0D0 .AND. ZI.EQ.0.0D0) IERR=1 + IF (FNU.LT.0.0D0) IERR=1 + IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 + IF (N.LT.1) IERR=1 + IF (IERR.NE.0) RETURN + HCII = 0.5D0 + CALL ZBESH(ZR, ZI, FNU, KODE, 1, N, CYR, CYI, NZ1, IERR) + IF (IERR.NE.0.AND.IERR.NE.3) GO TO 170 + CALL ZBESH(ZR, ZI, FNU, KODE, 2, N, CWRKR, CWRKI, NZ2, IERR) + IF (IERR.NE.0.AND.IERR.NE.3) GO TO 170 + NZ = MIN(NZ1,NZ2) + IF (KODE.EQ.2) GO TO 60 + DO 50 I=1,N + STR = CWRKR(I) - CYR(I) + STI = CWRKI(I) - CYI(I) + CYR(I) = -STI*HCII + CYI(I) = STR*HCII + 50 CONTINUE + RETURN + 60 CONTINUE + TOL = MAX(D1MACH(4),1.0D-18) + K1 = I1MACH(15) + K2 = I1MACH(16) + K = MIN(ABS(K1),ABS(K2)) + R1M5 = D1MACH(5) +C----------------------------------------------------------------------- +C ELIM IS THE APPROXIMATE EXPONENTIAL UNDER- AND OVERFLOW LIMIT +C----------------------------------------------------------------------- + ELIM = 2.303D0*(K*R1M5-3.0D0) + EXR = COS(ZR) + EXI = SIN(ZR) + EY = 0.0D0 + TAY = ABS(ZI+ZI) + IF (TAY.LT.ELIM) EY = EXP(-TAY) + IF (ZI.LT.0.0D0) GO TO 90 + C1R = EXR*EY + C1I = EXI*EY + C2R = EXR + C2I = -EXI + 70 CONTINUE + NZ = 0 + RTOL = 1.0D0/TOL + ASCLE = D1MACH(1)*RTOL*1.0D+3 + DO 80 I=1,N +C STR = C1R*CYR(I) - C1I*CYI(I) +C STI = C1R*CYI(I) + C1I*CYR(I) +C STR = -STR + C2R*CWRKR(I) - C2I*CWRKI(I) +C STI = -STI + C2R*CWRKI(I) + C2I*CWRKR(I) +C CYR(I) = -STI*HCII +C CYI(I) = STR*HCII + AA = CWRKR(I) + BB = CWRKI(I) + ATOL = 1.0D0 + IF (MAX(ABS(AA),ABS(BB)).GT.ASCLE) GO TO 75 + AA = AA*RTOL + BB = BB*RTOL + ATOL = TOL + 75 CONTINUE + STR = (AA*C2R - BB*C2I)*ATOL + STI = (AA*C2I + BB*C2R)*ATOL + AA = CYR(I) + BB = CYI(I) + ATOL = 1.0D0 + IF (MAX(ABS(AA),ABS(BB)).GT.ASCLE) GO TO 85 + AA = AA*RTOL + BB = BB*RTOL + ATOL = TOL + 85 CONTINUE + STR = STR - (AA*C1R - BB*C1I)*ATOL + STI = STI - (AA*C1I + BB*C1R)*ATOL + CYR(I) = -STI*HCII + CYI(I) = STR*HCII + IF (STR.EQ.0.0D0 .AND. STI.EQ.0.0D0 .AND. EY.EQ.0.0D0) NZ = NZ + * + 1 + 80 CONTINUE + RETURN + 90 CONTINUE + C1R = EXR + C1I = EXI + C2R = EXR*EY + C2I = -EXI*EY + GO TO 70 + 170 CONTINUE + NZ = 0 + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zbesy.lo b/modules/elementary_functions/src/fortran/slatec/zbesy.lo new file mode 100755 index 000000000..d93a28ddc --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zbesy.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zbesy.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zbesy.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zbinu.f b/modules/elementary_functions/src/fortran/slatec/zbinu.f new file mode 100755 index 000000000..af090de93 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zbinu.f @@ -0,0 +1,121 @@ +*DECK ZBINU + SUBROUTINE ZBINU (ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL, + + TOL, ELIM, ALIM) +C***BEGIN PROLOGUE ZBINU +C***SUBSIDIARY +C***PURPOSE Subsidiary to ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK and ZBIRY +C***LIBRARY SLATEC +C***TYPE ALL (CBINU-A, ZBINU-A) +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C ZBINU COMPUTES THE I FUNCTION IN THE RIGHT HALF Z PLANE +C +C***SEE ALSO ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK, ZBIRY +C***ROUTINES CALLED ZABS, ZASYI, ZBUNI, ZMLRI, ZSERI, ZUOIK, ZWRSK +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 910415 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE ZBINU + DOUBLE PRECISION ALIM, AZ, CWI, CWR, CYI, CYR, DFNU, ELIM, FNU, + * FNUL, RL, TOL, ZEROI, ZEROR, ZI, ZR, ZABS + INTEGER I, INW, KODE, N, NLAST, NN, NUI, NW, NZ + DIMENSION CYR(N), CYI(N), CWR(2), CWI(2) + EXTERNAL ZABS + DATA ZEROR,ZEROI / 0.0D0, 0.0D0 / +C***FIRST EXECUTABLE STATEMENT ZBINU + NZ = 0 + AZ = ZABS(ZR,ZI) + NN = N + DFNU = FNU + (N-1) + IF (AZ.LE.2.0D0) GO TO 10 + IF (AZ*AZ*0.25D0.GT.DFNU+1.0D0) GO TO 20 + 10 CONTINUE +C----------------------------------------------------------------------- +C POWER SERIES +C----------------------------------------------------------------------- + CALL ZSERI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM) + INW = ABS(NW) + NZ = NZ + INW + NN = NN - INW + IF (NN.EQ.0) RETURN + IF (NW.GE.0) GO TO 120 + DFNU = FNU + (NN-1) + 20 CONTINUE + IF (AZ.LT.RL) GO TO 40 + IF (DFNU.LE.1.0D0) GO TO 30 + IF (AZ+AZ.LT.DFNU*DFNU) GO TO 50 +C----------------------------------------------------------------------- +C ASYMPTOTIC EXPANSION FOR LARGE Z +C----------------------------------------------------------------------- + 30 CONTINUE + CALL ZASYI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, RL, TOL, ELIM, + * ALIM) + IF (NW.LT.0) GO TO 130 + GO TO 120 + 40 CONTINUE + IF (DFNU.LE.1.0D0) GO TO 70 + 50 CONTINUE +C----------------------------------------------------------------------- +C OVERFLOW AND UNDERFLOW TEST ON I SEQUENCE FOR MILLER ALGORITHM +C----------------------------------------------------------------------- + CALL ZUOIK(ZR, ZI, FNU, KODE, 1, NN, CYR, CYI, NW, TOL, ELIM, + * ALIM) + IF (NW.LT.0) GO TO 130 + NZ = NZ + NW + NN = NN - NW + IF (NN.EQ.0) RETURN + DFNU = FNU+(NN-1) + IF (DFNU.GT.FNUL) GO TO 110 + IF (AZ.GT.FNUL) GO TO 110 + 60 CONTINUE + IF (AZ.GT.RL) GO TO 80 + 70 CONTINUE +C----------------------------------------------------------------------- +C MILLER ALGORITHM NORMALIZED BY THE SERIES +C----------------------------------------------------------------------- + CALL ZMLRI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, TOL) + IF(NW.LT.0) GO TO 130 + GO TO 120 + 80 CONTINUE +C----------------------------------------------------------------------- +C MILLER ALGORITHM NORMALIZED BY THE WRONSKIAN +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- +C OVERFLOW TEST ON K FUNCTIONS USED IN WRONSKIAN +C----------------------------------------------------------------------- + CALL ZUOIK(ZR, ZI, FNU, KODE, 2, 2, CWR, CWI, NW, TOL, ELIM, + * ALIM) + IF (NW.GE.0) GO TO 100 + NZ = NN + DO 90 I=1,NN + CYR(I) = ZEROR + CYI(I) = ZEROI + 90 CONTINUE + RETURN + 100 CONTINUE + IF (NW.GT.0) GO TO 130 + CALL ZWRSK(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, CWR, CWI, TOL, + * ELIM, ALIM) + IF (NW.LT.0) GO TO 130 + GO TO 120 + 110 CONTINUE +C----------------------------------------------------------------------- +C INCREMENT FNU+NN-1 UP TO FNUL, COMPUTE AND RECUR BACKWARD +C----------------------------------------------------------------------- + NUI = FNUL-DFNU + 1 + NUI = MAX(NUI,0) + CALL ZBUNI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, NUI, NLAST, FNUL, + * TOL, ELIM, ALIM) + IF (NW.LT.0) GO TO 130 + NZ = NZ + NW + IF (NLAST.EQ.0) GO TO 120 + NN = NLAST + GO TO 60 + 120 CONTINUE + RETURN + 130 CONTINUE + NZ = -1 + IF(NW.EQ.(-2)) NZ=-2 + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zbinu.lo b/modules/elementary_functions/src/fortran/slatec/zbinu.lo new file mode 100755 index 000000000..f2521e7b9 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zbinu.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zbinu.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zbinu.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zbknu.f b/modules/elementary_functions/src/fortran/slatec/zbknu.f new file mode 100755 index 000000000..4bce16ed9 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zbknu.f @@ -0,0 +1,580 @@ +*DECK ZBKNU + SUBROUTINE ZBKNU (ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL, ELIM, + + ALIM) +C***BEGIN PROLOGUE ZBKNU +C***SUBSIDIARY +C***PURPOSE Subsidiary to ZAIRY, ZBESH, ZBESI and ZBESK +C***LIBRARY SLATEC +C***TYPE ALL (CBKNU-A, ZBKNU-A) +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C ZBKNU COMPUTES THE K BESSEL FUNCTION IN THE RIGHT HALF Z PLANE. +C +C***SEE ALSO ZAIRY, ZBESH, ZBESI, ZBESK +C***ROUTINES CALLED D1MACH, DGAMLN, I1MACH, ZABS, ZDIV, ZEXP, ZKSCL, +C ZLOG, ZMLT, ZSHCH, ZSQRT, ZUCHK +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 910415 Prologue converted to Version 4.0 format. (BAB) +C 930122 Added ZEXP, ZLOG and ZSQRT to EXTERNAL statement. (RWC) +C***END PROLOGUE ZBKNU +C + DOUBLE PRECISION AA, AK, ALIM, ASCLE, A1, A2, BB, BK, BRY, CAZ, + * CBI, CBR, CC, CCHI, CCHR, CKI, CKR, COEFI, COEFR, CONEI, CONER, + * CRSCR, CSCLR, CSHI, CSHR, CSI, CSR, CSRR, CSSR, CTWOR, + * CZEROI, CZEROR, CZI, CZR, DNU, DNU2, DPI, ELIM, ETEST, FC, FHS, + * FI, FK, FKS, FMUI, FMUR, FNU, FPI, FR, G1, G2, HPI, PI, PR, PTI, + * PTR, P1I, P1R, P2I, P2M, P2R, QI, QR, RAK, RCAZ, RTHPI, RZI, + * RZR, R1, S, SMUI, SMUR, SPI, STI, STR, S1I, S1R, S2I, S2R, TM, + * TOL, TTH, T1, T2, YI, YR, ZI, ZR, DGAMLN, D1MACH, ZABS, ELM, + * CELMR, ZDR, ZDI, AS, ALAS, HELIM, CYR, CYI + INTEGER I, IFLAG, INU, K, KFLAG, KK, KMAX, KODE, KODED, N, NZ, + * IDUM, I1MACH, J, IC, INUB, NW + DIMENSION YR(N), YI(N), CC(8), CSSR(3), CSRR(3), BRY(3), CYR(2), + * CYI(2) + EXTERNAL ZABS, ZEXP, ZLOG, ZSQRT +C COMPLEX Z,Y,A,B,RZ,SMU,FU,FMU,F,FLRZ,CZ,S1,S2,CSH,CCH +C COMPLEX CK,P,Q,COEF,P1,P2,CBK,PT,CZERO,CONE,CTWO,ST,EZ,CS,DK +C + DATA KMAX / 30 / + DATA CZEROR,CZEROI,CONER,CONEI,CTWOR,R1/ + 1 0.0D0 , 0.0D0 , 1.0D0 , 0.0D0 , 2.0D0 , 2.0D0 / + DATA DPI, RTHPI, SPI ,HPI, FPI, TTH / + 1 3.14159265358979324D0, 1.25331413731550025D0, + 2 1.90985931710274403D0, 1.57079632679489662D0, + 3 1.89769999331517738D0, 6.66666666666666666D-01/ + DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8)/ + 1 5.77215664901532861D-01, -4.20026350340952355D-02, + 2 -4.21977345555443367D-02, 7.21894324666309954D-03, + 3 -2.15241674114950973D-04, -2.01348547807882387D-05, + 4 1.13302723198169588D-06, 6.11609510448141582D-09/ +C***FIRST EXECUTABLE STATEMENT ZBKNU + CAZ = ZABS(ZR,ZI) + CSCLR = 1.0D0/TOL + CRSCR = TOL + CSSR(1) = CSCLR + CSSR(2) = 1.0D0 + CSSR(3) = CRSCR + CSRR(1) = CRSCR + CSRR(2) = 1.0D0 + CSRR(3) = CSCLR + BRY(1) = 1.0D+3*D1MACH(1)/TOL + BRY(2) = 1.0D0/BRY(1) + BRY(3) = D1MACH(2) + NZ = 0 + IFLAG = 0 + KODED = KODE + RCAZ = 1.0D0/CAZ + STR = ZR*RCAZ + STI = -ZI*RCAZ + RZR = (STR+STR)*RCAZ + RZI = (STI+STI)*RCAZ + INU = FNU+0.5D0 + DNU = FNU - INU + IF (ABS(DNU).EQ.0.5D0) GO TO 110 + DNU2 = 0.0D0 + IF (ABS(DNU).GT.TOL) DNU2 = DNU*DNU + IF (CAZ.GT.R1) GO TO 110 +C----------------------------------------------------------------------- +C SERIES FOR ABS(Z).LE.R1 +C----------------------------------------------------------------------- + FC = 1.0D0 + CALL ZLOG(RZR, RZI, SMUR, SMUI, IDUM) + FMUR = SMUR*DNU + FMUI = SMUI*DNU + CALL ZSHCH(FMUR, FMUI, CSHR, CSHI, CCHR, CCHI) + IF (DNU.EQ.0.0D0) GO TO 10 + FC = DNU*DPI + FC = FC/SIN(FC) + SMUR = CSHR/DNU + SMUI = CSHI/DNU + 10 CONTINUE + A2 = 1.0D0 + DNU +C----------------------------------------------------------------------- +C GAM(1-Z)*GAM(1+Z)=PI*Z/SIN(PI*Z), T1=1/GAM(1-DNU), T2=1/GAM(1+DNU) +C----------------------------------------------------------------------- + T2 = EXP(-DGAMLN(A2,IDUM)) + T1 = 1.0D0/(T2*FC) + IF (ABS(DNU).GT.0.1D0) GO TO 40 +C----------------------------------------------------------------------- +C SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU) +C----------------------------------------------------------------------- + AK = 1.0D0 + S = CC(1) + DO 20 K=2,8 + AK = AK*DNU2 + TM = CC(K)*AK + S = S + TM + IF (ABS(TM).LT.TOL) GO TO 30 + 20 CONTINUE + 30 G1 = -S + GO TO 50 + 40 CONTINUE + G1 = (T1-T2)/(DNU+DNU) + 50 CONTINUE + G2 = (T1+T2)*0.5D0 + FR = FC*(CCHR*G1+SMUR*G2) + FI = FC*(CCHI*G1+SMUI*G2) + CALL ZEXP(FMUR, FMUI, STR, STI) + PR = 0.5D0*STR/T2 + PI = 0.5D0*STI/T2 + CALL ZDIV(0.5D0, 0.0D0, STR, STI, PTR, PTI) + QR = PTR/T1 + QI = PTI/T1 + S1R = FR + S1I = FI + S2R = PR + S2I = PI + AK = 1.0D0 + A1 = 1.0D0 + CKR = CONER + CKI = CONEI + BK = 1.0D0 - DNU2 + IF (INU.GT.0 .OR. N.GT.1) GO TO 80 +C----------------------------------------------------------------------- +C GENERATE K(FNU,Z), 0.0D0 .LE. FNU .LT. 0.5D0 AND N=1 +C----------------------------------------------------------------------- + IF (CAZ.LT.TOL) GO TO 70 + CALL ZMLT(ZR, ZI, ZR, ZI, CZR, CZI) + CZR = 0.25D0*CZR + CZI = 0.25D0*CZI + T1 = 0.25D0*CAZ*CAZ + 60 CONTINUE + FR = (FR*AK+PR+QR)/BK + FI = (FI*AK+PI+QI)/BK + STR = 1.0D0/(AK-DNU) + PR = PR*STR + PI = PI*STR + STR = 1.0D0/(AK+DNU) + QR = QR*STR + QI = QI*STR + STR = CKR*CZR - CKI*CZI + RAK = 1.0D0/AK + CKI = (CKR*CZI+CKI*CZR)*RAK + CKR = STR*RAK + S1R = CKR*FR - CKI*FI + S1R + S1I = CKR*FI + CKI*FR + S1I + A1 = A1*T1*RAK + BK = BK + AK + AK + 1.0D0 + AK = AK + 1.0D0 + IF (A1.GT.TOL) GO TO 60 + 70 CONTINUE + YR(1) = S1R + YI(1) = S1I + IF (KODED.EQ.1) RETURN + CALL ZEXP(ZR, ZI, STR, STI) + CALL ZMLT(S1R, S1I, STR, STI, YR(1), YI(1)) + RETURN +C----------------------------------------------------------------------- +C GENERATE K(DNU,Z) AND K(DNU+1,Z) FOR FORWARD RECURRENCE +C----------------------------------------------------------------------- + 80 CONTINUE + IF (CAZ.LT.TOL) GO TO 100 + CALL ZMLT(ZR, ZI, ZR, ZI, CZR, CZI) + CZR = 0.25D0*CZR + CZI = 0.25D0*CZI + T1 = 0.25D0*CAZ*CAZ + 90 CONTINUE + FR = (FR*AK+PR+QR)/BK + FI = (FI*AK+PI+QI)/BK + STR = 1.0D0/(AK-DNU) + PR = PR*STR + PI = PI*STR + STR = 1.0D0/(AK+DNU) + QR = QR*STR + QI = QI*STR + STR = CKR*CZR - CKI*CZI + RAK = 1.0D0/AK + CKI = (CKR*CZI+CKI*CZR)*RAK + CKR = STR*RAK + S1R = CKR*FR - CKI*FI + S1R + S1I = CKR*FI + CKI*FR + S1I + STR = PR - FR*AK + STI = PI - FI*AK + S2R = CKR*STR - CKI*STI + S2R + S2I = CKR*STI + CKI*STR + S2I + A1 = A1*T1*RAK + BK = BK + AK + AK + 1.0D0 + AK = AK + 1.0D0 + IF (A1.GT.TOL) GO TO 90 + 100 CONTINUE + KFLAG = 2 + A1 = FNU + 1.0D0 + AK = A1*ABS(SMUR) + IF (AK.GT.ALIM) KFLAG = 3 + STR = CSSR(KFLAG) + P2R = S2R*STR + P2I = S2I*STR + CALL ZMLT(P2R, P2I, RZR, RZI, S2R, S2I) + S1R = S1R*STR + S1I = S1I*STR + IF (KODED.EQ.1) GO TO 210 + CALL ZEXP(ZR, ZI, FR, FI) + CALL ZMLT(S1R, S1I, FR, FI, S1R, S1I) + CALL ZMLT(S2R, S2I, FR, FI, S2R, S2I) + GO TO 210 +C----------------------------------------------------------------------- +C IFLAG=0 MEANS NO UNDERFLOW OCCURRED +C IFLAG=1 MEANS AN UNDERFLOW OCCURRED- COMPUTATION PROCEEDS WITH +C KODED=2 AND A TEST FOR ON SCALE VALUES IS MADE DURING FORWARD +C RECURSION +C----------------------------------------------------------------------- + 110 CONTINUE + CALL ZSQRT(ZR, ZI, STR, STI) + CALL ZDIV(RTHPI, CZEROI, STR, STI, COEFR, COEFI) + KFLAG = 2 + IF (KODED.EQ.2) GO TO 120 + IF (ZR.GT.ALIM) GO TO 290 +C BLANK LINE + STR = EXP(-ZR)*CSSR(KFLAG) + STI = -STR*SIN(ZI) + STR = STR*COS(ZI) + CALL ZMLT(COEFR, COEFI, STR, STI, COEFR, COEFI) + 120 CONTINUE + IF (ABS(DNU).EQ.0.5D0) GO TO 300 +C----------------------------------------------------------------------- +C MILLER ALGORITHM FOR ABS(Z).GT.R1 +C----------------------------------------------------------------------- + AK = COS(DPI*DNU) + AK = ABS(AK) + IF (AK.EQ.CZEROR) GO TO 300 + FHS = ABS(0.25D0-DNU2) + IF (FHS.EQ.CZEROR) GO TO 300 +C----------------------------------------------------------------------- +C COMPUTE R2=F(E). IF ABS(Z).GE.R2, USE FORWARD RECURRENCE TO +C DETERMINE THE BACKWARD INDEX K. R2=F(E) IS A STRAIGHT LINE ON +C 12.LE.E.LE.60. E IS COMPUTED FROM 2**(-E)=B**(1-I1MACH(14))= +C TOL WHERE B IS THE BASE OF THE ARITHMETIC. +C----------------------------------------------------------------------- + T1 = I1MACH(14)-1 + T1 = T1*D1MACH(5)*3.321928094D0 + T1 = MAX(T1,12.0D0) + T1 = MIN(T1,60.0D0) + T2 = TTH*T1 - 6.0D0 + IF (ZR.NE.0.0D0) GO TO 130 + T1 = HPI + GO TO 140 + 130 CONTINUE + T1 = DATAN(ZI/ZR) + T1 = ABS(T1) + 140 CONTINUE + IF (T2.GT.CAZ) GO TO 170 +C----------------------------------------------------------------------- +C FORWARD RECURRENCE LOOP WHEN ABS(Z).GE.R2 +C----------------------------------------------------------------------- + ETEST = AK/(DPI*CAZ*TOL) + FK = CONER + IF (ETEST.LT.CONER) GO TO 180 + FKS = CTWOR + CKR = CAZ + CAZ + CTWOR + P1R = CZEROR + P2R = CONER + DO 150 I=1,KMAX + AK = FHS/FKS + CBR = CKR/(FK+CONER) + PTR = P2R + P2R = CBR*P2R - P1R*AK + P1R = PTR + CKR = CKR + CTWOR + FKS = FKS + FK + FK + CTWOR + FHS = FHS + FK + FK + FK = FK + CONER + STR = ABS(P2R)*FK + IF (ETEST.LT.STR) GO TO 160 + 150 CONTINUE + GO TO 310 + 160 CONTINUE + FK = FK + SPI*T1*SQRT(T2/CAZ) + FHS = ABS(0.25D0-DNU2) + GO TO 180 + 170 CONTINUE +C----------------------------------------------------------------------- +C COMPUTE BACKWARD INDEX K FOR ABS(Z).LT.R2 +C----------------------------------------------------------------------- + A2 = SQRT(CAZ) + AK = FPI*AK/(TOL*SQRT(A2)) + AA = 3.0D0*T1/(1.0D0+CAZ) + BB = 14.7D0*T1/(28.0D0+CAZ) + AK = (LOG(AK)+CAZ*COS(AA)/(1.0D0+0.008D0*CAZ))/COS(BB) + FK = 0.12125D0*AK*AK/CAZ + 1.5D0 + 180 CONTINUE +C----------------------------------------------------------------------- +C BACKWARD RECURRENCE LOOP FOR MILLER ALGORITHM +C----------------------------------------------------------------------- + K = FK + FK = K + FKS = FK*FK + P1R = CZEROR + P1I = CZEROI + P2R = TOL + P2I = CZEROI + CSR = P2R + CSI = P2I + DO 190 I=1,K + A1 = FKS - FK + AK = (FKS+FK)/(A1+FHS) + RAK = 2.0D0/(FK+CONER) + CBR = (FK+ZR)*RAK + CBI = ZI*RAK + PTR = P2R + PTI = P2I + P2R = (PTR*CBR-PTI*CBI-P1R)*AK + P2I = (PTI*CBR+PTR*CBI-P1I)*AK + P1R = PTR + P1I = PTI + CSR = CSR + P2R + CSI = CSI + P2I + FKS = A1 - FK + CONER + FK = FK - CONER + 190 CONTINUE +C----------------------------------------------------------------------- +C COMPUTE (P2/CS)=(P2/ABS(CS))*(CONJG(CS)/ABS(CS)) FOR BETTER +C SCALING +C----------------------------------------------------------------------- + TM = ZABS(CSR,CSI) + PTR = 1.0D0/TM + S1R = P2R*PTR + S1I = P2I*PTR + CSR = CSR*PTR + CSI = -CSI*PTR + CALL ZMLT(COEFR, COEFI, S1R, S1I, STR, STI) + CALL ZMLT(STR, STI, CSR, CSI, S1R, S1I) + IF (INU.GT.0 .OR. N.GT.1) GO TO 200 + ZDR = ZR + ZDI = ZI + IF(IFLAG.EQ.1) GO TO 270 + GO TO 240 + 200 CONTINUE +C----------------------------------------------------------------------- +C COMPUTE P1/P2=(P1/ABS(P2)*CONJG(P2)/ABS(P2) FOR SCALING +C----------------------------------------------------------------------- + TM = ZABS(P2R,P2I) + PTR = 1.0D0/TM + P1R = P1R*PTR + P1I = P1I*PTR + P2R = P2R*PTR + P2I = -P2I*PTR + CALL ZMLT(P1R, P1I, P2R, P2I, PTR, PTI) + STR = DNU + 0.5D0 - PTR + STI = -PTI + CALL ZDIV(STR, STI, ZR, ZI, STR, STI) + STR = STR + 1.0D0 + CALL ZMLT(STR, STI, S1R, S1I, S2R, S2I) +C----------------------------------------------------------------------- +C FORWARD RECURSION ON THE THREE TERM RECURSION WITH RELATION WITH +C SCALING NEAR EXPONENT EXTREMES ON KFLAG=1 OR KFLAG=3 +C----------------------------------------------------------------------- + 210 CONTINUE + STR = DNU + 1.0D0 + CKR = STR*RZR + CKI = STR*RZI + IF (N.EQ.1) INU = INU - 1 + IF (INU.GT.0) GO TO 220 + IF (N.GT.1) GO TO 215 + S1R = S2R + S1I = S2I + 215 CONTINUE + ZDR = ZR + ZDI = ZI + IF(IFLAG.EQ.1) GO TO 270 + GO TO 240 + 220 CONTINUE + INUB = 1 + IF(IFLAG.EQ.1) GO TO 261 + 225 CONTINUE + P1R = CSRR(KFLAG) + ASCLE = BRY(KFLAG) + DO 230 I=INUB,INU + STR = S2R + STI = S2I + S2R = CKR*STR - CKI*STI + S1R + S2I = CKR*STI + CKI*STR + S1I + S1R = STR + S1I = STI + CKR = CKR + RZR + CKI = CKI + RZI + IF (KFLAG.GE.3) GO TO 230 + P2R = S2R*P1R + P2I = S2I*P1R + STR = ABS(P2R) + STI = ABS(P2I) + P2M = MAX(STR,STI) + IF (P2M.LE.ASCLE) GO TO 230 + KFLAG = KFLAG + 1 + ASCLE = BRY(KFLAG) + S1R = S1R*P1R + S1I = S1I*P1R + S2R = P2R + S2I = P2I + STR = CSSR(KFLAG) + S1R = S1R*STR + S1I = S1I*STR + S2R = S2R*STR + S2I = S2I*STR + P1R = CSRR(KFLAG) + 230 CONTINUE + IF (N.NE.1) GO TO 240 + S1R = S2R + S1I = S2I + 240 CONTINUE + STR = CSRR(KFLAG) + YR(1) = S1R*STR + YI(1) = S1I*STR + IF (N.EQ.1) RETURN + YR(2) = S2R*STR + YI(2) = S2I*STR + IF (N.EQ.2) RETURN + KK = 2 + 250 CONTINUE + KK = KK + 1 + IF (KK.GT.N) RETURN + P1R = CSRR(KFLAG) + ASCLE = BRY(KFLAG) + DO 260 I=KK,N + P2R = S2R + P2I = S2I + S2R = CKR*P2R - CKI*P2I + S1R + S2I = CKI*P2R + CKR*P2I + S1I + S1R = P2R + S1I = P2I + CKR = CKR + RZR + CKI = CKI + RZI + P2R = S2R*P1R + P2I = S2I*P1R + YR(I) = P2R + YI(I) = P2I + IF (KFLAG.GE.3) GO TO 260 + STR = ABS(P2R) + STI = ABS(P2I) + P2M = MAX(STR,STI) + IF (P2M.LE.ASCLE) GO TO 260 + KFLAG = KFLAG + 1 + ASCLE = BRY(KFLAG) + S1R = S1R*P1R + S1I = S1I*P1R + S2R = P2R + S2I = P2I + STR = CSSR(KFLAG) + S1R = S1R*STR + S1I = S1I*STR + S2R = S2R*STR + S2I = S2I*STR + P1R = CSRR(KFLAG) + 260 CONTINUE + RETURN +C----------------------------------------------------------------------- +C IFLAG=1 CASES, FORWARD RECURRENCE ON SCALED VALUES ON UNDERFLOW +C----------------------------------------------------------------------- + 261 CONTINUE + HELIM = 0.5D0*ELIM + ELM = EXP(-ELIM) + CELMR = ELM + ASCLE = BRY(1) + ZDR = ZR + ZDI = ZI + IC = -1 + J = 2 + DO 262 I=1,INU + STR = S2R + STI = S2I + S2R = STR*CKR-STI*CKI+S1R + S2I = STI*CKR+STR*CKI+S1I + S1R = STR + S1I = STI + CKR = CKR+RZR + CKI = CKI+RZI + AS = ZABS(S2R,S2I) + ALAS = LOG(AS) + P2R = -ZDR+ALAS + IF(P2R.LT.(-ELIM)) GO TO 263 + CALL ZLOG(S2R,S2I,STR,STI,IDUM) + P2R = -ZDR+STR + P2I = -ZDI+STI + P2M = EXP(P2R)/TOL + P1R = P2M*COS(P2I) + P1I = P2M*SIN(P2I) + CALL ZUCHK(P1R,P1I,NW,ASCLE,TOL) + IF(NW.NE.0) GO TO 263 + J = 3 - J + CYR(J) = P1R + CYI(J) = P1I + IF(IC.EQ.(I-1)) GO TO 264 + IC = I + GO TO 262 + 263 CONTINUE + IF(ALAS.LT.HELIM) GO TO 262 + ZDR = ZDR-ELIM + S1R = S1R*CELMR + S1I = S1I*CELMR + S2R = S2R*CELMR + S2I = S2I*CELMR + 262 CONTINUE + IF(N.NE.1) GO TO 270 + S1R = S2R + S1I = S2I + GO TO 270 + 264 CONTINUE + KFLAG = 1 + INUB = I+1 + S2R = CYR(J) + S2I = CYI(J) + J = 3 - J + S1R = CYR(J) + S1I = CYI(J) + IF(INUB.LE.INU) GO TO 225 + IF(N.NE.1) GO TO 240 + S1R = S2R + S1I = S2I + GO TO 240 + 270 CONTINUE + YR(1) = S1R + YI(1) = S1I + IF(N.EQ.1) GO TO 280 + YR(2) = S2R + YI(2) = S2I + 280 CONTINUE + ASCLE = BRY(1) + CALL ZKSCL(ZDR,ZDI,FNU,N,YR,YI,NZ,RZR,RZI,ASCLE,TOL,ELIM) + INU = N - NZ + IF (INU.LE.0) RETURN + KK = NZ + 1 + S1R = YR(KK) + S1I = YI(KK) + YR(KK) = S1R*CSRR(1) + YI(KK) = S1I*CSRR(1) + IF (INU.EQ.1) RETURN + KK = NZ + 2 + S2R = YR(KK) + S2I = YI(KK) + YR(KK) = S2R*CSRR(1) + YI(KK) = S2I*CSRR(1) + IF (INU.EQ.2) RETURN + T2 = FNU + (KK-1) + CKR = T2*RZR + CKI = T2*RZI + KFLAG = 1 + GO TO 250 + 290 CONTINUE +C----------------------------------------------------------------------- +C SCALE BY EXP(Z), IFLAG = 1 CASES +C----------------------------------------------------------------------- + KODED = 2 + IFLAG = 1 + KFLAG = 2 + GO TO 120 +C----------------------------------------------------------------------- +C FNU=HALF ODD INTEGER CASE, DNU=-0.5 +C----------------------------------------------------------------------- + 300 CONTINUE + S1R = COEFR + S1I = COEFI + S2R = COEFR + S2I = COEFI + GO TO 210 +C +C + 310 CONTINUE + NZ=-2 + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zbknu.lo b/modules/elementary_functions/src/fortran/slatec/zbknu.lo new file mode 100755 index 000000000..c52c24d7e --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zbknu.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zbknu.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zbknu.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zbuni.f b/modules/elementary_functions/src/fortran/slatec/zbuni.f new file mode 100755 index 000000000..03f32bed6 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zbuni.f @@ -0,0 +1,186 @@ +*DECK ZBUNI + SUBROUTINE ZBUNI (ZR, ZI, FNU, KODE, N, YR, YI, NZ, NUI, NLAST, + + FNUL, TOL, ELIM, ALIM) +C***BEGIN PROLOGUE ZBUNI +C***SUBSIDIARY +C***PURPOSE Subsidiary to ZBESI and ZBESK +C***LIBRARY SLATEC +C***TYPE ALL (CBUNI-A, ZBUNI-A) +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C ZBUNI COMPUTES THE I BESSEL FUNCTION FOR LARGE ABS(Z).GT. +C FNUL AND FNU+N-1.LT.FNUL. THE ORDER IS INCREASED FROM +C FNU+N-1 GREATER THAN FNUL BY ADDING NUI AND COMPUTING +C ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR I(FNU,Z) +C ON IFORM=1 AND THE EXPANSION FOR J(FNU,Z) ON IFORM=2 +C +C***SEE ALSO ZBESI, ZBESK +C***ROUTINES CALLED D1MACH, ZABS, ZUNI1, ZUNI2 +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 910415 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE ZBUNI +C COMPLEX CSCL,CSCR,CY,RZ,ST,S1,S2,Y,Z + DOUBLE PRECISION ALIM, AX, AY, CSCLR, CSCRR, CYI, CYR, DFNU, + * ELIM, FNU, FNUI, FNUL, GNU, RAZ, RZI, RZR, STI, STR, S1I, S1R, + * S2I, S2R, TOL, YI, YR, ZI, ZR, ZABS, ASCLE, BRY, C1R, C1I, C1M, + * D1MACH + INTEGER I, IFLAG, IFORM, K, KODE, N, NL, NLAST, NUI, NW, NZ + DIMENSION YR(N), YI(N), CYR(2), CYI(2), BRY(3) + EXTERNAL ZABS +C***FIRST EXECUTABLE STATEMENT ZBUNI + NZ = 0 + AX = ABS(ZR)*1.7321D0 + AY = ABS(ZI) + IFORM = 1 + IF (AY.GT.AX) IFORM = 2 + IF (NUI.EQ.0) GO TO 60 + FNUI = NUI + DFNU = FNU + (N-1) + GNU = DFNU + FNUI + IF (IFORM.EQ.2) GO TO 10 +C----------------------------------------------------------------------- +C ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN +C -PI/3.LE.ARG(Z).LE.PI/3 +C----------------------------------------------------------------------- + CALL ZUNI1(ZR, ZI, GNU, KODE, 2, CYR, CYI, NW, NLAST, FNUL, TOL, + * ELIM, ALIM) + GO TO 20 + 10 CONTINUE +C----------------------------------------------------------------------- +C ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU +C APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I +C AND HPI=PI/2 +C----------------------------------------------------------------------- + CALL ZUNI2(ZR, ZI, GNU, KODE, 2, CYR, CYI, NW, NLAST, FNUL, TOL, + * ELIM, ALIM) + 20 CONTINUE + IF (NW.LT.0) GO TO 50 + IF (NW.NE.0) GO TO 90 + STR = ZABS(CYR(1),CYI(1)) +C---------------------------------------------------------------------- +C SCALE BACKWARD RECURRENCE, BRY(3) IS DEFINED BUT NEVER USED +C---------------------------------------------------------------------- + BRY(1)=1.0D+3*D1MACH(1)/TOL + BRY(2) = 1.0D0/BRY(1) + BRY(3) = BRY(2) + IFLAG = 2 + ASCLE = BRY(2) + CSCLR = 1.0D0 + IF (STR.GT.BRY(1)) GO TO 21 + IFLAG = 1 + ASCLE = BRY(1) + CSCLR = 1.0D0/TOL + GO TO 25 + 21 CONTINUE + IF (STR.LT.BRY(2)) GO TO 25 + IFLAG = 3 + ASCLE=BRY(3) + CSCLR = TOL + 25 CONTINUE + CSCRR = 1.0D0/CSCLR + S1R = CYR(2)*CSCLR + S1I = CYI(2)*CSCLR + S2R = CYR(1)*CSCLR + S2I = CYI(1)*CSCLR + RAZ = 1.0D0/ZABS(ZR,ZI) + STR = ZR*RAZ + STI = -ZI*RAZ + RZR = (STR+STR)*RAZ + RZI = (STI+STI)*RAZ + DO 30 I=1,NUI + STR = S2R + STI = S2I + S2R = (DFNU+FNUI)*(RZR*STR-RZI*STI) + S1R + S2I = (DFNU+FNUI)*(RZR*STI+RZI*STR) + S1I + S1R = STR + S1I = STI + FNUI = FNUI - 1.0D0 + IF (IFLAG.GE.3) GO TO 30 + STR = S2R*CSCRR + STI = S2I*CSCRR + C1R = ABS(STR) + C1I = ABS(STI) + C1M = MAX(C1R,C1I) + IF (C1M.LE.ASCLE) GO TO 30 + IFLAG = IFLAG+1 + ASCLE = BRY(IFLAG) + S1R = S1R*CSCRR + S1I = S1I*CSCRR + S2R = STR + S2I = STI + CSCLR = CSCLR*TOL + CSCRR = 1.0D0/CSCLR + S1R = S1R*CSCLR + S1I = S1I*CSCLR + S2R = S2R*CSCLR + S2I = S2I*CSCLR + 30 CONTINUE + YR(N) = S2R*CSCRR + YI(N) = S2I*CSCRR + IF (N.EQ.1) RETURN + NL = N - 1 + FNUI = NL + K = NL + DO 40 I=1,NL + STR = S2R + STI = S2I + S2R = (FNU+FNUI)*(RZR*STR-RZI*STI) + S1R + S2I = (FNU+FNUI)*(RZR*STI+RZI*STR) + S1I + S1R = STR + S1I = STI + STR = S2R*CSCRR + STI = S2I*CSCRR + YR(K) = STR + YI(K) = STI + FNUI = FNUI - 1.0D0 + K = K - 1 + IF (IFLAG.GE.3) GO TO 40 + C1R = ABS(STR) + C1I = ABS(STI) + C1M = MAX(C1R,C1I) + IF (C1M.LE.ASCLE) GO TO 40 + IFLAG = IFLAG+1 + ASCLE = BRY(IFLAG) + S1R = S1R*CSCRR + S1I = S1I*CSCRR + S2R = STR + S2I = STI + CSCLR = CSCLR*TOL + CSCRR = 1.0D0/CSCLR + S1R = S1R*CSCLR + S1I = S1I*CSCLR + S2R = S2R*CSCLR + S2I = S2I*CSCLR + 40 CONTINUE + RETURN + 50 CONTINUE + NZ = -1 + IF(NW.EQ.(-2)) NZ=-2 + RETURN + 60 CONTINUE + IF (IFORM.EQ.2) GO TO 70 +C----------------------------------------------------------------------- +C ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN +C -PI/3.LE.ARG(Z).LE.PI/3 +C----------------------------------------------------------------------- + CALL ZUNI1(ZR, ZI, FNU, KODE, N, YR, YI, NW, NLAST, FNUL, TOL, + * ELIM, ALIM) + GO TO 80 + 70 CONTINUE +C----------------------------------------------------------------------- +C ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU +C APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I +C AND HPI=PI/2 +C----------------------------------------------------------------------- + CALL ZUNI2(ZR, ZI, FNU, KODE, N, YR, YI, NW, NLAST, FNUL, TOL, + * ELIM, ALIM) + 80 CONTINUE + IF (NW.LT.0) GO TO 50 + NZ = NW + RETURN + 90 CONTINUE + NLAST = N + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zbuni.lo b/modules/elementary_functions/src/fortran/slatec/zbuni.lo new file mode 100755 index 000000000..c498d611a --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zbuni.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zbuni.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zbuni.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zbunk.f b/modules/elementary_functions/src/fortran/slatec/zbunk.f new file mode 100755 index 000000000..398742a88 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zbunk.f @@ -0,0 +1,46 @@ +*DECK ZBUNK + SUBROUTINE ZBUNK (ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, + + ALIM) +C***BEGIN PROLOGUE ZBUNK +C***SUBSIDIARY +C***PURPOSE Subsidiary to ZBESH and ZBESK +C***LIBRARY SLATEC +C***TYPE ALL (CBUNI-A, ZBUNI-A) +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C ZBUNK COMPUTES THE K BESSEL FUNCTION FOR FNU.GT.FNUL. +C ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR K(FNU,Z) +C IN ZUNK1 AND THE EXPANSION FOR H(2,FNU,Z) IN ZUNK2 +C +C***SEE ALSO ZBESH, ZBESK +C***ROUTINES CALLED ZUNK1, ZUNK2 +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 910415 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE ZBUNK +C COMPLEX Y,Z + DOUBLE PRECISION ALIM, AX, AY, ELIM, FNU, TOL, YI, YR, ZI, ZR + INTEGER KODE, MR, N, NZ + DIMENSION YR(N), YI(N) +C***FIRST EXECUTABLE STATEMENT ZBUNK + NZ = 0 + AX = ABS(ZR)*1.7321D0 + AY = ABS(ZI) + IF (AY.GT.AX) GO TO 10 +C----------------------------------------------------------------------- +C ASYMPTOTIC EXPANSION FOR K(FNU,Z) FOR LARGE FNU APPLIED IN +C -PI/3.LE.ARG(Z).LE.PI/3 +C----------------------------------------------------------------------- + CALL ZUNK1(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, ALIM) + GO TO 20 + 10 CONTINUE +C----------------------------------------------------------------------- +C ASYMPTOTIC EXPANSION FOR H(2,FNU,Z*EXP(M*HPI)) FOR LARGE FNU +C APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I +C AND HPI=PI/2 +C----------------------------------------------------------------------- + CALL ZUNK2(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, ALIM) + 20 CONTINUE + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zbunk.lo b/modules/elementary_functions/src/fortran/slatec/zbunk.lo new file mode 100755 index 000000000..5d3b27278 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zbunk.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zbunk.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zbunk.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zdiv.f b/modules/elementary_functions/src/fortran/slatec/zdiv.f new file mode 100755 index 000000000..83bb12bb5 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zdiv.f @@ -0,0 +1,32 @@ +*DECK ZDIV + SUBROUTINE ZDIV (AR, AI, BR, BI, CR, CI) +C***BEGIN PROLOGUE ZDIV +C***SUBSIDIARY +C***PURPOSE Subsidiary to ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZAIRY and +C ZBIRY +C***LIBRARY SLATEC +C***TYPE ALL (ZDIV-A) +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C DOUBLE PRECISION COMPLEX DIVIDE C=A/B. +C +C***SEE ALSO ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZBIRY +C***ROUTINES CALLED ZABS +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 910415 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE ZDIV + DOUBLE PRECISION AR, AI, BR, BI, CR, CI, BM, CA, CB, CC, CD + DOUBLE PRECISION ZABS + EXTERNAL ZABS +C***FIRST EXECUTABLE STATEMENT ZDIV + BM = 1.0D0/ZABS(BR,BI) + CC = BR*BM + CD = BI*BM + CA = (AR*CC+AI*CD)*BM + CB = (AI*CC-AR*CD)*BM + CR = CA + CI = CB + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zdiv.lo b/modules/elementary_functions/src/fortran/slatec/zdiv.lo new file mode 100755 index 000000000..4d32852ec --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zdiv.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zdiv.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zdiv.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zexp.f b/modules/elementary_functions/src/fortran/slatec/zexp.f new file mode 100755 index 000000000..63ba0e071 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zexp.f @@ -0,0 +1,28 @@ +*DECK ZEXP + SUBROUTINE ZEXP (AR, AI, BR, BI) +C***BEGIN PROLOGUE ZEXP +C***SUBSIDIARY +C***PURPOSE Subsidiary to ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZAIRY and +C ZBIRY +C***LIBRARY SLATEC +C***TYPE ALL (ZEXP-A) +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C DOUBLE PRECISION COMPLEX EXPONENTIAL FUNCTION B=EXP(A) +C +C***SEE ALSO ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZBIRY +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 910415 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE ZEXP + DOUBLE PRECISION AR, AI, BR, BI, ZM, CA, CB +C***FIRST EXECUTABLE STATEMENT ZEXP + ZM = EXP(AR) + CA = ZM*COS(AI) + CB = ZM*SIN(AI) + BR = CA + BI = CB + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zexp.lo b/modules/elementary_functions/src/fortran/slatec/zexp.lo new file mode 100755 index 000000000..001f8038f --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zexp.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zexp.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zexp.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zkscl.f b/modules/elementary_functions/src/fortran/slatec/zkscl.f new file mode 100755 index 000000000..9d7c300d1 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zkscl.f @@ -0,0 +1,134 @@ +*DECK ZKSCL + SUBROUTINE ZKSCL (ZRR, ZRI, FNU, N, YR, YI, NZ, RZR, RZI, ASCLE, + + TOL, ELIM) +C***BEGIN PROLOGUE ZKSCL +C***SUBSIDIARY +C***PURPOSE Subsidiary to ZBESK +C***LIBRARY SLATEC +C***TYPE ALL (CKSCL-A, ZKSCL-A) +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C SET K FUNCTIONS TO ZERO ON UNDERFLOW, CONTINUE RECURRENCE +C ON SCALED FUNCTIONS UNTIL TWO MEMBERS COME ON SCALE, THEN +C RETURN WITH MIN(NZ+2,N) VALUES SCALED BY 1/TOL. +C +C***SEE ALSO ZBESK +C***ROUTINES CALLED ZABS, ZLOG, ZUCHK +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 910415 Prologue converted to Version 4.0 format. (BAB) +C 930122 Added ZLOG to EXTERNAL statement. (RWC) +C***END PROLOGUE ZKSCL +C COMPLEX CK,CS,CY,CZERO,RZ,S1,S2,Y,ZR,ZD,CELM + DOUBLE PRECISION ACS, AS, ASCLE, CKI, CKR, CSI, CSR, CYI, + * CYR, ELIM, FN, FNU, RZI, RZR, STR, S1I, S1R, S2I, + * S2R, TOL, YI, YR, ZEROI, ZEROR, ZRI, ZRR, ZABS, + * ZDR, ZDI, CELMR, ELM, HELIM, ALAS + INTEGER I, IC, IDUM, KK, N, NN, NW, NZ + DIMENSION YR(N), YI(N), CYR(2), CYI(2) + EXTERNAL ZABS, ZLOG + DATA ZEROR,ZEROI / 0.0D0 , 0.0D0 / +C***FIRST EXECUTABLE STATEMENT ZKSCL + NZ = 0 + IC = 0 + NN = MIN(2,N) + DO 10 I=1,NN + S1R = YR(I) + S1I = YI(I) + CYR(I) = S1R + CYI(I) = S1I + AS = ZABS(S1R,S1I) + ACS = -ZRR + LOG(AS) + NZ = NZ + 1 + YR(I) = ZEROR + YI(I) = ZEROI + IF (ACS.LT.(-ELIM)) GO TO 10 + CALL ZLOG(S1R, S1I, CSR, CSI, IDUM) + CSR = CSR - ZRR + CSI = CSI - ZRI + STR = EXP(CSR)/TOL + CSR = STR*COS(CSI) + CSI = STR*SIN(CSI) + CALL ZUCHK(CSR, CSI, NW, ASCLE, TOL) + IF (NW.NE.0) GO TO 10 + YR(I) = CSR + YI(I) = CSI + IC = I + NZ = NZ - 1 + 10 CONTINUE + IF (N.EQ.1) RETURN + IF (IC.GT.1) GO TO 20 + YR(1) = ZEROR + YI(1) = ZEROI + NZ = 2 + 20 CONTINUE + IF (N.EQ.2) RETURN + IF (NZ.EQ.0) RETURN + FN = FNU + 1.0D0 + CKR = FN*RZR + CKI = FN*RZI + S1R = CYR(1) + S1I = CYI(1) + S2R = CYR(2) + S2I = CYI(2) + HELIM = 0.5D0*ELIM + ELM = EXP(-ELIM) + CELMR = ELM + ZDR = ZRR + ZDI = ZRI +C +C FIND TWO CONSECUTIVE Y VALUES ON SCALE. SCALE RECURRENCE IF +C S2 GETS LARGER THAN EXP(ELIM/2) +C + DO 30 I=3,N + KK = I + CSR = S2R + CSI = S2I + S2R = CKR*CSR - CKI*CSI + S1R + S2I = CKI*CSR + CKR*CSI + S1I + S1R = CSR + S1I = CSI + CKR = CKR + RZR + CKI = CKI + RZI + AS = ZABS(S2R,S2I) + ALAS = LOG(AS) + ACS = -ZDR + ALAS + NZ = NZ + 1 + YR(I) = ZEROR + YI(I) = ZEROI + IF (ACS.LT.(-ELIM)) GO TO 25 + CALL ZLOG(S2R, S2I, CSR, CSI, IDUM) + CSR = CSR - ZDR + CSI = CSI - ZDI + STR = EXP(CSR)/TOL + CSR = STR*COS(CSI) + CSI = STR*SIN(CSI) + CALL ZUCHK(CSR, CSI, NW, ASCLE, TOL) + IF (NW.NE.0) GO TO 25 + YR(I) = CSR + YI(I) = CSI + NZ = NZ - 1 + IF (IC.EQ.KK-1) GO TO 40 + IC = KK + GO TO 30 + 25 CONTINUE + IF(ALAS.LT.HELIM) GO TO 30 + ZDR = ZDR - ELIM + S1R = S1R*CELMR + S1I = S1I*CELMR + S2R = S2R*CELMR + S2I = S2I*CELMR + 30 CONTINUE + NZ = N + IF(IC.EQ.N) NZ=N-1 + GO TO 45 + 40 CONTINUE + NZ = KK - 2 + 45 CONTINUE + DO 50 I=1,NZ + YR(I) = ZEROR + YI(I) = ZEROI + 50 CONTINUE + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zkscl.lo b/modules/elementary_functions/src/fortran/slatec/zkscl.lo new file mode 100755 index 000000000..cc3db0368 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zkscl.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zkscl.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zkscl.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zlog.f b/modules/elementary_functions/src/fortran/slatec/zlog.f new file mode 100755 index 000000000..cb17d2570 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zlog.f @@ -0,0 +1,54 @@ +*DECK ZLOG + SUBROUTINE ZLOG (AR, AI, BR, BI, IERR) +C***BEGIN PROLOGUE ZLOG +C***SUBSIDIARY +C***PURPOSE Subsidiary to ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZAIRY and +C ZBIRY +C***LIBRARY SLATEC +C***TYPE ALL (ZLOG-A) +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C DOUBLE PRECISION COMPLEX LOGARITHM B=CLOG(A) +C IERR=0,NORMAL RETURN IERR=1, Z=CMPLX(0.0,0.0) +C***SEE ALSO ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZBIRY +C***ROUTINES CALLED ZABS +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 910415 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE ZLOG + DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DHPI + DOUBLE PRECISION ZABS + INTEGER IERR + EXTERNAL ZABS + DATA DPI , DHPI / 3.141592653589793238462643383D+0, + 1 1.570796326794896619231321696D+0/ +C***FIRST EXECUTABLE STATEMENT ZLOG + IERR=0 + IF (AR.EQ.0.0D+0) GO TO 10 + IF (AI.EQ.0.0D+0) GO TO 20 + DTHETA = DATAN(AI/AR) + IF (DTHETA.LE.0.0D+0) GO TO 40 + IF (AR.LT.0.0D+0) DTHETA = DTHETA - DPI + GO TO 50 + 10 IF (AI.EQ.0.0D+0) GO TO 60 + BI = DHPI + BR = LOG(ABS(AI)) + IF (AI.LT.0.0D+0) BI = -BI + RETURN + 20 IF (AR.GT.0.0D+0) GO TO 30 + BR = LOG(ABS(AR)) + BI = DPI + RETURN + 30 BR = LOG(AR) + BI = 0.0D+0 + RETURN + 40 IF (AR.LT.0.0D+0) DTHETA = DTHETA + DPI + 50 ZM = ZABS(AR,AI) + BR = LOG(ZM) + BI = DTHETA + RETURN + 60 CONTINUE + IERR=1 + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zlog.lo b/modules/elementary_functions/src/fortran/slatec/zlog.lo new file mode 100755 index 000000000..b6e937622 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zlog.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zlog.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zlog.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zmlri.f b/modules/elementary_functions/src/fortran/slatec/zmlri.f new file mode 100755 index 000000000..32a208ea9 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zmlri.f @@ -0,0 +1,217 @@ +*DECK ZMLRI + SUBROUTINE ZMLRI (ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL) +C***BEGIN PROLOGUE ZMLRI +C***SUBSIDIARY +C***PURPOSE Subsidiary to ZBESI and ZBESK +C***LIBRARY SLATEC +C***TYPE ALL (CMLRI-A, ZMLRI-A) +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C ZMLRI COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY THE +C MILLER ALGORITHM NORMALIZED BY A NEUMANN SERIES. +C +C***SEE ALSO ZBESI, ZBESK +C***ROUTINES CALLED D1MACH, DGAMLN, ZABS, ZEXP, ZLOG, ZMLT +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 910415 Prologue converted to Version 4.0 format. (BAB) +C 930122 Added ZEXP and ZLOG to EXTERNAL statement. (RWC) +C***END PROLOGUE ZMLRI +C COMPLEX CK,CNORM,CONE,CTWO,CZERO,PT,P1,P2,RZ,SUM,Y,Z + DOUBLE PRECISION ACK, AK, AP, AT, AZ, BK, CKI, CKR, CNORMI, + * CNORMR, CONEI, CONER, FKAP, FKK, FLAM, FNF, FNU, PTI, PTR, P1I, + * P1R, P2I, P2R, RAZ, RHO, RHO2, RZI, RZR, SCLE, STI, STR, SUMI, + * SUMR, TFNF, TOL, TST, YI, YR, ZEROI, ZEROR, ZI, ZR, DGAMLN, + * D1MACH, ZABS + INTEGER I, IAZ, IDUM, IFNU, INU, ITIME, K, KK, KM, KODE, M, N, NZ + DIMENSION YR(N), YI(N) + EXTERNAL ZABS, ZEXP, ZLOG + DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / +C***FIRST EXECUTABLE STATEMENT ZMLRI + SCLE = D1MACH(1)/TOL + NZ=0 + AZ = ZABS(ZR,ZI) + IAZ = AZ + IFNU = FNU + INU = IFNU + N - 1 + AT = IAZ + 1.0D0 + RAZ = 1.0D0/AZ + STR = ZR*RAZ + STI = -ZI*RAZ + CKR = STR*AT*RAZ + CKI = STI*AT*RAZ + RZR = (STR+STR)*RAZ + RZI = (STI+STI)*RAZ + P1R = ZEROR + P1I = ZEROI + P2R = CONER + P2I = CONEI + ACK = (AT+1.0D0)*RAZ + RHO = ACK + SQRT(ACK*ACK-1.0D0) + RHO2 = RHO*RHO + TST = (RHO2+RHO2)/((RHO2-1.0D0)*(RHO-1.0D0)) + TST = TST/TOL +C----------------------------------------------------------------------- +C COMPUTE RELATIVE TRUNCATION ERROR INDEX FOR SERIES +C----------------------------------------------------------------------- + AK = AT + DO 10 I=1,80 + PTR = P2R + PTI = P2I + P2R = P1R - (CKR*PTR-CKI*PTI) + P2I = P1I - (CKI*PTR+CKR*PTI) + P1R = PTR + P1I = PTI + CKR = CKR + RZR + CKI = CKI + RZI + AP = ZABS(P2R,P2I) + IF (AP.GT.TST*AK*AK) GO TO 20 + AK = AK + 1.0D0 + 10 CONTINUE + GO TO 110 + 20 CONTINUE + I = I + 1 + K = 0 + IF (INU.LT.IAZ) GO TO 40 +C----------------------------------------------------------------------- +C COMPUTE RELATIVE TRUNCATION ERROR FOR RATIOS +C----------------------------------------------------------------------- + P1R = ZEROR + P1I = ZEROI + P2R = CONER + P2I = CONEI + AT = INU + 1.0D0 + STR = ZR*RAZ + STI = -ZI*RAZ + CKR = STR*AT*RAZ + CKI = STI*AT*RAZ + ACK = AT*RAZ + TST = SQRT(ACK/TOL) + ITIME = 1 + DO 30 K=1,80 + PTR = P2R + PTI = P2I + P2R = P1R - (CKR*PTR-CKI*PTI) + P2I = P1I - (CKR*PTI+CKI*PTR) + P1R = PTR + P1I = PTI + CKR = CKR + RZR + CKI = CKI + RZI + AP = ZABS(P2R,P2I) + IF (AP.LT.TST) GO TO 30 + IF (ITIME.EQ.2) GO TO 40 + ACK = ZABS(CKR,CKI) + FLAM = ACK + SQRT(ACK*ACK-1.0D0) + FKAP = AP/ZABS(P1R,P1I) + RHO = MIN(FLAM,FKAP) + TST = TST*SQRT(RHO/(RHO*RHO-1.0D0)) + ITIME = 2 + 30 CONTINUE + GO TO 110 + 40 CONTINUE +C----------------------------------------------------------------------- +C BACKWARD RECURRENCE AND SUM NORMALIZING RELATION +C----------------------------------------------------------------------- + K = K + 1 + KK = MAX(I+IAZ,K+INU) + FKK = KK + P1R = ZEROR + P1I = ZEROI +C----------------------------------------------------------------------- +C SCALE P2 AND SUM BY SCLE +C----------------------------------------------------------------------- + P2R = SCLE + P2I = ZEROI + FNF = FNU - IFNU + TFNF = FNF + FNF + BK = DGAMLN(FKK+TFNF+1.0D0,IDUM) - DGAMLN(FKK+1.0D0,IDUM) - + * DGAMLN(TFNF+1.0D0,IDUM) + BK = EXP(BK) + SUMR = ZEROR + SUMI = ZEROI + KM = KK - INU + DO 50 I=1,KM + PTR = P2R + PTI = P2I + P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI) + P2I = P1I + (FKK+FNF)*(RZI*PTR+RZR*PTI) + P1R = PTR + P1I = PTI + AK = 1.0D0 - TFNF/(FKK+TFNF) + ACK = BK*AK + SUMR = SUMR + (ACK+BK)*P1R + SUMI = SUMI + (ACK+BK)*P1I + BK = ACK + FKK = FKK - 1.0D0 + 50 CONTINUE + YR(N) = P2R + YI(N) = P2I + IF (N.EQ.1) GO TO 70 + DO 60 I=2,N + PTR = P2R + PTI = P2I + P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI) + P2I = P1I + (FKK+FNF)*(RZI*PTR+RZR*PTI) + P1R = PTR + P1I = PTI + AK = 1.0D0 - TFNF/(FKK+TFNF) + ACK = BK*AK + SUMR = SUMR + (ACK+BK)*P1R + SUMI = SUMI + (ACK+BK)*P1I + BK = ACK + FKK = FKK - 1.0D0 + M = N - I + 1 + YR(M) = P2R + YI(M) = P2I + 60 CONTINUE + 70 CONTINUE + IF (IFNU.LE.0) GO TO 90 + DO 80 I=1,IFNU + PTR = P2R + PTI = P2I + P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI) + P2I = P1I + (FKK+FNF)*(RZR*PTI+RZI*PTR) + P1R = PTR + P1I = PTI + AK = 1.0D0 - TFNF/(FKK+TFNF) + ACK = BK*AK + SUMR = SUMR + (ACK+BK)*P1R + SUMI = SUMI + (ACK+BK)*P1I + BK = ACK + FKK = FKK - 1.0D0 + 80 CONTINUE + 90 CONTINUE + PTR = ZR + PTI = ZI + IF (KODE.EQ.2) PTR = ZEROR + CALL ZLOG(RZR, RZI, STR, STI, IDUM) + P1R = -FNF*STR + PTR + P1I = -FNF*STI + PTI + AP = DGAMLN(1.0D0+FNF,IDUM) + PTR = P1R - AP + PTI = P1I +C----------------------------------------------------------------------- +C THE DIVISION CEXP(PT)/(SUM+P2) IS ALTERED TO AVOID OVERFLOW +C IN THE DENOMINATOR BY SQUARING LARGE QUANTITIES +C----------------------------------------------------------------------- + P2R = P2R + SUMR + P2I = P2I + SUMI + AP = ZABS(P2R,P2I) + P1R = 1.0D0/AP + CALL ZEXP(PTR, PTI, STR, STI) + CKR = STR*P1R + CKI = STI*P1R + PTR = P2R*P1R + PTI = -P2I*P1R + CALL ZMLT(CKR, CKI, PTR, PTI, CNORMR, CNORMI) + DO 100 I=1,N + STR = YR(I)*CNORMR - YI(I)*CNORMI + YI(I) = YR(I)*CNORMI + YI(I)*CNORMR + YR(I) = STR + 100 CONTINUE + RETURN + 110 CONTINUE + NZ=-2 + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zmlri.lo b/modules/elementary_functions/src/fortran/slatec/zmlri.lo new file mode 100755 index 000000000..5ea477b93 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zmlri.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zmlri.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zmlri.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zmlt.f b/modules/elementary_functions/src/fortran/slatec/zmlt.f new file mode 100755 index 000000000..a4f130d6b --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zmlt.f @@ -0,0 +1,27 @@ +*DECK ZMLT + SUBROUTINE ZMLT (AR, AI, BR, BI, CR, CI) +C***BEGIN PROLOGUE ZMLT +C***SUBSIDIARY +C***PURPOSE Subsidiary to ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZAIRY and +C ZBIRY +C***LIBRARY SLATEC +C***TYPE ALL (ZMLT-A) +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C DOUBLE PRECISION COMPLEX MULTIPLY, C=A*B. +C +C***SEE ALSO ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZBIRY +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 910415 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE ZMLT + DOUBLE PRECISION AR, AI, BR, BI, CR, CI, CA, CB +C***FIRST EXECUTABLE STATEMENT ZMLT + CA = AR*BR - AI*BI + CB = AR*BI + AI*BR + CR = CA + CI = CB + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zmlt.lo b/modules/elementary_functions/src/fortran/slatec/zmlt.lo new file mode 100755 index 000000000..3f127777b --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zmlt.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zmlt.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zmlt.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zrati.f b/modules/elementary_functions/src/fortran/slatec/zrati.f new file mode 100755 index 000000000..8eedca9b8 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zrati.f @@ -0,0 +1,143 @@ +*DECK ZRATI + SUBROUTINE ZRATI (ZR, ZI, FNU, N, CYR, CYI, TOL) +C***BEGIN PROLOGUE ZRATI +C***SUBSIDIARY +C***PURPOSE Subsidiary to ZBESH, ZBESI and ZBESK +C***LIBRARY SLATEC +C***TYPE ALL (CRATI-A, ZRATI-A) +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C ZRATI COMPUTES RATIOS OF I BESSEL FUNCTIONS BY BACKWARD +C RECURRENCE. THE STARTING INDEX IS DETERMINED BY FORWARD +C RECURRENCE AS DESCRIBED IN J. RES. OF NAT. BUR. OF STANDARDS-B, +C MATHEMATICAL SCIENCES, VOL 77B, P111-114, SEPTEMBER, 1973, +C BESSEL FUNCTIONS I AND J OF COMPLEX ARGUMENT AND INTEGER ORDER, +C BY D. J. SOOKNE. +C +C***SEE ALSO ZBESH, ZBESI, ZBESK +C***ROUTINES CALLED ZABS, ZDIV +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 910415 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE ZRATI + DOUBLE PRECISION AK, AMAGZ, AP1, AP2, ARG, AZ, CDFNUI, CDFNUR, + * CONEI, CONER, CYI, CYR, CZEROI, CZEROR, DFNU, FDNU, FLAM, FNU, + * FNUP, PTI, PTR, P1I, P1R, P2I, P2R, RAK, RAP1, RHO, RT2, RZI, + * RZR, TEST, TEST1, TOL, TTI, TTR, T1I, T1R, ZI, ZR, ZABS + INTEGER I, ID, IDNU, INU, ITIME, K, KK, MAGZ, N + DIMENSION CYR(N), CYI(N) + EXTERNAL ZABS + DATA CZEROR,CZEROI,CONER,CONEI,RT2/ + 1 0.0D0, 0.0D0, 1.0D0, 0.0D0, 1.41421356237309505D0 / +C***FIRST EXECUTABLE STATEMENT ZRATI + AZ = ZABS(ZR,ZI) + INU = FNU + IDNU = INU + N - 1 + MAGZ = AZ + AMAGZ = MAGZ+1 + FDNU = IDNU + FNUP = MAX(AMAGZ,FDNU) + ID = IDNU - MAGZ - 1 + ITIME = 1 + K = 1 + PTR = 1.0D0/AZ + RZR = PTR*(ZR+ZR)*PTR + RZI = -PTR*(ZI+ZI)*PTR + T1R = RZR*FNUP + T1I = RZI*FNUP + P2R = -T1R + P2I = -T1I + P1R = CONER + P1I = CONEI + T1R = T1R + RZR + T1I = T1I + RZI + IF (ID.GT.0) ID = 0 + AP2 = ZABS(P2R,P2I) + AP1 = ZABS(P1R,P1I) +C----------------------------------------------------------------------- +C THE OVERFLOW TEST ON K(FNU+I-1,Z) BEFORE THE CALL TO CBKNU +C GUARANTEES THAT P2 IS ON SCALE. SCALE TEST1 AND ALL SUBSEQUENT +C P2 VALUES BY AP1 TO ENSURE THAT AN OVERFLOW DOES NOT OCCUR +C PREMATURELY. +C----------------------------------------------------------------------- + ARG = (AP2+AP2)/(AP1*TOL) + TEST1 = SQRT(ARG) + TEST = TEST1 + RAP1 = 1.0D0/AP1 + P1R = P1R*RAP1 + P1I = P1I*RAP1 + P2R = P2R*RAP1 + P2I = P2I*RAP1 + AP2 = AP2*RAP1 + 10 CONTINUE + K = K + 1 + AP1 = AP2 + PTR = P2R + PTI = P2I + P2R = P1R - (T1R*PTR-T1I*PTI) + P2I = P1I - (T1R*PTI+T1I*PTR) + P1R = PTR + P1I = PTI + T1R = T1R + RZR + T1I = T1I + RZI + AP2 = ZABS(P2R,P2I) + IF (AP1.LE.TEST) GO TO 10 + IF (ITIME.EQ.2) GO TO 20 + AK = ZABS(T1R,T1I)*0.5D0 + FLAM = AK + SQRT(AK*AK-1.0D0) + RHO = MIN(AP2/AP1,FLAM) + TEST = TEST1*SQRT(RHO/(RHO*RHO-1.0D0)) + ITIME = 2 + GO TO 10 + 20 CONTINUE + KK = K + 1 - ID + AK = KK + T1R = AK + T1I = CZEROI + DFNU = FNU + (N-1) + P1R = 1.0D0/AP2 + P1I = CZEROI + P2R = CZEROR + P2I = CZEROI + DO 30 I=1,KK + PTR = P1R + PTI = P1I + RAP1 = DFNU + T1R + TTR = RZR*RAP1 + TTI = RZI*RAP1 + P1R = (PTR*TTR-PTI*TTI) + P2R + P1I = (PTR*TTI+PTI*TTR) + P2I + P2R = PTR + P2I = PTI + T1R = T1R - CONER + 30 CONTINUE + IF (P1R.NE.CZEROR .OR. P1I.NE.CZEROI) GO TO 40 + P1R = TOL + P1I = TOL + 40 CONTINUE + CALL ZDIV(P2R, P2I, P1R, P1I, CYR(N), CYI(N)) + IF (N.EQ.1) RETURN + K = N - 1 + AK = K + T1R = AK + T1I = CZEROI + CDFNUR = FNU*RZR + CDFNUI = FNU*RZI + DO 60 I=2,N + PTR = CDFNUR + (T1R*RZR-T1I*RZI) + CYR(K+1) + PTI = CDFNUI + (T1R*RZI+T1I*RZR) + CYI(K+1) + AK = ZABS(PTR,PTI) + IF (AK.NE.CZEROR) GO TO 50 + PTR = TOL + PTI = TOL + AK = TOL*RT2 + 50 CONTINUE + RAK = CONER/AK + CYR(K) = RAK*PTR*RAK + CYI(K) = -RAK*PTI*RAK + T1R = T1R - CONER + K = K - 1 + 60 CONTINUE + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zrati.lo b/modules/elementary_functions/src/fortran/slatec/zrati.lo new file mode 100755 index 000000000..2e88d744a --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zrati.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zrati.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zrati.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zs1s2.f b/modules/elementary_functions/src/fortran/slatec/zs1s2.f new file mode 100755 index 000000000..e62809458 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zs1s2.f @@ -0,0 +1,62 @@ +*DECK ZS1S2 + SUBROUTINE ZS1S2 (ZRR, ZRI, S1R, S1I, S2R, S2I, NZ, ASCLE, ALIM, + + IUF) +C***BEGIN PROLOGUE ZS1S2 +C***SUBSIDIARY +C***PURPOSE Subsidiary to ZAIRY and ZBESK +C***LIBRARY SLATEC +C***TYPE ALL (CS1S2-A, ZS1S2-A) +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C ZS1S2 TESTS FOR A POSSIBLE UNDERFLOW RESULTING FROM THE +C ADDITION OF THE I AND K FUNCTIONS IN THE ANALYTIC CON- +C TINUATION FORMULA WHERE S1=K FUNCTION AND S2=I FUNCTION. +C ON KODE=1 THE I AND K FUNCTIONS ARE DIFFERENT ORDERS OF +C MAGNITUDE, BUT FOR KODE=2 THEY CAN BE OF THE SAME ORDER +C OF MAGNITUDE AND THE MAXIMUM MUST BE AT LEAST ONE +C PRECISION ABOVE THE UNDERFLOW LIMIT. +C +C***SEE ALSO ZAIRY, ZBESK +C***ROUTINES CALLED ZABS, ZEXP, ZLOG +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 910415 Prologue converted to Version 4.0 format. (BAB) +C 930122 Added ZEXP and ZLOG to EXTERNAL statement. (RWC) +C***END PROLOGUE ZS1S2 +C COMPLEX CZERO,C1,S1,S1D,S2,ZR + DOUBLE PRECISION AA, ALIM, ALN, ASCLE, AS1, AS2, C1I, C1R, S1DI, + * S1DR, S1I, S1R, S2I, S2R, ZEROI, ZEROR, ZRI, ZRR, ZABS + INTEGER IUF, IDUM, NZ + EXTERNAL ZABS, ZEXP, ZLOG + DATA ZEROR,ZEROI / 0.0D0 , 0.0D0 / +C***FIRST EXECUTABLE STATEMENT ZS1S2 + NZ = 0 + AS1 = ZABS(S1R,S1I) + AS2 = ZABS(S2R,S2I) + IF (S1R.EQ.0.0D0 .AND. S1I.EQ.0.0D0) GO TO 10 + IF (AS1.EQ.0.0D0) GO TO 10 + ALN = -ZRR - ZRR + LOG(AS1) + S1DR = S1R + S1DI = S1I + S1R = ZEROR + S1I = ZEROI + AS1 = ZEROR + IF (ALN.LT.(-ALIM)) GO TO 10 + CALL ZLOG(S1DR, S1DI, C1R, C1I, IDUM) + C1R = C1R - ZRR - ZRR + C1I = C1I - ZRI - ZRI + CALL ZEXP(C1R, C1I, S1R, S1I) + AS1 = ZABS(S1R,S1I) + IUF = IUF + 1 + 10 CONTINUE + AA = MAX(AS1,AS2) + IF (AA.GT.ASCLE) RETURN + S1R = ZEROR + S1I = ZEROI + S2R = ZEROR + S2I = ZEROI + NZ = 1 + IUF = 0 + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zs1s2.lo b/modules/elementary_functions/src/fortran/slatec/zs1s2.lo new file mode 100755 index 000000000..6f29b1abb --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zs1s2.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zs1s2.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zs1s2.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zseri.f b/modules/elementary_functions/src/fortran/slatec/zseri.f new file mode 100755 index 000000000..f577e96fa --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zseri.f @@ -0,0 +1,203 @@ +*DECK ZSERI + SUBROUTINE ZSERI (ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL, ELIM, + + ALIM) +C***BEGIN PROLOGUE ZSERI +C***SUBSIDIARY +C***PURPOSE Subsidiary to ZBESI and ZBESK +C***LIBRARY SLATEC +C***TYPE ALL (CSERI-A, ZSERI-A) +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C ZSERI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY +C MEANS OF THE POWER SERIES FOR LARGE ABS(Z) IN THE +C REGION ABS(Z).LE.2*SQRT(FNU+1). NZ=0 IS A NORMAL RETURN. +C NZ.GT.0 MEANS THAT THE LAST NZ COMPONENTS WERE SET TO ZERO +C DUE TO UNDERFLOW. NZ.LT.0 MEANS UNDERFLOW OCCURRED, BUT THE +C CONDITION ABS(Z).LE.2*SQRT(FNU+1) WAS VIOLATED AND THE +C COMPUTATION MUST BE COMPLETED IN ANOTHER ROUTINE WITH N=N-ABS(NZ). +C +C***SEE ALSO ZBESI, ZBESK +C***ROUTINES CALLED D1MACH, DGAMLN, ZABS, ZDIV, ZLOG, ZMLT, ZUCHK +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 910415 Prologue converted to Version 4.0 format. (BAB) +C 930122 Added ZLOG to EXTERNAL statement. (RWC) +C***END PROLOGUE ZSERI +C COMPLEX AK1,CK,COEF,CONE,CRSC,CSCL,CZ,CZERO,HZ,RZ,S1,S2,Y,Z + DOUBLE PRECISION AA, ACZ, AK, AK1I, AK1R, ALIM, ARM, ASCLE, ATOL, + * AZ, CKI, CKR, COEFI, COEFR, CONEI, CONER, CRSCR, CZI, CZR, DFNU, + * ELIM, FNU, FNUP, HZI, HZR, RAZ, RS, RTR1, RZI, RZR, S, SS, STI, + * STR, S1I, S1R, S2I, S2R, TOL, YI, YR, WI, WR, ZEROI, ZEROR, ZI, + * ZR, DGAMLN, D1MACH, ZABS + INTEGER I, IB, IDUM, IFLAG, IL, K, KODE, L, M, N, NN, NZ, NW + DIMENSION YR(N), YI(N), WR(2), WI(2) + EXTERNAL ZABS, ZLOG + DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / +C***FIRST EXECUTABLE STATEMENT ZSERI + NZ = 0 + AZ = ZABS(ZR,ZI) + IF (AZ.EQ.0.0D0) GO TO 160 + ARM = 1.0D+3*D1MACH(1) + RTR1 = SQRT(ARM) + CRSCR = 1.0D0 + IFLAG = 0 + IF (AZ.LT.ARM) GO TO 150 + HZR = 0.5D0*ZR + HZI = 0.5D0*ZI + CZR = ZEROR + CZI = ZEROI + IF (AZ.LE.RTR1) GO TO 10 + CALL ZMLT(HZR, HZI, HZR, HZI, CZR, CZI) + 10 CONTINUE + ACZ = ZABS(CZR,CZI) + NN = N + CALL ZLOG(HZR, HZI, CKR, CKI, IDUM) + 20 CONTINUE + DFNU = FNU + (NN-1) + FNUP = DFNU + 1.0D0 +C----------------------------------------------------------------------- +C UNDERFLOW TEST +C----------------------------------------------------------------------- + AK1R = CKR*DFNU + AK1I = CKI*DFNU + AK = DGAMLN(FNUP,IDUM) + AK1R = AK1R - AK + IF (KODE.EQ.2) AK1R = AK1R - ZR + IF (AK1R.GT.(-ELIM)) GO TO 40 + 30 CONTINUE + NZ = NZ + 1 + YR(NN) = ZEROR + YI(NN) = ZEROI + IF (ACZ.GT.DFNU) GO TO 190 + NN = NN - 1 + IF (NN.EQ.0) RETURN + GO TO 20 + 40 CONTINUE + IF (AK1R.GT.(-ALIM)) GO TO 50 + IFLAG = 1 + SS = 1.0D0/TOL + CRSCR = TOL + ASCLE = ARM*SS + 50 CONTINUE + AA = EXP(AK1R) + IF (IFLAG.EQ.1) AA = AA*SS + COEFR = AA*COS(AK1I) + COEFI = AA*SIN(AK1I) + ATOL = TOL*ACZ/FNUP + IL = MIN(2,NN) + DO 90 I=1,IL + DFNU = FNU + (NN-I) + FNUP = DFNU + 1.0D0 + S1R = CONER + S1I = CONEI + IF (ACZ.LT.TOL*FNUP) GO TO 70 + AK1R = CONER + AK1I = CONEI + AK = FNUP + 2.0D0 + S = FNUP + AA = 2.0D0 + 60 CONTINUE + RS = 1.0D0/S + STR = AK1R*CZR - AK1I*CZI + STI = AK1R*CZI + AK1I*CZR + AK1R = STR*RS + AK1I = STI*RS + S1R = S1R + AK1R + S1I = S1I + AK1I + S = S + AK + AK = AK + 2.0D0 + AA = AA*ACZ*RS + IF (AA.GT.ATOL) GO TO 60 + 70 CONTINUE + S2R = S1R*COEFR - S1I*COEFI + S2I = S1R*COEFI + S1I*COEFR + WR(I) = S2R + WI(I) = S2I + IF (IFLAG.EQ.0) GO TO 80 + CALL ZUCHK(S2R, S2I, NW, ASCLE, TOL) + IF (NW.NE.0) GO TO 30 + 80 CONTINUE + M = NN - I + 1 + YR(M) = S2R*CRSCR + YI(M) = S2I*CRSCR + IF (I.EQ.IL) GO TO 90 + CALL ZDIV(COEFR, COEFI, HZR, HZI, STR, STI) + COEFR = STR*DFNU + COEFI = STI*DFNU + 90 CONTINUE + + IF (NN.LE.2) RETURN + K = NN - 2 + AK = K + RAZ = 1.0D0/AZ + STR = ZR*RAZ + STI = -ZI*RAZ + RZR = (STR+STR)*RAZ + RZI = (STI+STI)*RAZ + IF (IFLAG.EQ.1) GO TO 120 + IB = 3 + 100 CONTINUE + DO 110 I=IB,NN + YR(K) = (AK+FNU)*(RZR*YR(K+1)-RZI*YI(K+1)) + YR(K+2) + YI(K) = (AK+FNU)*(RZR*YI(K+1)+RZI*YR(K+1)) + YI(K+2) + AK = AK - 1.0D0 + K = K - 1 + 110 CONTINUE + RETURN +C----------------------------------------------------------------------- +C RECUR BACKWARD WITH SCALED VALUES +C----------------------------------------------------------------------- + 120 CONTINUE +C----------------------------------------------------------------------- +C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION ABOVE THE +C UNDERFLOW LIMIT = ASCLE = D1MACH(1)*SS*1.0D+3 +C----------------------------------------------------------------------- + S1R = WR(1) + S1I = WI(1) + S2R = WR(2) + S2I = WI(2) + DO 130 L=3,NN + CKR = S2R + CKI = S2I + S2R = S1R + (AK+FNU)*(RZR*CKR-RZI*CKI) + S2I = S1I + (AK+FNU)*(RZR*CKI+RZI*CKR) + S1R = CKR + S1I = CKI + CKR = S2R*CRSCR + CKI = S2I*CRSCR + YR(K) = CKR + YI(K) = CKI + AK = AK - 1.0D0 + K = K - 1 + IF (ZABS(CKR,CKI).GT.ASCLE) GO TO 140 + 130 CONTINUE + RETURN + 140 CONTINUE + IB = L + 1 + IF (IB.GT.NN) RETURN + GO TO 100 + 150 CONTINUE + NZ = N + IF (FNU.EQ.0.0D0) NZ = NZ - 1 + 160 CONTINUE + YR(1) = ZEROR + YI(1) = ZEROI + IF (FNU.NE.0.0D0) GO TO 170 + YR(1) = CONER + YI(1) = CONEI + 170 CONTINUE + IF (N.EQ.1) RETURN + DO 180 I=2,N + YR(I) = ZEROR + YI(I) = ZEROI + 180 CONTINUE + RETURN +C----------------------------------------------------------------------- +C RETURN WITH NZ.LT.0 IF ABS(Z*Z/4).GT.FNU+N-NZ-1 COMPLETE +C THE CALCULATION IN CBINU WITH N=N-ABS(NZ) +C----------------------------------------------------------------------- + 190 CONTINUE + NZ = -NZ + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zseri.lo b/modules/elementary_functions/src/fortran/slatec/zseri.lo new file mode 100755 index 000000000..09d0e23a3 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zseri.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zseri.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zseri.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zshch.f b/modules/elementary_functions/src/fortran/slatec/zshch.f new file mode 100755 index 000000000..3b394cdca --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zshch.f @@ -0,0 +1,32 @@ +*DECK ZSHCH + SUBROUTINE ZSHCH (ZR, ZI, CSHR, CSHI, CCHR, CCHI) +C***BEGIN PROLOGUE ZSHCH +C***SUBSIDIARY +C***PURPOSE Subsidiary to ZBESH and ZBESK +C***LIBRARY SLATEC +C***TYPE ALL (CSHCH-A, ZSHCH-A) +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C ZSHCH COMPUTES THE COMPLEX HYPERBOLIC FUNCTIONS CSH=SINH(X+I*Y) +C AND CCH=COSH(X+I*Y), WHERE I**2=-1. +C +C***SEE ALSO ZBESH, ZBESK +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 910415 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE ZSHCH +C + DOUBLE PRECISION CCHI, CCHR, CH, CN, CSHI, CSHR, SH, SN, ZI, ZR +C***FIRST EXECUTABLE STATEMENT ZSHCH + SH = SINH(ZR) + CH = COSH(ZR) + SN = SIN(ZI) + CN = COS(ZI) + CSHR = SH*CN + CSHI = CH*SN + CCHR = CH*CN + CCHI = SH*SN + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zshch.lo b/modules/elementary_functions/src/fortran/slatec/zshch.lo new file mode 100755 index 000000000..22a38ded2 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zshch.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zshch.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zshch.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zsqrt.f b/modules/elementary_functions/src/fortran/slatec/zsqrt.f new file mode 100755 index 000000000..86a7b05f3 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zsqrt.f @@ -0,0 +1,57 @@ +*DECK ZSQRT + SUBROUTINE ZSQRT (AR, AI, BR, BI) +C***BEGIN PROLOGUE ZSQRT +C***SUBSIDIARY +C***PURPOSE Subsidiary to ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZAIRY and +C ZBIRY +C***LIBRARY SLATEC +C***TYPE ALL (ZSQRT-A) +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C DOUBLE PRECISION COMPLEX SQUARE ROOT, B=CSQRT(A) +C +C***SEE ALSO ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZBIRY +C***ROUTINES CALLED ZABS +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 910415 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE ZSQRT + DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DRT + DOUBLE PRECISION ZABS + EXTERNAL ZABS + DATA DRT , DPI / 7.071067811865475244008443621D-1, + 1 3.141592653589793238462643383D+0/ +C***FIRST EXECUTABLE STATEMENT ZSQRT + ZM = ZABS(AR,AI) + ZM = SQRT(ZM) + IF (AR.EQ.0.0D+0) GO TO 10 + IF (AI.EQ.0.0D+0) GO TO 20 + DTHETA = DATAN(AI/AR) + IF (DTHETA.LE.0.0D+0) GO TO 40 + IF (AR.LT.0.0D+0) DTHETA = DTHETA - DPI + GO TO 50 + 10 IF (AI.GT.0.0D+0) GO TO 60 + IF (AI.LT.0.0D+0) GO TO 70 + BR = 0.0D+0 + BI = 0.0D+0 + RETURN + 20 IF (AR.GT.0.0D+0) GO TO 30 + BR = 0.0D+0 + BI = SQRT(ABS(AR)) + RETURN + 30 BR = SQRT(AR) + BI = 0.0D+0 + RETURN + 40 IF (AR.LT.0.0D+0) DTHETA = DTHETA + DPI + 50 DTHETA = DTHETA*0.5D+0 + BR = ZM*COS(DTHETA) + BI = ZM*SIN(DTHETA) + RETURN + 60 BR = ZM*DRT + BI = ZM*DRT + RETURN + 70 BR = ZM*DRT + BI = -ZM*DRT + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zsqrt.lo b/modules/elementary_functions/src/fortran/slatec/zsqrt.lo new file mode 100755 index 000000000..f8fa67fb9 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zsqrt.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zsqrt.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zsqrt.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zuchk.f b/modules/elementary_functions/src/fortran/slatec/zuchk.f new file mode 100755 index 000000000..ebf85c3d7 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zuchk.f @@ -0,0 +1,40 @@ +*DECK ZUCHK + SUBROUTINE ZUCHK (YR, YI, NZ, ASCLE, TOL) +C***BEGIN PROLOGUE ZUCHK +C***SUBSIDIARY +C***PURPOSE Subsidiary to SERI, ZUOIK, ZUNK1, ZUNK2, ZUNI1, ZUNI2 and +C ZKSCL +C***LIBRARY SLATEC +C***TYPE ALL (CUCHK-A, ZUCHK-A) +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C Y ENTERS AS A SCALED QUANTITY WHOSE MAGNITUDE IS GREATER THAN +C EXP(-ALIM)=ASCLE=1.0E+3*D1MACH(1)/TOL. THE TEST IS MADE TO SEE +C IF THE MAGNITUDE OF THE REAL OR IMAGINARY PART WOULD UNDERFLOW +C WHEN Y IS SCALED (BY TOL) TO ITS PROPER VALUE. Y IS ACCEPTED +C IF THE UNDERFLOW IS AT LEAST ONE PRECISION BELOW THE MAGNITUDE +C OF THE LARGEST COMPONENT; OTHERWISE THE PHASE ANGLE DOES NOT HAVE +C ABSOLUTE ACCURACY AND AN UNDERFLOW IS ASSUMED. +C +C***SEE ALSO SERI, ZKSCL, ZUNI1, ZUNI2, ZUNK1, ZUNK2, ZUOIK +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C ?????? DATE WRITTEN +C 910415 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE ZUCHK +C +C COMPLEX Y + DOUBLE PRECISION ASCLE, SS, ST, TOL, WR, WI, YR, YI + INTEGER NZ +C***FIRST EXECUTABLE STATEMENT ZUCHK + NZ = 0 + WR = ABS(YR) + WI = ABS(YI) + ST = MIN(WR,WI) + IF (ST.GT.ASCLE) RETURN + SS = MAX(WR,WI) + ST = ST/TOL + IF (SS.LT.ST) NZ = 1 + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zuchk.lo b/modules/elementary_functions/src/fortran/slatec/zuchk.lo new file mode 100755 index 000000000..bb7a5d636 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zuchk.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zuchk.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zuchk.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zunhj.f b/modules/elementary_functions/src/fortran/slatec/zunhj.f new file mode 100755 index 000000000..5df7a3326 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zunhj.f @@ -0,0 +1,726 @@ +*DECK ZUNHJ + SUBROUTINE ZUNHJ (ZR, ZI, FNU, IPMTR, TOL, PHIR, PHII, ARGR, ARGI, + + ZETA1R, ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) +C***BEGIN PROLOGUE ZUNHJ +C***SUBSIDIARY +C***PURPOSE Subsidiary to ZBESI and ZBESK +C***LIBRARY SLATEC +C***TYPE ALL (CUNHJ-A, ZUNHJ-A) +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C REFERENCES +C HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ AND I.A. +C STEGUN, AMS55, NATIONAL BUREAU OF STANDARDS, 1965, CHAPTER 9. +C +C ASYMPTOTICS AND SPECIAL FUNCTIONS BY F.W.J. OLVER, ACADEMIC +C PRESS, N.Y., 1974, PAGE 420 +C +C ABSTRACT +C ZUNHJ COMPUTES PARAMETERS FOR BESSEL FUNCTIONS C(FNU,Z) = +C J(FNU,Z), Y(FNU,Z) OR H(I,FNU,Z) I=1,2 FOR LARGE ORDERS FNU +C BY MEANS OF THE UNIFORM ASYMPTOTIC EXPANSION +C +C C(FNU,Z)=C1*PHI*( ASUM*AIRY(ARG) + C2*BSUM*DAIRY(ARG) ) +C +C FOR PROPER CHOICES OF C1, C2, AIRY AND DAIRY WHERE AIRY IS +C AN AIRY FUNCTION AND DAIRY IS ITS DERIVATIVE. +C +C (2/3)*FNU*ZETA**1.5 = ZETA1-ZETA2, +C +C ZETA1=0.5*FNU*CLOG((1+W)/(1-W)), ZETA2=FNU*W FOR SCALING +C PURPOSES IN AIRY FUNCTIONS FROM CAIRY OR CBIRY. +C +C MCONJ=SIGN OF AIMAG(Z), BUT IS AMBIGUOUS WHEN Z IS REAL AND +C MUST BE SPECIFIED. IPMTR=0 RETURNS ALL PARAMETERS. IPMTR= +C 1 COMPUTES ALL EXCEPT ASUM AND BSUM. +C +C***SEE ALSO ZBESI, ZBESK +C***ROUTINES CALLED D1MACH, ZABS, ZDIV, ZLOG, ZSQRT +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 910415 Prologue converted to Version 4.0 format. (BAB) +C 930122 Added ZLOG and ZSQRT to EXTERNAL statement. (RWC) +C***END PROLOGUE ZUNHJ +C COMPLEX ARG,ASUM,BSUM,CFNU,CONE,CR,CZERO,DR,P,PHI,PRZTH,PTFN, +C *RFN13,RTZTA,RZTH,SUMA,SUMB,TFN,T2,UP,W,W2,Z,ZA,ZB,ZC,ZETA,ZETA1, +C *ZETA2,ZTH + DOUBLE PRECISION ALFA, ANG, AP, AR, ARGI, ARGR, ASUMI, ASUMR, + * ATOL, AW2, AZTH, BETA, BR, BSUMI, BSUMR, BTOL, C, CONEI, CONER, + * CRI, CRR, DRI, DRR, EX1, EX2, FNU, FN13, FN23, GAMA, GPI, HPI, + * PHII, PHIR, PI, PP, PR, PRZTHI, PRZTHR, PTFNI, PTFNR, RAW, RAW2, + * RAZTH, RFNU, RFNU2, RFN13, RTZTI, RTZTR, RZTHI, RZTHR, STI, STR, + * SUMAI, SUMAR, SUMBI, SUMBR, TEST, TFNI, TFNR, THPI, TOL, TZAI, + * TZAR, T2I, T2R, UPI, UPR, WI, WR, W2I, W2R, ZAI, ZAR, ZBI, ZBR, + * ZCI, ZCR, ZEROI, ZEROR, ZETAI, ZETAR, ZETA1I, ZETA1R, ZETA2I, + * ZETA2R, ZI, ZR, ZTHI, ZTHR, ZABS, AC, D1MACH + INTEGER IAS, IBS, IPMTR, IS, J, JR, JU, K, KMAX, KP1, KS, L, LR, + * LRP1, L1, L2, M, IDUM + DIMENSION AR(14), BR(14), C(105), ALFA(180), BETA(210), GAMA(30), + * AP(30), PR(30), PI(30), UPR(14), UPI(14), CRR(14), CRI(14), + * DRR(14), DRI(14) + EXTERNAL ZABS, ZLOG, ZSQRT + DATA AR(1), AR(2), AR(3), AR(4), AR(5), AR(6), AR(7), AR(8), + 1 AR(9), AR(10), AR(11), AR(12), AR(13), AR(14)/ + 2 1.00000000000000000D+00, 1.04166666666666667D-01, + 3 8.35503472222222222D-02, 1.28226574556327160D-01, + 4 2.91849026464140464D-01, 8.81627267443757652D-01, + 5 3.32140828186276754D+00, 1.49957629868625547D+01, + 6 7.89230130115865181D+01, 4.74451538868264323D+02, + 7 3.20749009089066193D+03, 2.40865496408740049D+04, + 8 1.98923119169509794D+05, 1.79190200777534383D+06/ + DATA BR(1), BR(2), BR(3), BR(4), BR(5), BR(6), BR(7), BR(8), + 1 BR(9), BR(10), BR(11), BR(12), BR(13), BR(14)/ + 2 1.00000000000000000D+00, -1.45833333333333333D-01, + 3 -9.87413194444444444D-02, -1.43312053915895062D-01, + 4 -3.17227202678413548D-01, -9.42429147957120249D-01, + 5 -3.51120304082635426D+00, -1.57272636203680451D+01, + 6 -8.22814390971859444D+01, -4.92355370523670524D+02, + 7 -3.31621856854797251D+03, -2.48276742452085896D+04, + 8 -2.04526587315129788D+05, -1.83844491706820990D+06/ + DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), + 1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), + 2 C(19), C(20), C(21), C(22), C(23), C(24)/ + 3 1.00000000000000000D+00, -2.08333333333333333D-01, + 4 1.25000000000000000D-01, 3.34201388888888889D-01, + 5 -4.01041666666666667D-01, 7.03125000000000000D-02, + 6 -1.02581259645061728D+00, 1.84646267361111111D+00, + 7 -8.91210937500000000D-01, 7.32421875000000000D-02, + 8 4.66958442342624743D+00, -1.12070026162229938D+01, + 9 8.78912353515625000D+00, -2.36408691406250000D+00, + A 1.12152099609375000D-01, -2.82120725582002449D+01, + B 8.46362176746007346D+01, -9.18182415432400174D+01, + C 4.25349987453884549D+01, -7.36879435947963170D+00, + D 2.27108001708984375D-01, 2.12570130039217123D+02, + E -7.65252468141181642D+02, 1.05999045252799988D+03/ + DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), + 1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), + 2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ + 3 -6.99579627376132541D+02, 2.18190511744211590D+02, + 4 -2.64914304869515555D+01, 5.72501420974731445D-01, + 5 -1.91945766231840700D+03, 8.06172218173730938D+03, + 6 -1.35865500064341374D+04, 1.16553933368645332D+04, + 7 -5.30564697861340311D+03, 1.20090291321635246D+03, + 8 -1.08090919788394656D+02, 1.72772750258445740D+00, + 9 2.02042913309661486D+04, -9.69805983886375135D+04, + A 1.92547001232531532D+05, -2.03400177280415534D+05, + B 1.22200464983017460D+05, -4.11926549688975513D+04, + C 7.10951430248936372D+03, -4.93915304773088012D+02, + D 6.07404200127348304D+00, -2.42919187900551333D+05, + E 1.31176361466297720D+06, -2.99801591853810675D+06/ + DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), + 1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), + 2 C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/ + 3 3.76327129765640400D+06, -2.81356322658653411D+06, + 4 1.26836527332162478D+06, -3.31645172484563578D+05, + 5 4.52187689813627263D+04, -2.49983048181120962D+03, + 6 2.43805296995560639D+01, 3.28446985307203782D+06, + 7 -1.97068191184322269D+07, 5.09526024926646422D+07, + 8 -7.41051482115326577D+07, 6.63445122747290267D+07, + 9 -3.75671766607633513D+07, 1.32887671664218183D+07, + A -2.78561812808645469D+06, 3.08186404612662398D+05, + B -1.38860897537170405D+04, 1.10017140269246738D+02, + C -4.93292536645099620D+07, 3.25573074185765749D+08, + D -9.39462359681578403D+08, 1.55359689957058006D+09, + E -1.62108055210833708D+09, 1.10684281682301447D+09/ + DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80), + 1 C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88), + 2 C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/ + 3 -4.95889784275030309D+08, 1.42062907797533095D+08, + 4 -2.44740627257387285D+07, 2.24376817792244943D+06, + 5 -8.40054336030240853D+04, 5.51335896122020586D+02, + 6 8.14789096118312115D+08, -5.86648149205184723D+09, + 7 1.86882075092958249D+10, -3.46320433881587779D+10, + 8 4.12801855797539740D+10, -3.30265997498007231D+10, + 9 1.79542137311556001D+10, -6.56329379261928433D+09, + A 1.55927986487925751D+09, -2.25105661889415278D+08, + B 1.73951075539781645D+07, -5.49842327572288687D+05, + C 3.03809051092238427D+03, -1.46792612476956167D+10, + D 1.14498237732025810D+11, -3.99096175224466498D+11, + E 8.19218669548577329D+11, -1.09837515608122331D+12/ + DATA C(97), C(98), C(99), C(100), C(101), C(102), C(103), C(104), + 1 C(105)/ + 2 1.00815810686538209D+12, -6.45364869245376503D+11, + 3 2.87900649906150589D+11, -8.78670721780232657D+10, + 4 1.76347306068349694D+10, -2.16716498322379509D+09, + 5 1.43157876718888981D+08, -3.87183344257261262D+06, + 6 1.82577554742931747D+04/ + DATA ALFA(1), ALFA(2), ALFA(3), ALFA(4), ALFA(5), ALFA(6), + 1 ALFA(7), ALFA(8), ALFA(9), ALFA(10), ALFA(11), ALFA(12), + 2 ALFA(13), ALFA(14), ALFA(15), ALFA(16), ALFA(17), ALFA(18), + 3 ALFA(19), ALFA(20), ALFA(21), ALFA(22)/ + 4 -4.44444444444444444D-03, -9.22077922077922078D-04, + 5 -8.84892884892884893D-05, 1.65927687832449737D-04, + 6 2.46691372741792910D-04, 2.65995589346254780D-04, + 7 2.61824297061500945D-04, 2.48730437344655609D-04, + 8 2.32721040083232098D-04, 2.16362485712365082D-04, + 9 2.00738858762752355D-04, 1.86267636637545172D-04, + A 1.73060775917876493D-04, 1.61091705929015752D-04, + B 1.50274774160908134D-04, 1.40503497391269794D-04, + C 1.31668816545922806D-04, 1.23667445598253261D-04, + D 1.16405271474737902D-04, 1.09798298372713369D-04, + E 1.03772410422992823D-04, 9.82626078369363448D-05/ + DATA ALFA(23), ALFA(24), ALFA(25), ALFA(26), ALFA(27), ALFA(28), + 1 ALFA(29), ALFA(30), ALFA(31), ALFA(32), ALFA(33), ALFA(34), + 2 ALFA(35), ALFA(36), ALFA(37), ALFA(38), ALFA(39), ALFA(40), + 3 ALFA(41), ALFA(42), ALFA(43), ALFA(44)/ + 4 9.32120517249503256D-05, 8.85710852478711718D-05, + 5 8.42963105715700223D-05, 8.03497548407791151D-05, + 6 7.66981345359207388D-05, 7.33122157481777809D-05, + 7 7.01662625163141333D-05, 6.72375633790160292D-05, + 8 6.93735541354588974D-04, 2.32241745182921654D-04, + 9 -1.41986273556691197D-05, -1.16444931672048640D-04, + A -1.50803558053048762D-04, -1.55121924918096223D-04, + B -1.46809756646465549D-04, -1.33815503867491367D-04, + C -1.19744975684254051D-04, -1.06184319207974020D-04, + D -9.37699549891194492D-05, -8.26923045588193274D-05, + E -7.29374348155221211D-05, -6.44042357721016283D-05/ + DATA ALFA(45), ALFA(46), ALFA(47), ALFA(48), ALFA(49), ALFA(50), + 1 ALFA(51), ALFA(52), ALFA(53), ALFA(54), ALFA(55), ALFA(56), + 2 ALFA(57), ALFA(58), ALFA(59), ALFA(60), ALFA(61), ALFA(62), + 3 ALFA(63), ALFA(64), ALFA(65), ALFA(66)/ + 4 -5.69611566009369048D-05, -5.04731044303561628D-05, + 5 -4.48134868008882786D-05, -3.98688727717598864D-05, + 6 -3.55400532972042498D-05, -3.17414256609022480D-05, + 7 -2.83996793904174811D-05, -2.54522720634870566D-05, + 8 -2.28459297164724555D-05, -2.05352753106480604D-05, + 9 -1.84816217627666085D-05, -1.66519330021393806D-05, + A -1.50179412980119482D-05, -1.35554031379040526D-05, + B -1.22434746473858131D-05, -1.10641884811308169D-05, + C -3.54211971457743841D-04, -1.56161263945159416D-04, + D 3.04465503594936410D-05, 1.30198655773242693D-04, + E 1.67471106699712269D-04, 1.70222587683592569D-04/ + DATA ALFA(67), ALFA(68), ALFA(69), ALFA(70), ALFA(71), ALFA(72), + 1 ALFA(73), ALFA(74), ALFA(75), ALFA(76), ALFA(77), ALFA(78), + 2 ALFA(79), ALFA(80), ALFA(81), ALFA(82), ALFA(83), ALFA(84), + 3 ALFA(85), ALFA(86), ALFA(87), ALFA(88)/ + 4 1.56501427608594704D-04, 1.36339170977445120D-04, + 5 1.14886692029825128D-04, 9.45869093034688111D-05, + 6 7.64498419250898258D-05, 6.07570334965197354D-05, + 7 4.74394299290508799D-05, 3.62757512005344297D-05, + 8 2.69939714979224901D-05, 1.93210938247939253D-05, + 9 1.30056674793963203D-05, 7.82620866744496661D-06, + A 3.59257485819351583D-06, 1.44040049814251817D-07, + B -2.65396769697939116D-06, -4.91346867098485910D-06, + C -6.72739296091248287D-06, -8.17269379678657923D-06, + D -9.31304715093561232D-06, -1.02011418798016441D-05, + E -1.08805962510592880D-05, -1.13875481509603555D-05/ + DATA ALFA(89), ALFA(90), ALFA(91), ALFA(92), ALFA(93), ALFA(94), + 1 ALFA(95), ALFA(96), ALFA(97), ALFA(98), ALFA(99), ALFA(100), + 2 ALFA(101), ALFA(102), ALFA(103), ALFA(104), ALFA(105), + 3 ALFA(106), ALFA(107), ALFA(108), ALFA(109), ALFA(110)/ + 4 -1.17519675674556414D-05, -1.19987364870944141D-05, + 5 3.78194199201772914D-04, 2.02471952761816167D-04, + 6 -6.37938506318862408D-05, -2.38598230603005903D-04, + 7 -3.10916256027361568D-04, -3.13680115247576316D-04, + 8 -2.78950273791323387D-04, -2.28564082619141374D-04, + 9 -1.75245280340846749D-04, -1.25544063060690348D-04, + A -8.22982872820208365D-05, -4.62860730588116458D-05, + B -1.72334302366962267D-05, 5.60690482304602267D-06, + C 2.31395443148286800D-05, 3.62642745856793957D-05, + D 4.58006124490188752D-05, 5.24595294959114050D-05, + E 5.68396208545815266D-05, 5.94349820393104052D-05/ + DATA ALFA(111), ALFA(112), ALFA(113), ALFA(114), ALFA(115), + 1 ALFA(116), ALFA(117), ALFA(118), ALFA(119), ALFA(120), + 2 ALFA(121), ALFA(122), ALFA(123), ALFA(124), ALFA(125), + 3 ALFA(126), ALFA(127), ALFA(128), ALFA(129), ALFA(130)/ + 4 6.06478527578421742D-05, 6.08023907788436497D-05, + 5 6.01577894539460388D-05, 5.89199657344698500D-05, + 6 5.72515823777593053D-05, 5.52804375585852577D-05, + 7 5.31063773802880170D-05, 5.08069302012325706D-05, + 8 4.84418647620094842D-05, 4.60568581607475370D-05, + 9 -6.91141397288294174D-04, -4.29976633058871912D-04, + A 1.83067735980039018D-04, 6.60088147542014144D-04, + B 8.75964969951185931D-04, 8.77335235958235514D-04, + C 7.49369585378990637D-04, 5.63832329756980918D-04, + D 3.68059319971443156D-04, 1.88464535514455599D-04/ + DATA ALFA(131), ALFA(132), ALFA(133), ALFA(134), ALFA(135), + 1 ALFA(136), ALFA(137), ALFA(138), ALFA(139), ALFA(140), + 2 ALFA(141), ALFA(142), ALFA(143), ALFA(144), ALFA(145), + 3 ALFA(146), ALFA(147), ALFA(148), ALFA(149), ALFA(150)/ + 4 3.70663057664904149D-05, -8.28520220232137023D-05, + 5 -1.72751952869172998D-04, -2.36314873605872983D-04, + 6 -2.77966150694906658D-04, -3.02079514155456919D-04, + 7 -3.12594712643820127D-04, -3.12872558758067163D-04, + 8 -3.05678038466324377D-04, -2.93226470614557331D-04, + 9 -2.77255655582934777D-04, -2.59103928467031709D-04, + A -2.39784014396480342D-04, -2.20048260045422848D-04, + B -2.00443911094971498D-04, -1.81358692210970687D-04, + C -1.63057674478657464D-04, -1.45712672175205844D-04, + D -1.29425421983924587D-04, -1.14245691942445952D-04/ + DATA ALFA(151), ALFA(152), ALFA(153), ALFA(154), ALFA(155), + 1 ALFA(156), ALFA(157), ALFA(158), ALFA(159), ALFA(160), + 2 ALFA(161), ALFA(162), ALFA(163), ALFA(164), ALFA(165), + 3 ALFA(166), ALFA(167), ALFA(168), ALFA(169), ALFA(170)/ + 4 1.92821964248775885D-03, 1.35592576302022234D-03, + 5 -7.17858090421302995D-04, -2.58084802575270346D-03, + 6 -3.49271130826168475D-03, -3.46986299340960628D-03, + 7 -2.82285233351310182D-03, -1.88103076404891354D-03, + 8 -8.89531718383947600D-04, 3.87912102631035228D-06, + 9 7.28688540119691412D-04, 1.26566373053457758D-03, + A 1.62518158372674427D-03, 1.83203153216373172D-03, + B 1.91588388990527909D-03, 1.90588846755546138D-03, + C 1.82798982421825727D-03, 1.70389506421121530D-03, + D 1.55097127171097686D-03, 1.38261421852276159D-03/ + DATA ALFA(171), ALFA(172), ALFA(173), ALFA(174), ALFA(175), + 1 ALFA(176), ALFA(177), ALFA(178), ALFA(179), ALFA(180)/ + 2 1.20881424230064774D-03, 1.03676532638344962D-03, + 3 8.71437918068619115D-04, 7.16080155297701002D-04, + 4 5.72637002558129372D-04, 4.42089819465802277D-04, + 5 3.24724948503090564D-04, 2.20342042730246599D-04, + 6 1.28412898401353882D-04, 4.82005924552095464D-05/ + DATA BETA(1), BETA(2), BETA(3), BETA(4), BETA(5), BETA(6), + 1 BETA(7), BETA(8), BETA(9), BETA(10), BETA(11), BETA(12), + 2 BETA(13), BETA(14), BETA(15), BETA(16), BETA(17), BETA(18), + 3 BETA(19), BETA(20), BETA(21), BETA(22)/ + 4 1.79988721413553309D-02, 5.59964911064388073D-03, + 5 2.88501402231132779D-03, 1.80096606761053941D-03, + 6 1.24753110589199202D-03, 9.22878876572938311D-04, + 7 7.14430421727287357D-04, 5.71787281789704872D-04, + 8 4.69431007606481533D-04, 3.93232835462916638D-04, + 9 3.34818889318297664D-04, 2.88952148495751517D-04, + A 2.52211615549573284D-04, 2.22280580798883327D-04, + B 1.97541838033062524D-04, 1.76836855019718004D-04, + C 1.59316899661821081D-04, 1.44347930197333986D-04, + D 1.31448068119965379D-04, 1.20245444949302884D-04, + E 1.10449144504599392D-04, 1.01828770740567258D-04/ + DATA BETA(23), BETA(24), BETA(25), BETA(26), BETA(27), BETA(28), + 1 BETA(29), BETA(30), BETA(31), BETA(32), BETA(33), BETA(34), + 2 BETA(35), BETA(36), BETA(37), BETA(38), BETA(39), BETA(40), + 3 BETA(41), BETA(42), BETA(43), BETA(44)/ + 4 9.41998224204237509D-05, 8.74130545753834437D-05, + 5 8.13466262162801467D-05, 7.59002269646219339D-05, + 6 7.09906300634153481D-05, 6.65482874842468183D-05, + 7 6.25146958969275078D-05, 5.88403394426251749D-05, + 8 -1.49282953213429172D-03, -8.78204709546389328D-04, + 9 -5.02916549572034614D-04, -2.94822138512746025D-04, + A -1.75463996970782828D-04, -1.04008550460816434D-04, + B -5.96141953046457895D-05, -3.12038929076098340D-05, + C -1.26089735980230047D-05, -2.42892608575730389D-07, + D 8.05996165414273571D-06, 1.36507009262147391D-05, + E 1.73964125472926261D-05, 1.98672978842133780D-05/ + DATA BETA(45), BETA(46), BETA(47), BETA(48), BETA(49), BETA(50), + 1 BETA(51), BETA(52), BETA(53), BETA(54), BETA(55), BETA(56), + 2 BETA(57), BETA(58), BETA(59), BETA(60), BETA(61), BETA(62), + 3 BETA(63), BETA(64), BETA(65), BETA(66)/ + 4 2.14463263790822639D-05, 2.23954659232456514D-05, + 5 2.28967783814712629D-05, 2.30785389811177817D-05, + 6 2.30321976080909144D-05, 2.28236073720348722D-05, + 7 2.25005881105292418D-05, 2.20981015361991429D-05, + 8 2.16418427448103905D-05, 2.11507649256220843D-05, + 9 2.06388749782170737D-05, 2.01165241997081666D-05, + A 1.95913450141179244D-05, 1.90689367910436740D-05, + B 1.85533719641636667D-05, 1.80475722259674218D-05, + C 5.52213076721292790D-04, 4.47932581552384646D-04, + D 2.79520653992020589D-04, 1.52468156198446602D-04, + E 6.93271105657043598D-05, 1.76258683069991397D-05/ + DATA BETA(67), BETA(68), BETA(69), BETA(70), BETA(71), BETA(72), + 1 BETA(73), BETA(74), BETA(75), BETA(76), BETA(77), BETA(78), + 2 BETA(79), BETA(80), BETA(81), BETA(82), BETA(83), BETA(84), + 3 BETA(85), BETA(86), BETA(87), BETA(88)/ + 4 -1.35744996343269136D-05, -3.17972413350427135D-05, + 5 -4.18861861696693365D-05, -4.69004889379141029D-05, + 6 -4.87665447413787352D-05, -4.87010031186735069D-05, + 7 -4.74755620890086638D-05, -4.55813058138628452D-05, + 8 -4.33309644511266036D-05, -4.09230193157750364D-05, + 9 -3.84822638603221274D-05, -3.60857167535410501D-05, + A -3.37793306123367417D-05, -3.15888560772109621D-05, + B -2.95269561750807315D-05, -2.75978914828335759D-05, + C -2.58006174666883713D-05, -2.41308356761280200D-05, + D -2.25823509518346033D-05, -2.11479656768912971D-05, + E -1.98200638885294927D-05, -1.85909870801065077D-05/ + DATA BETA(89), BETA(90), BETA(91), BETA(92), BETA(93), BETA(94), + 1 BETA(95), BETA(96), BETA(97), BETA(98), BETA(99), BETA(100), + 2 BETA(101), BETA(102), BETA(103), BETA(104), BETA(105), + 3 BETA(106), BETA(107), BETA(108), BETA(109), BETA(110)/ + 4 -1.74532699844210224D-05, -1.63997823854497997D-05, + 5 -4.74617796559959808D-04, -4.77864567147321487D-04, + 6 -3.20390228067037603D-04, -1.61105016119962282D-04, + 7 -4.25778101285435204D-05, 3.44571294294967503D-05, + 8 7.97092684075674924D-05, 1.03138236708272200D-04, + 9 1.12466775262204158D-04, 1.13103642108481389D-04, + A 1.08651634848774268D-04, 1.01437951597661973D-04, + B 9.29298396593363896D-05, 8.40293133016089978D-05, + C 7.52727991349134062D-05, 6.69632521975730872D-05, + D 5.92564547323194704D-05, 5.22169308826975567D-05, + E 4.58539485165360646D-05, 4.01445513891486808D-05/ + DATA BETA(111), BETA(112), BETA(113), BETA(114), BETA(115), + 1 BETA(116), BETA(117), BETA(118), BETA(119), BETA(120), + 2 BETA(121), BETA(122), BETA(123), BETA(124), BETA(125), + 3 BETA(126), BETA(127), BETA(128), BETA(129), BETA(130)/ + 4 3.50481730031328081D-05, 3.05157995034346659D-05, + 5 2.64956119950516039D-05, 2.29363633690998152D-05, + 6 1.97893056664021636D-05, 1.70091984636412623D-05, + 7 1.45547428261524004D-05, 1.23886640995878413D-05, + 8 1.04775876076583236D-05, 8.79179954978479373D-06, + 9 7.36465810572578444D-04, 8.72790805146193976D-04, + A 6.22614862573135066D-04, 2.85998154194304147D-04, + B 3.84737672879366102D-06, -1.87906003636971558D-04, + C -2.97603646594554535D-04, -3.45998126832656348D-04, + D -3.53382470916037712D-04, -3.35715635775048757D-04/ + DATA BETA(131), BETA(132), BETA(133), BETA(134), BETA(135), + 1 BETA(136), BETA(137), BETA(138), BETA(139), BETA(140), + 2 BETA(141), BETA(142), BETA(143), BETA(144), BETA(145), + 3 BETA(146), BETA(147), BETA(148), BETA(149), BETA(150)/ + 4 -3.04321124789039809D-04, -2.66722723047612821D-04, + 5 -2.27654214122819527D-04, -1.89922611854562356D-04, + 6 -1.55058918599093870D-04, -1.23778240761873630D-04, + 7 -9.62926147717644187D-05, -7.25178327714425337D-05, + 8 -5.22070028895633801D-05, -3.50347750511900522D-05, + 9 -2.06489761035551757D-05, -8.70106096849767054D-06, + A 1.13698686675100290D-06, 9.16426474122778849D-06, + B 1.56477785428872620D-05, 2.08223629482466847D-05, + C 2.48923381004595156D-05, 2.80340509574146325D-05, + D 3.03987774629861915D-05, 3.21156731406700616D-05/ + DATA BETA(151), BETA(152), BETA(153), BETA(154), BETA(155), + 1 BETA(156), BETA(157), BETA(158), BETA(159), BETA(160), + 2 BETA(161), BETA(162), BETA(163), BETA(164), BETA(165), + 3 BETA(166), BETA(167), BETA(168), BETA(169), BETA(170)/ + 4 -1.80182191963885708D-03, -2.43402962938042533D-03, + 5 -1.83422663549856802D-03, -7.62204596354009765D-04, + 6 2.39079475256927218D-04, 9.49266117176881141D-04, + 7 1.34467449701540359D-03, 1.48457495259449178D-03, + 8 1.44732339830617591D-03, 1.30268261285657186D-03, + 9 1.10351597375642682D-03, 8.86047440419791759D-04, + A 6.73073208165665473D-04, 4.77603872856582378D-04, + B 3.05991926358789362D-04, 1.60315694594721630D-04, + C 4.00749555270613286D-05, -5.66607461635251611D-05, + D -1.32506186772982638D-04, -1.90296187989614057D-04/ + DATA BETA(171), BETA(172), BETA(173), BETA(174), BETA(175), + 1 BETA(176), BETA(177), BETA(178), BETA(179), BETA(180), + 2 BETA(181), BETA(182), BETA(183), BETA(184), BETA(185), + 3 BETA(186), BETA(187), BETA(188), BETA(189), BETA(190)/ + 4 -2.32811450376937408D-04, -2.62628811464668841D-04, + 5 -2.82050469867598672D-04, -2.93081563192861167D-04, + 6 -2.97435962176316616D-04, -2.96557334239348078D-04, + 7 -2.91647363312090861D-04, -2.83696203837734166D-04, + 8 -2.73512317095673346D-04, -2.61750155806768580D-04, + 9 6.38585891212050914D-03, 9.62374215806377941D-03, + A 7.61878061207001043D-03, 2.83219055545628054D-03, + B -2.09841352012720090D-03, -5.73826764216626498D-03, + C -7.70804244495414620D-03, -8.21011692264844401D-03, + D -7.65824520346905413D-03, -6.47209729391045177D-03/ + DATA BETA(191), BETA(192), BETA(193), BETA(194), BETA(195), + 1 BETA(196), BETA(197), BETA(198), BETA(199), BETA(200), + 2 BETA(201), BETA(202), BETA(203), BETA(204), BETA(205), + 3 BETA(206), BETA(207), BETA(208), BETA(209), BETA(210)/ + 4 -4.99132412004966473D-03, -3.45612289713133280D-03, + 5 -2.01785580014170775D-03, -7.59430686781961401D-04, + 6 2.84173631523859138D-04, 1.10891667586337403D-03, + 7 1.72901493872728771D-03, 2.16812590802684701D-03, + 8 2.45357710494539735D-03, 2.61281821058334862D-03, + 9 2.67141039656276912D-03, 2.65203073395980430D-03, + A 2.57411652877287315D-03, 2.45389126236094427D-03, + B 2.30460058071795494D-03, 2.13684837686712662D-03, + C 1.95896528478870911D-03, 1.77737008679454412D-03, + D 1.59690280765839059D-03, 1.42111975664438546D-03/ + DATA GAMA(1), GAMA(2), GAMA(3), GAMA(4), GAMA(5), GAMA(6), + 1 GAMA(7), GAMA(8), GAMA(9), GAMA(10), GAMA(11), GAMA(12), + 2 GAMA(13), GAMA(14), GAMA(15), GAMA(16), GAMA(17), GAMA(18), + 3 GAMA(19), GAMA(20), GAMA(21), GAMA(22)/ + 4 6.29960524947436582D-01, 2.51984209978974633D-01, + 5 1.54790300415655846D-01, 1.10713062416159013D-01, + 6 8.57309395527394825D-02, 6.97161316958684292D-02, + 7 5.86085671893713576D-02, 5.04698873536310685D-02, + 8 4.42600580689154809D-02, 3.93720661543509966D-02, + 9 3.54283195924455368D-02, 3.21818857502098231D-02, + A 2.94646240791157679D-02, 2.71581677112934479D-02, + B 2.51768272973861779D-02, 2.34570755306078891D-02, + C 2.19508390134907203D-02, 2.06210828235646240D-02, + D 1.94388240897880846D-02, 1.83810633800683158D-02, + E 1.74293213231963172D-02, 1.65685837786612353D-02/ + DATA GAMA(23), GAMA(24), GAMA(25), GAMA(26), GAMA(27), GAMA(28), + 1 GAMA(29), GAMA(30)/ + 2 1.57865285987918445D-02, 1.50729501494095594D-02, + 3 1.44193250839954639D-02, 1.38184805735341786D-02, + 4 1.32643378994276568D-02, 1.27517121970498651D-02, + 5 1.22761545318762767D-02, 1.18338262398482403D-02/ + DATA EX1, EX2, HPI, GPI, THPI / + 1 3.33333333333333333D-01, 6.66666666666666667D-01, + 2 1.57079632679489662D+00, 3.14159265358979324D+00, + 3 4.71238898038468986D+00/ + DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / +C***FIRST EXECUTABLE STATEMENT ZUNHJ + RFNU = 1.0D0/FNU +C----------------------------------------------------------------------- +C OVERFLOW TEST (Z/FNU TOO SMALL) +C----------------------------------------------------------------------- + TEST = D1MACH(1)*1.0D+3 + AC = FNU*TEST + IF (ABS(ZR).GT.AC .OR. ABS(ZI).GT.AC) GO TO 15 + ZETA1R = 2.0D0*ABS(LOG(TEST))+FNU + ZETA1I = 0.0D0 + ZETA2R = FNU + ZETA2I = 0.0D0 + PHIR = 1.0D0 + PHII = 0.0D0 + ARGR = 1.0D0 + ARGI = 0.0D0 + RETURN + 15 CONTINUE + ZBR = ZR*RFNU + ZBI = ZI*RFNU + RFNU2 = RFNU*RFNU +C----------------------------------------------------------------------- +C COMPUTE IN THE FOURTH QUADRANT +C----------------------------------------------------------------------- + FN13 = FNU**EX1 + FN23 = FN13*FN13 + RFN13 = 1.0D0/FN13 + W2R = CONER - ZBR*ZBR + ZBI*ZBI + W2I = CONEI - ZBR*ZBI - ZBR*ZBI + AW2 = ZABS(W2R,W2I) + IF (AW2.GT.0.25D0) GO TO 130 +C----------------------------------------------------------------------- +C POWER SERIES FOR ABS(W2).LE.0.25D0 +C----------------------------------------------------------------------- + K = 1 + PR(1) = CONER + PI(1) = CONEI + SUMAR = GAMA(1) + SUMAI = ZEROI + AP(1) = 1.0D0 + IF (AW2.LT.TOL) GO TO 20 + DO 10 K=2,30 + PR(K) = PR(K-1)*W2R - PI(K-1)*W2I + PI(K) = PR(K-1)*W2I + PI(K-1)*W2R + SUMAR = SUMAR + PR(K)*GAMA(K) + SUMAI = SUMAI + PI(K)*GAMA(K) + AP(K) = AP(K-1)*AW2 + IF (AP(K).LT.TOL) GO TO 20 + 10 CONTINUE + K = 30 + 20 CONTINUE + KMAX = K + ZETAR = W2R*SUMAR - W2I*SUMAI + ZETAI = W2R*SUMAI + W2I*SUMAR + ARGR = ZETAR*FN23 + ARGI = ZETAI*FN23 + CALL ZSQRT(SUMAR, SUMAI, ZAR, ZAI) + CALL ZSQRT(W2R, W2I, STR, STI) + ZETA2R = STR*FNU + ZETA2I = STI*FNU + STR = CONER + EX2*(ZETAR*ZAR-ZETAI*ZAI) + STI = CONEI + EX2*(ZETAR*ZAI+ZETAI*ZAR) + ZETA1R = STR*ZETA2R - STI*ZETA2I + ZETA1I = STR*ZETA2I + STI*ZETA2R + ZAR = ZAR + ZAR + ZAI = ZAI + ZAI + CALL ZSQRT(ZAR, ZAI, STR, STI) + PHIR = STR*RFN13 + PHII = STI*RFN13 + IF (IPMTR.EQ.1) GO TO 120 +C----------------------------------------------------------------------- +C SUM SERIES FOR ASUM AND BSUM +C----------------------------------------------------------------------- + SUMBR = ZEROR + SUMBI = ZEROI + DO 30 K=1,KMAX + SUMBR = SUMBR + PR(K)*BETA(K) + SUMBI = SUMBI + PI(K)*BETA(K) + 30 CONTINUE + ASUMR = ZEROR + ASUMI = ZEROI + BSUMR = SUMBR + BSUMI = SUMBI + L1 = 0 + L2 = 30 + BTOL = TOL*(ABS(BSUMR)+ABS(BSUMI)) + ATOL = TOL + PP = 1.0D0 + IAS = 0 + IBS = 0 + IF (RFNU2.LT.TOL) GO TO 110 + DO 100 IS=2,7 + ATOL = ATOL/RFNU2 + PP = PP*RFNU2 + IF (IAS.EQ.1) GO TO 60 + SUMAR = ZEROR + SUMAI = ZEROI + DO 40 K=1,KMAX + M = L1 + K + SUMAR = SUMAR + PR(K)*ALFA(M) + SUMAI = SUMAI + PI(K)*ALFA(M) + IF (AP(K).LT.ATOL) GO TO 50 + 40 CONTINUE + 50 CONTINUE + ASUMR = ASUMR + SUMAR*PP + ASUMI = ASUMI + SUMAI*PP + IF (PP.LT.TOL) IAS = 1 + 60 CONTINUE + IF (IBS.EQ.1) GO TO 90 + SUMBR = ZEROR + SUMBI = ZEROI + DO 70 K=1,KMAX + M = L2 + K + SUMBR = SUMBR + PR(K)*BETA(M) + SUMBI = SUMBI + PI(K)*BETA(M) + IF (AP(K).LT.ATOL) GO TO 80 + 70 CONTINUE + 80 CONTINUE + BSUMR = BSUMR + SUMBR*PP + BSUMI = BSUMI + SUMBI*PP + IF (PP.LT.BTOL) IBS = 1 + 90 CONTINUE + IF (IAS.EQ.1 .AND. IBS.EQ.1) GO TO 110 + L1 = L1 + 30 + L2 = L2 + 30 + 100 CONTINUE + 110 CONTINUE + ASUMR = ASUMR + CONER + PP = RFNU*RFN13 + BSUMR = BSUMR*PP + BSUMI = BSUMI*PP + 120 CONTINUE + RETURN +C----------------------------------------------------------------------- +C ABS(W2).GT.0.25D0 +C----------------------------------------------------------------------- + 130 CONTINUE + CALL ZSQRT(W2R, W2I, WR, WI) + IF (WR.LT.0.0D0) WR = 0.0D0 + IF (WI.LT.0.0D0) WI = 0.0D0 + STR = CONER + WR + STI = WI + CALL ZDIV(STR, STI, ZBR, ZBI, ZAR, ZAI) + CALL ZLOG(ZAR, ZAI, ZCR, ZCI, IDUM) + IF (ZCI.LT.0.0D0) ZCI = 0.0D0 + IF (ZCI.GT.HPI) ZCI = HPI + IF (ZCR.LT.0.0D0) ZCR = 0.0D0 + ZTHR = (ZCR-WR)*1.5D0 + ZTHI = (ZCI-WI)*1.5D0 + ZETA1R = ZCR*FNU + ZETA1I = ZCI*FNU + ZETA2R = WR*FNU + ZETA2I = WI*FNU + AZTH = ZABS(ZTHR,ZTHI) + ANG = THPI + IF (ZTHR.GE.0.0D0 .AND. ZTHI.LT.0.0D0) GO TO 140 + ANG = HPI + IF (ZTHR.EQ.0.0D0) GO TO 140 + ANG = DATAN(ZTHI/ZTHR) + IF (ZTHR.LT.0.0D0) ANG = ANG + GPI + 140 CONTINUE + PP = AZTH**EX2 + ANG = ANG*EX2 + ZETAR = PP*COS(ANG) + ZETAI = PP*SIN(ANG) + IF (ZETAI.LT.0.0D0) ZETAI = 0.0D0 + ARGR = ZETAR*FN23 + ARGI = ZETAI*FN23 + CALL ZDIV(ZTHR, ZTHI, ZETAR, ZETAI, RTZTR, RTZTI) + CALL ZDIV(RTZTR, RTZTI, WR, WI, ZAR, ZAI) + TZAR = ZAR + ZAR + TZAI = ZAI + ZAI + CALL ZSQRT(TZAR, TZAI, STR, STI) + PHIR = STR*RFN13 + PHII = STI*RFN13 + IF (IPMTR.EQ.1) GO TO 120 + RAW = 1.0D0/SQRT(AW2) + STR = WR*RAW + STI = -WI*RAW + TFNR = STR*RFNU*RAW + TFNI = STI*RFNU*RAW + RAZTH = 1.0D0/AZTH + STR = ZTHR*RAZTH + STI = -ZTHI*RAZTH + RZTHR = STR*RAZTH*RFNU + RZTHI = STI*RAZTH*RFNU + ZCR = RZTHR*AR(2) + ZCI = RZTHI*AR(2) + RAW2 = 1.0D0/AW2 + STR = W2R*RAW2 + STI = -W2I*RAW2 + T2R = STR*RAW2 + T2I = STI*RAW2 + STR = T2R*C(2) + C(3) + STI = T2I*C(2) + UPR(2) = STR*TFNR - STI*TFNI + UPI(2) = STR*TFNI + STI*TFNR + BSUMR = UPR(2) + ZCR + BSUMI = UPI(2) + ZCI + ASUMR = ZEROR + ASUMI = ZEROI + IF (RFNU.LT.TOL) GO TO 220 + PRZTHR = RZTHR + PRZTHI = RZTHI + PTFNR = TFNR + PTFNI = TFNI + UPR(1) = CONER + UPI(1) = CONEI + PP = 1.0D0 + BTOL = TOL*(ABS(BSUMR)+ABS(BSUMI)) + KS = 0 + KP1 = 2 + L = 3 + IAS = 0 + IBS = 0 + DO 210 LR=2,12,2 + LRP1 = LR + 1 +C----------------------------------------------------------------------- +C COMPUTE TWO ADDITIONAL CR, DR, AND UP FOR TWO MORE TERMS IN +C NEXT SUMA AND SUMB +C----------------------------------------------------------------------- + DO 160 K=LR,LRP1 + KS = KS + 1 + KP1 = KP1 + 1 + L = L + 1 + ZAR = C(L) + ZAI = ZEROI + DO 150 J=2,KP1 + L = L + 1 + STR = ZAR*T2R - T2I*ZAI + C(L) + ZAI = ZAR*T2I + ZAI*T2R + ZAR = STR + 150 CONTINUE + STR = PTFNR*TFNR - PTFNI*TFNI + PTFNI = PTFNR*TFNI + PTFNI*TFNR + PTFNR = STR + UPR(KP1) = PTFNR*ZAR - PTFNI*ZAI + UPI(KP1) = PTFNI*ZAR + PTFNR*ZAI + CRR(KS) = PRZTHR*BR(KS+1) + CRI(KS) = PRZTHI*BR(KS+1) + STR = PRZTHR*RZTHR - PRZTHI*RZTHI + PRZTHI = PRZTHR*RZTHI + PRZTHI*RZTHR + PRZTHR = STR + DRR(KS) = PRZTHR*AR(KS+2) + DRI(KS) = PRZTHI*AR(KS+2) + 160 CONTINUE + PP = PP*RFNU2 + IF (IAS.EQ.1) GO TO 180 + SUMAR = UPR(LRP1) + SUMAI = UPI(LRP1) + JU = LRP1 + DO 170 JR=1,LR + JU = JU - 1 + SUMAR = SUMAR + CRR(JR)*UPR(JU) - CRI(JR)*UPI(JU) + SUMAI = SUMAI + CRR(JR)*UPI(JU) + CRI(JR)*UPR(JU) + 170 CONTINUE + ASUMR = ASUMR + SUMAR + ASUMI = ASUMI + SUMAI + TEST = ABS(SUMAR) + ABS(SUMAI) + IF (PP.LT.TOL .AND. TEST.LT.TOL) IAS = 1 + 180 CONTINUE + IF (IBS.EQ.1) GO TO 200 + SUMBR = UPR(LR+2) + UPR(LRP1)*ZCR - UPI(LRP1)*ZCI + SUMBI = UPI(LR+2) + UPR(LRP1)*ZCI + UPI(LRP1)*ZCR + JU = LRP1 + DO 190 JR=1,LR + JU = JU - 1 + SUMBR = SUMBR + DRR(JR)*UPR(JU) - DRI(JR)*UPI(JU) + SUMBI = SUMBI + DRR(JR)*UPI(JU) + DRI(JR)*UPR(JU) + 190 CONTINUE + BSUMR = BSUMR + SUMBR + BSUMI = BSUMI + SUMBI + TEST = ABS(SUMBR) + ABS(SUMBI) + IF (PP.LT.BTOL .AND. TEST.LT.BTOL) IBS = 1 + 200 CONTINUE + IF (IAS.EQ.1 .AND. IBS.EQ.1) GO TO 220 + 210 CONTINUE + 220 CONTINUE + ASUMR = ASUMR + CONER + STR = -BSUMR*RFN13 + STI = -BSUMI*RFN13 + CALL ZDIV(STR, STI, RTZTR, RTZTI, BSUMR, BSUMI) + GO TO 120 + END diff --git a/modules/elementary_functions/src/fortran/slatec/zunhj.lo b/modules/elementary_functions/src/fortran/slatec/zunhj.lo new file mode 100755 index 000000000..b4d4e6f70 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zunhj.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zunhj.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zunhj.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zuni1.f b/modules/elementary_functions/src/fortran/slatec/zuni1.f new file mode 100755 index 000000000..eb309afa2 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zuni1.f @@ -0,0 +1,215 @@ +*DECK ZUNI1 + SUBROUTINE ZUNI1 (ZR, ZI, FNU, KODE, N, YR, YI, NZ, NLAST, FNUL, + + TOL, ELIM, ALIM) +C***BEGIN PROLOGUE ZUNI1 +C***SUBSIDIARY +C***PURPOSE Subsidiary to ZBESI and ZBESK +C***LIBRARY SLATEC +C***TYPE ALL (CUNI1-A, ZUNI1-A) +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C ZUNI1 COMPUTES I(FNU,Z) BY MEANS OF THE UNIFORM ASYMPTOTIC +C EXPANSION FOR I(FNU,Z) IN -PI/3.LE.ARG Z.LE.PI/3. +C +C FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC +C EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET. +C NLAST.NE.0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER +C FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1.LT.FNUL. +C Y(I)=CZERO FOR I=NLAST+1,N +C +C***SEE ALSO ZBESI, ZBESK +C***ROUTINES CALLED D1MACH, ZABS, ZUCHK, ZUNIK, ZUOIK +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 910415 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE ZUNI1 +C COMPLEX CFN,CONE,CRSC,CSCL,CSR,CSS,CWRK,CZERO,C1,C2,PHI,RZ,SUM,S1, +C *S2,Y,Z,ZETA1,ZETA2 + DOUBLE PRECISION ALIM, APHI, ASCLE, BRY, CONER, CRSC, + * CSCL, CSRR, CSSR, CWRKI, CWRKR, C1R, C2I, C2M, C2R, ELIM, FN, + * FNU, FNUL, PHII, PHIR, RAST, RS1, RZI, RZR, STI, STR, SUMI, + * SUMR, S1I, S1R, S2I, S2R, TOL, YI, YR, ZEROI, ZEROR, ZETA1I, + * ZETA1R, ZETA2I, ZETA2R, ZI, ZR, CYR, CYI, D1MACH, ZABS + INTEGER I, IFLAG, INIT, K, KODE, M, N, ND, NLAST, NN, NUF, NW, NZ + DIMENSION BRY(3), YR(N), YI(N), CWRKR(16), CWRKI(16), CSSR(3), + * CSRR(3), CYR(2), CYI(2) + EXTERNAL ZABS + DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 / +C***FIRST EXECUTABLE STATEMENT ZUNI1 + NZ = 0 + ND = N + NLAST = 0 +C----------------------------------------------------------------------- +C COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG- +C NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE, +C EXP(ALIM)=EXP(ELIM)*TOL +C----------------------------------------------------------------------- + CSCL = 1.0D0/TOL + CRSC = TOL + CSSR(1) = CSCL + CSSR(2) = CONER + CSSR(3) = CRSC + CSRR(1) = CRSC + CSRR(2) = CONER + CSRR(3) = CSCL + BRY(1) = 1.0D+3*D1MACH(1)/TOL +C----------------------------------------------------------------------- +C CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER +C----------------------------------------------------------------------- + FN = MAX(FNU,1.0D0) + INIT = 0 + CALL ZUNIK(ZR, ZI, FN, 1, 1, TOL, INIT, PHIR, PHII, ZETA1R, + * ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) + IF (KODE.EQ.1) GO TO 10 + STR = ZR + ZETA2R + STI = ZI + ZETA2I + RAST = FN/ZABS(STR,STI) + STR = STR*RAST*RAST + STI = -STI*RAST*RAST + S1R = -ZETA1R + STR + S1I = -ZETA1I + STI + GO TO 20 + 10 CONTINUE + S1R = -ZETA1R + ZETA2R + S1I = -ZETA1I + ZETA2I + 20 CONTINUE + RS1 = S1R + IF (ABS(RS1).GT.ELIM) GO TO 130 + 30 CONTINUE + NN = MIN(2,ND) + DO 80 I=1,NN + FN = FNU + (ND-I) + INIT = 0 + CALL ZUNIK(ZR, ZI, FN, 1, 0, TOL, INIT, PHIR, PHII, ZETA1R, + * ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) + IF (KODE.EQ.1) GO TO 40 + STR = ZR + ZETA2R + STI = ZI + ZETA2I + RAST = FN/ZABS(STR,STI) + STR = STR*RAST*RAST + STI = -STI*RAST*RAST + S1R = -ZETA1R + STR + S1I = -ZETA1I + STI + ZI + GO TO 50 + 40 CONTINUE + S1R = -ZETA1R + ZETA2R + S1I = -ZETA1I + ZETA2I + 50 CONTINUE +C----------------------------------------------------------------------- +C TEST FOR UNDERFLOW AND OVERFLOW +C----------------------------------------------------------------------- + RS1 = S1R + IF (ABS(RS1).GT.ELIM) GO TO 110 + IF (I.EQ.1) IFLAG = 2 + IF (ABS(RS1).LT.ALIM) GO TO 60 +C----------------------------------------------------------------------- +C REFINE TEST AND SCALE +C----------------------------------------------------------------------- + APHI = ZABS(PHIR,PHII) + RS1 = RS1 + LOG(APHI) + IF (ABS(RS1).GT.ELIM) GO TO 110 + IF (I.EQ.1) IFLAG = 1 + IF (RS1.LT.0.0D0) GO TO 60 + IF (I.EQ.1) IFLAG = 3 + 60 CONTINUE +C----------------------------------------------------------------------- +C SCALE S1 IF ABS(S1).LT.ASCLE +C----------------------------------------------------------------------- + S2R = PHIR*SUMR - PHII*SUMI + S2I = PHIR*SUMI + PHII*SUMR + STR = EXP(S1R)*CSSR(IFLAG) + S1R = STR*COS(S1I) + S1I = STR*SIN(S1I) + STR = S2R*S1R - S2I*S1I + S2I = S2R*S1I + S2I*S1R + S2R = STR + IF (IFLAG.NE.1) GO TO 70 + CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) + IF (NW.NE.0) GO TO 110 + 70 CONTINUE + CYR(I) = S2R + CYI(I) = S2I + M = ND - I + 1 + YR(M) = S2R*CSRR(IFLAG) + YI(M) = S2I*CSRR(IFLAG) + 80 CONTINUE + IF (ND.LE.2) GO TO 100 + RAST = 1.0D0/ZABS(ZR,ZI) + STR = ZR*RAST + STI = -ZI*RAST + RZR = (STR+STR)*RAST + RZI = (STI+STI)*RAST + BRY(2) = 1.0D0/BRY(1) + BRY(3) = D1MACH(2) + S1R = CYR(1) + S1I = CYI(1) + S2R = CYR(2) + S2I = CYI(2) + C1R = CSRR(IFLAG) + ASCLE = BRY(IFLAG) + K = ND - 2 + FN = K + DO 90 I=3,ND + C2R = S2R + C2I = S2I + S2R = S1R + (FNU+FN)*(RZR*C2R-RZI*C2I) + S2I = S1I + (FNU+FN)*(RZR*C2I+RZI*C2R) + S1R = C2R + S1I = C2I + C2R = S2R*C1R + C2I = S2I*C1R + YR(K) = C2R + YI(K) = C2I + K = K - 1 + FN = FN - 1.0D0 + IF (IFLAG.GE.3) GO TO 90 + STR = ABS(C2R) + STI = ABS(C2I) + C2M = MAX(STR,STI) + IF (C2M.LE.ASCLE) GO TO 90 + IFLAG = IFLAG + 1 + ASCLE = BRY(IFLAG) + S1R = S1R*C1R + S1I = S1I*C1R + S2R = C2R + S2I = C2I + S1R = S1R*CSSR(IFLAG) + S1I = S1I*CSSR(IFLAG) + S2R = S2R*CSSR(IFLAG) + S2I = S2I*CSSR(IFLAG) + C1R = CSRR(IFLAG) + 90 CONTINUE + 100 CONTINUE + RETURN +C----------------------------------------------------------------------- +C SET UNDERFLOW AND UPDATE PARAMETERS +C----------------------------------------------------------------------- + 110 CONTINUE + IF (RS1.GT.0.0D0) GO TO 120 + YR(ND) = ZEROR + YI(ND) = ZEROI + NZ = NZ + 1 + ND = ND - 1 + IF (ND.EQ.0) GO TO 100 + CALL ZUOIK(ZR, ZI, FNU, KODE, 1, ND, YR, YI, NUF, TOL, ELIM, ALIM) + IF (NUF.LT.0) GO TO 120 + ND = ND - NUF + NZ = NZ + NUF + IF (ND.EQ.0) GO TO 100 + FN = FNU + (ND-1) + IF (FN.GE.FNUL) GO TO 30 + NLAST = ND + RETURN + 120 CONTINUE + NZ = -1 + RETURN + 130 CONTINUE + IF (RS1.GT.0.0D0) GO TO 120 + NZ = N + DO 140 I=1,N + YR(I) = ZEROR + YI(I) = ZEROI + 140 CONTINUE + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zuni1.lo b/modules/elementary_functions/src/fortran/slatec/zuni1.lo new file mode 100755 index 000000000..09cae7fee --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zuni1.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zuni1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zuni1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zuni2.f b/modules/elementary_functions/src/fortran/slatec/zuni2.f new file mode 100755 index 000000000..35ff301c9 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zuni2.f @@ -0,0 +1,278 @@ +*DECK ZUNI2 + SUBROUTINE ZUNI2 (ZR, ZI, FNU, KODE, N, YR, YI, NZ, NLAST, FNUL, + + TOL, ELIM, ALIM) +C***BEGIN PROLOGUE ZUNI2 +C***SUBSIDIARY +C***PURPOSE Subsidiary to ZBESI and ZBESK +C***LIBRARY SLATEC +C***TYPE ALL (CUNI2-A, ZUNI2-A) +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C ZUNI2 COMPUTES I(FNU,Z) IN THE RIGHT HALF PLANE BY MEANS OF +C UNIFORM ASYMPTOTIC EXPANSION FOR J(FNU,ZN) WHERE ZN IS Z*I +C OR -Z*I AND ZN IS IN THE RIGHT HALF PLANE ALSO. +C +C FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC +C EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET. +C NLAST.NE.0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER +C FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1.LT.FNUL. +C Y(I)=CZERO FOR I=NLAST+1,N +C +C***SEE ALSO ZBESI, ZBESK +C***ROUTINES CALLED D1MACH, ZABS, ZAIRY, ZUCHK, ZUNHJ, ZUOIK +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 910415 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE ZUNI2 +C COMPLEX AI,ARG,ASUM,BSUM,CFN,CI,CID,CIP,CONE,CRSC,CSCL,CSR,CSS, +C *CZERO,C1,C2,DAI,PHI,RZ,S1,S2,Y,Z,ZB,ZETA1,ZETA2,ZN + DOUBLE PRECISION AARG, AIC, AII, AIR, ALIM, ANG, APHI, ARGI, + * ARGR, ASCLE, ASUMI, ASUMR, BRY, BSUMI, BSUMR, CIDI, CIPI, CIPR, + * CONER, CRSC, CSCL, CSRR, CSSR, C1R, C2I, C2M, C2R, DAII, + * DAIR, ELIM, FN, FNU, FNUL, HPI, PHII, PHIR, RAST, RAZ, RS1, RZI, + * RZR, STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, ZBI, ZBR, ZEROI, + * ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZI, ZNI, ZNR, ZR, CYR, + * CYI, D1MACH, ZABS, CAR, SAR + INTEGER I, IFLAG, IN, INU, J, K, KODE, N, NAI, ND, NDAI, NLAST, + * NN, NUF, NW, NZ, IDUM + DIMENSION BRY(3), YR(N), YI(N), CIPR(4), CIPI(4), CSSR(3), + * CSRR(3), CYR(2), CYI(2) + EXTERNAL ZABS + DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 / + DATA CIPR(1),CIPI(1),CIPR(2),CIPI(2),CIPR(3),CIPI(3),CIPR(4), + * CIPI(4)/ 1.0D0,0.0D0, 0.0D0,1.0D0, -1.0D0,0.0D0, 0.0D0,-1.0D0/ + DATA HPI, AIC / + 1 1.57079632679489662D+00, 1.265512123484645396D+00/ +C***FIRST EXECUTABLE STATEMENT ZUNI2 + NZ = 0 + ND = N + NLAST = 0 +C----------------------------------------------------------------------- +C COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG- +C NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE, +C EXP(ALIM)=EXP(ELIM)*TOL +C----------------------------------------------------------------------- + CSCL = 1.0D0/TOL + CRSC = TOL + CSSR(1) = CSCL + CSSR(2) = CONER + CSSR(3) = CRSC + CSRR(1) = CRSC + CSRR(2) = CONER + CSRR(3) = CSCL + BRY(1) = 1.0D+3*D1MACH(1)/TOL +C----------------------------------------------------------------------- +C ZN IS IN THE RIGHT HALF PLANE AFTER ROTATION BY CI OR -CI +C----------------------------------------------------------------------- + ZNR = ZI + ZNI = -ZR + ZBR = ZR + ZBI = ZI + CIDI = -CONER + INU = FNU + ANG = HPI*(FNU-INU) + C2R = COS(ANG) + C2I = SIN(ANG) + CAR = C2R + SAR = C2I + IN = INU + N - 1 + IN = MOD(IN,4) + 1 + STR = C2R*CIPR(IN) - C2I*CIPI(IN) + C2I = C2R*CIPI(IN) + C2I*CIPR(IN) + C2R = STR + IF (ZI.GT.0.0D0) GO TO 10 + ZNR = -ZNR + ZBI = -ZBI + CIDI = -CIDI + C2I = -C2I + 10 CONTINUE +C----------------------------------------------------------------------- +C CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER +C----------------------------------------------------------------------- + FN = MAX(FNU,1.0D0) + CALL ZUNHJ(ZNR, ZNI, FN, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R, + * ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) + IF (KODE.EQ.1) GO TO 20 + STR = ZBR + ZETA2R + STI = ZBI + ZETA2I + RAST = FN/ZABS(STR,STI) + STR = STR*RAST*RAST + STI = -STI*RAST*RAST + S1R = -ZETA1R + STR + S1I = -ZETA1I + STI + GO TO 30 + 20 CONTINUE + S1R = -ZETA1R + ZETA2R + S1I = -ZETA1I + ZETA2I + 30 CONTINUE + RS1 = S1R + IF (ABS(RS1).GT.ELIM) GO TO 150 + 40 CONTINUE + NN = MIN(2,ND) + DO 90 I=1,NN + FN = FNU + (ND-I) + CALL ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIR, PHII, ARGR, ARGI, + * ZETA1R, ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) + IF (KODE.EQ.1) GO TO 50 + STR = ZBR + ZETA2R + STI = ZBI + ZETA2I + RAST = FN/ZABS(STR,STI) + STR = STR*RAST*RAST + STI = -STI*RAST*RAST + S1R = -ZETA1R + STR + S1I = -ZETA1I + STI + ABS(ZI) + GO TO 60 + 50 CONTINUE + S1R = -ZETA1R + ZETA2R + S1I = -ZETA1I + ZETA2I + 60 CONTINUE +C----------------------------------------------------------------------- +C TEST FOR UNDERFLOW AND OVERFLOW +C----------------------------------------------------------------------- + RS1 = S1R + IF (ABS(RS1).GT.ELIM) GO TO 120 + IF (I.EQ.1) IFLAG = 2 + IF (ABS(RS1).LT.ALIM) GO TO 70 +C----------------------------------------------------------------------- +C REFINE TEST AND SCALE +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + APHI = ZABS(PHIR,PHII) + AARG = ZABS(ARGR,ARGI) + RS1 = RS1 + LOG(APHI) - 0.25D0*LOG(AARG) - AIC + IF (ABS(RS1).GT.ELIM) GO TO 120 + IF (I.EQ.1) IFLAG = 1 + IF (RS1.LT.0.0D0) GO TO 70 + IF (I.EQ.1) IFLAG = 3 + 70 CONTINUE +C----------------------------------------------------------------------- +C SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR +C EXPONENT EXTREMES +C----------------------------------------------------------------------- + CALL ZAIRY(ARGR, ARGI, 0, 2, AIR, AII, NAI, IDUM) + CALL ZAIRY(ARGR, ARGI, 1, 2, DAIR, DAII, NDAI, IDUM) + STR = DAIR*BSUMR - DAII*BSUMI + STI = DAIR*BSUMI + DAII*BSUMR + STR = STR + (AIR*ASUMR-AII*ASUMI) + STI = STI + (AIR*ASUMI+AII*ASUMR) + S2R = PHIR*STR - PHII*STI + S2I = PHIR*STI + PHII*STR + STR = EXP(S1R)*CSSR(IFLAG) + S1R = STR*COS(S1I) + S1I = STR*SIN(S1I) + STR = S2R*S1R - S2I*S1I + S2I = S2R*S1I + S2I*S1R + S2R = STR + IF (IFLAG.NE.1) GO TO 80 + CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) + IF (NW.NE.0) GO TO 120 + 80 CONTINUE + IF (ZI.LE.0.0D0) S2I = -S2I + STR = S2R*C2R - S2I*C2I + S2I = S2R*C2I + S2I*C2R + S2R = STR + CYR(I) = S2R + CYI(I) = S2I + J = ND - I + 1 + YR(J) = S2R*CSRR(IFLAG) + YI(J) = S2I*CSRR(IFLAG) + STR = -C2I*CIDI + C2I = C2R*CIDI + C2R = STR + 90 CONTINUE + IF (ND.LE.2) GO TO 110 + RAZ = 1.0D0/ZABS(ZR,ZI) + STR = ZR*RAZ + STI = -ZI*RAZ + RZR = (STR+STR)*RAZ + RZI = (STI+STI)*RAZ + BRY(2) = 1.0D0/BRY(1) + BRY(3) = D1MACH(2) + S1R = CYR(1) + S1I = CYI(1) + S2R = CYR(2) + S2I = CYI(2) + C1R = CSRR(IFLAG) + ASCLE = BRY(IFLAG) + K = ND - 2 + FN = K + DO 100 I=3,ND + C2R = S2R + C2I = S2I + S2R = S1R + (FNU+FN)*(RZR*C2R-RZI*C2I) + S2I = S1I + (FNU+FN)*(RZR*C2I+RZI*C2R) + S1R = C2R + S1I = C2I + C2R = S2R*C1R + C2I = S2I*C1R + YR(K) = C2R + YI(K) = C2I + K = K - 1 + FN = FN - 1.0D0 + IF (IFLAG.GE.3) GO TO 100 + STR = ABS(C2R) + STI = ABS(C2I) + C2M = MAX(STR,STI) + IF (C2M.LE.ASCLE) GO TO 100 + IFLAG = IFLAG + 1 + ASCLE = BRY(IFLAG) + S1R = S1R*C1R + S1I = S1I*C1R + S2R = C2R + S2I = C2I + S1R = S1R*CSSR(IFLAG) + S1I = S1I*CSSR(IFLAG) + S2R = S2R*CSSR(IFLAG) + S2I = S2I*CSSR(IFLAG) + C1R = CSRR(IFLAG) + 100 CONTINUE + 110 CONTINUE + RETURN + 120 CONTINUE + IF (RS1.GT.0.0D0) GO TO 140 +C----------------------------------------------------------------------- +C SET UNDERFLOW AND UPDATE PARAMETERS +C----------------------------------------------------------------------- + YR(ND) = ZEROR + YI(ND) = ZEROI + NZ = NZ + 1 + ND = ND - 1 + IF (ND.EQ.0) GO TO 110 + CALL ZUOIK(ZR, ZI, FNU, KODE, 1, ND, YR, YI, NUF, TOL, ELIM, ALIM) + IF (NUF.LT.0) GO TO 140 + ND = ND - NUF + NZ = NZ + NUF + IF (ND.EQ.0) GO TO 110 + FN = FNU + (ND-1) + IF (FN.LT.FNUL) GO TO 130 +C FN = CIDI +C J = NUF + 1 +C K = MOD(J,4) + 1 +C S1R = CIPR(K) +C S1I = CIPI(K) +C IF (FN.LT.0.0D0) S1I = -S1I +C STR = C2R*S1R - C2I*S1I +C C2I = C2R*S1I + C2I*S1R +C C2R = STR + IN = INU + ND - 1 + IN = MOD(IN,4) + 1 + C2R = CAR*CIPR(IN) - SAR*CIPI(IN) + C2I = CAR*CIPI(IN) + SAR*CIPR(IN) + IF (ZI.LE.0.0D0) C2I = -C2I + GO TO 40 + 130 CONTINUE + NLAST = ND + RETURN + 140 CONTINUE + NZ = -1 + RETURN + 150 CONTINUE + IF (RS1.GT.0.0D0) GO TO 140 + NZ = N + DO 160 I=1,N + YR(I) = ZEROR + YI(I) = ZEROI + 160 CONTINUE + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zuni2.lo b/modules/elementary_functions/src/fortran/slatec/zuni2.lo new file mode 100755 index 000000000..a3a668409 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zuni2.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zuni2.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zuni2.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zunik.f b/modules/elementary_functions/src/fortran/slatec/zunik.f new file mode 100755 index 000000000..6785b9884 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zunik.f @@ -0,0 +1,223 @@ +*DECK ZUNIK + SUBROUTINE ZUNIK (ZRR, ZRI, FNU, IKFLG, IPMTR, TOL, INIT, PHIR, + + PHII, ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) +C***BEGIN PROLOGUE ZUNIK +C***SUBSIDIARY +C***PURPOSE Subsidiary to ZBESI and ZBESK +C***LIBRARY SLATEC +C***TYPE ALL (CUNIK-A, ZUNIK-A) +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C ZUNIK COMPUTES PARAMETERS FOR THE UNIFORM ASYMPTOTIC +C EXPANSIONS OF THE I AND K FUNCTIONS ON IKFLG= 1 OR 2 +C RESPECTIVELY BY +C +C W(FNU,ZR) = PHI*EXP(ZETA)*SUM +C +C WHERE ZETA=-ZETA1 + ZETA2 OR +C ZETA1 - ZETA2 +C +C THE FIRST CALL MUST HAVE INIT=0. SUBSEQUENT CALLS WITH THE +C SAME ZR AND FNU WILL RETURN THE I OR K FUNCTION ON IKFLG= +C 1 OR 2 WITH NO CHANGE IN INIT. CWRK IS A COMPLEX WORK +C ARRAY. IPMTR=0 COMPUTES ALL PARAMETERS. IPMTR=1 COMPUTES PHI, +C ZETA1,ZETA2. +C +C***SEE ALSO ZBESI, ZBESK +C***ROUTINES CALLED D1MACH, ZDIV, ZLOG, ZSQRT +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 910415 Prologue converted to Version 4.0 format. (BAB) +C 930122 Added EXTERNAL statement with ZLOG and ZSQRT. (RWC) +C***END PROLOGUE ZUNIK +C COMPLEX CFN,CON,CONE,CRFN,CWRK,CZERO,PHI,S,SR,SUM,T,T2,ZETA1, +C *ZETA2,ZN,ZR + DOUBLE PRECISION AC, C, CON, CONEI, CONER, CRFNI, CRFNR, CWRKI, + * CWRKR, FNU, PHII, PHIR, RFN, SI, SR, SRI, SRR, STI, STR, SUMI, + * SUMR, TEST, TI, TOL, TR, T2I, T2R, ZEROI, ZEROR, ZETA1I, ZETA1R, + * ZETA2I, ZETA2R, ZNI, ZNR, ZRI, ZRR, D1MACH + INTEGER I, IDUM, IKFLG, INIT, IPMTR, J, K, L + DIMENSION C(120), CWRKR(16), CWRKI(16), CON(2) + EXTERNAL ZLOG, ZSQRT + DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / + DATA CON(1), CON(2) / + 1 3.98942280401432678D-01, 1.25331413731550025D+00 / + DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), + 1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), + 2 C(19), C(20), C(21), C(22), C(23), C(24)/ + 3 1.00000000000000000D+00, -2.08333333333333333D-01, + 4 1.25000000000000000D-01, 3.34201388888888889D-01, + 5 -4.01041666666666667D-01, 7.03125000000000000D-02, + 6 -1.02581259645061728D+00, 1.84646267361111111D+00, + 7 -8.91210937500000000D-01, 7.32421875000000000D-02, + 8 4.66958442342624743D+00, -1.12070026162229938D+01, + 9 8.78912353515625000D+00, -2.36408691406250000D+00, + A 1.12152099609375000D-01, -2.82120725582002449D+01, + B 8.46362176746007346D+01, -9.18182415432400174D+01, + C 4.25349987453884549D+01, -7.36879435947963170D+00, + D 2.27108001708984375D-01, 2.12570130039217123D+02, + E -7.65252468141181642D+02, 1.05999045252799988D+03/ + DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), + 1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), + 2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ + 3 -6.99579627376132541D+02, 2.18190511744211590D+02, + 4 -2.64914304869515555D+01, 5.72501420974731445D-01, + 5 -1.91945766231840700D+03, 8.06172218173730938D+03, + 6 -1.35865500064341374D+04, 1.16553933368645332D+04, + 7 -5.30564697861340311D+03, 1.20090291321635246D+03, + 8 -1.08090919788394656D+02, 1.72772750258445740D+00, + 9 2.02042913309661486D+04, -9.69805983886375135D+04, + A 1.92547001232531532D+05, -2.03400177280415534D+05, + B 1.22200464983017460D+05, -4.11926549688975513D+04, + C 7.10951430248936372D+03, -4.93915304773088012D+02, + D 6.07404200127348304D+00, -2.42919187900551333D+05, + E 1.31176361466297720D+06, -2.99801591853810675D+06/ + DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), + 1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), + 2 C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/ + 3 3.76327129765640400D+06, -2.81356322658653411D+06, + 4 1.26836527332162478D+06, -3.31645172484563578D+05, + 5 4.52187689813627263D+04, -2.49983048181120962D+03, + 6 2.43805296995560639D+01, 3.28446985307203782D+06, + 7 -1.97068191184322269D+07, 5.09526024926646422D+07, + 8 -7.41051482115326577D+07, 6.63445122747290267D+07, + 9 -3.75671766607633513D+07, 1.32887671664218183D+07, + A -2.78561812808645469D+06, 3.08186404612662398D+05, + B -1.38860897537170405D+04, 1.10017140269246738D+02, + C -4.93292536645099620D+07, 3.25573074185765749D+08, + D -9.39462359681578403D+08, 1.55359689957058006D+09, + E -1.62108055210833708D+09, 1.10684281682301447D+09/ + DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80), + 1 C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88), + 2 C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/ + 3 -4.95889784275030309D+08, 1.42062907797533095D+08, + 4 -2.44740627257387285D+07, 2.24376817792244943D+06, + 5 -8.40054336030240853D+04, 5.51335896122020586D+02, + 6 8.14789096118312115D+08, -5.86648149205184723D+09, + 7 1.86882075092958249D+10, -3.46320433881587779D+10, + 8 4.12801855797539740D+10, -3.30265997498007231D+10, + 9 1.79542137311556001D+10, -6.56329379261928433D+09, + A 1.55927986487925751D+09, -2.25105661889415278D+08, + B 1.73951075539781645D+07, -5.49842327572288687D+05, + C 3.03809051092238427D+03, -1.46792612476956167D+10, + D 1.14498237732025810D+11, -3.99096175224466498D+11, + E 8.19218669548577329D+11, -1.09837515608122331D+12/ + DATA C(97), C(98), C(99), C(100), C(101), C(102), C(103), C(104), + 1 C(105), C(106), C(107), C(108), C(109), C(110), C(111), + 2 C(112), C(113), C(114), C(115), C(116), C(117), C(118)/ + 3 1.00815810686538209D+12, -6.45364869245376503D+11, + 4 2.87900649906150589D+11, -8.78670721780232657D+10, + 5 1.76347306068349694D+10, -2.16716498322379509D+09, + 6 1.43157876718888981D+08, -3.87183344257261262D+06, + 7 1.82577554742931747D+04, 2.86464035717679043D+11, + 8 -2.40629790002850396D+12, 9.10934118523989896D+12, + 9 -2.05168994109344374D+13, 3.05651255199353206D+13, + A -3.16670885847851584D+13, 2.33483640445818409D+13, + B -1.23204913055982872D+13, 4.61272578084913197D+12, + C -1.19655288019618160D+12, 2.05914503232410016D+11, + D -2.18229277575292237D+10, 1.24700929351271032D+09/ + DATA C(119), C(120)/ + 1 -2.91883881222208134D+07, 1.18838426256783253D+05/ +C***FIRST EXECUTABLE STATEMENT ZUNIK + IF (INIT.NE.0) GO TO 40 +C----------------------------------------------------------------------- +C INITIALIZE ALL VARIABLES +C----------------------------------------------------------------------- + RFN = 1.0D0/FNU +C----------------------------------------------------------------------- +C OVERFLOW TEST (ZR/FNU TOO SMALL) +C----------------------------------------------------------------------- + TEST = D1MACH(1)*1.0D+3 + AC = FNU*TEST + IF (ABS(ZRR).GT.AC .OR. ABS(ZRI).GT.AC) GO TO 15 + ZETA1R = 2.0D0*ABS(LOG(TEST))+FNU + ZETA1I = 0.0D0 + ZETA2R = FNU + ZETA2I = 0.0D0 + PHIR = 1.0D0 + PHII = 0.0D0 + RETURN + 15 CONTINUE + TR = ZRR*RFN + TI = ZRI*RFN + SR = CONER + (TR*TR-TI*TI) + SI = CONEI + (TR*TI+TI*TR) + CALL ZSQRT(SR, SI, SRR, SRI) + STR = CONER + SRR + STI = CONEI + SRI + CALL ZDIV(STR, STI, TR, TI, ZNR, ZNI) + CALL ZLOG(ZNR, ZNI, STR, STI, IDUM) + ZETA1R = FNU*STR + ZETA1I = FNU*STI + ZETA2R = FNU*SRR + ZETA2I = FNU*SRI + CALL ZDIV(CONER, CONEI, SRR, SRI, TR, TI) + SRR = TR*RFN + SRI = TI*RFN + CALL ZSQRT(SRR, SRI, CWRKR(16), CWRKI(16)) + PHIR = CWRKR(16)*CON(IKFLG) + PHII = CWRKI(16)*CON(IKFLG) + IF (IPMTR.NE.0) RETURN + CALL ZDIV(CONER, CONEI, SR, SI, T2R, T2I) + CWRKR(1) = CONER + CWRKI(1) = CONEI + CRFNR = CONER + CRFNI = CONEI + AC = 1.0D0 + L = 1 + DO 20 K=2,15 + SR = ZEROR + SI = ZEROI + DO 10 J=1,K + L = L + 1 + STR = SR*T2R - SI*T2I + C(L) + SI = SR*T2I + SI*T2R + SR = STR + 10 CONTINUE + STR = CRFNR*SRR - CRFNI*SRI + CRFNI = CRFNR*SRI + CRFNI*SRR + CRFNR = STR + CWRKR(K) = CRFNR*SR - CRFNI*SI + CWRKI(K) = CRFNR*SI + CRFNI*SR + AC = AC*RFN + TEST = ABS(CWRKR(K)) + ABS(CWRKI(K)) + IF (AC.LT.TOL .AND. TEST.LT.TOL) GO TO 30 + 20 CONTINUE + K = 15 + 30 CONTINUE + INIT = K + 40 CONTINUE + IF (IKFLG.EQ.2) GO TO 60 +C----------------------------------------------------------------------- +C COMPUTE SUM FOR THE I FUNCTION +C----------------------------------------------------------------------- + SR = ZEROR + SI = ZEROI + DO 50 I=1,INIT + SR = SR + CWRKR(I) + SI = SI + CWRKI(I) + 50 CONTINUE + SUMR = SR + SUMI = SI + PHIR = CWRKR(16)*CON(1) + PHII = CWRKI(16)*CON(1) + RETURN + 60 CONTINUE +C----------------------------------------------------------------------- +C COMPUTE SUM FOR THE K FUNCTION +C----------------------------------------------------------------------- + SR = ZEROR + SI = ZEROI + TR = CONER + DO 70 I=1,INIT + SR = SR + TR*CWRKR(I) + SI = SI + TR*CWRKI(I) + TR = -TR + 70 CONTINUE + SUMR = SR + SUMI = SI + PHIR = CWRKR(16)*CON(2) + PHII = CWRKI(16)*CON(2) + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zunik.lo b/modules/elementary_functions/src/fortran/slatec/zunik.lo new file mode 100755 index 000000000..a3c02a499 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zunik.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zunik.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zunik.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zunk1.f b/modules/elementary_functions/src/fortran/slatec/zunk1.f new file mode 100755 index 000000000..5824df0c9 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zunk1.f @@ -0,0 +1,437 @@ +*DECK ZUNK1 + SUBROUTINE ZUNK1 (ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, + + ALIM) +C***BEGIN PROLOGUE ZUNK1 +C***SUBSIDIARY +C***PURPOSE Subsidiary to ZBESK +C***LIBRARY SLATEC +C***TYPE ALL (CUNK1-A, ZUNK1-A) +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C ZUNK1 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE +C RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE +C UNIFORM ASYMPTOTIC EXPANSION. +C MR INDICATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION. +C NZ=-1 MEANS AN OVERFLOW WILL OCCUR +C +C***SEE ALSO ZBESK +C***ROUTINES CALLED D1MACH, ZABS, ZS1S2, ZUCHK, ZUNIK +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 910415 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE ZUNK1 +C COMPLEX CFN,CK,CONE,CRSC,CS,CSCL,CSGN,CSPN,CSR,CSS,CWRK,CY,CZERO, +C *C1,C2,PHI,PHID,RZ,SUM,SUMD,S1,S2,Y,Z,ZETA1,ZETA1D,ZETA2,ZETA2D,ZR + DOUBLE PRECISION ALIM, ANG, APHI, ASC, ASCLE, BRY, CKI, CKR, + * CONER, CRSC, CSCL, CSGNI, CSPNI, CSPNR, CSR, CSRR, CSSR, + * CWRKI, CWRKR, CYI, CYR, C1I, C1R, C2I, C2M, C2R, ELIM, FMR, FN, + * FNF, FNU, PHIDI, PHIDR, PHII, PHIR, PI, RAST, RAZR, RS1, RZI, + * RZR, SGN, STI, STR, SUMDI, SUMDR, SUMI, SUMR, S1I, S1R, S2I, + * S2R, TOL, YI, YR, ZEROI, ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, + * ZET1DI, ZET1DR, ZET2DI, ZET2DR, ZI, ZR, ZRI, ZRR, D1MACH, ZABS + INTEGER I, IB, IFLAG, IFN, IL, INIT, INU, IUF, K, KDFLG, KFLAG, + * KK, KODE, MR, N, NW, NZ, INITD, IC, IPARD, J, M + DIMENSION BRY(3), INIT(2), YR(N), YI(N), SUMR(2), SUMI(2), + * ZETA1R(2), ZETA1I(2), ZETA2R(2), ZETA2I(2), CYR(2), CYI(2), + * CWRKR(16,3), CWRKI(16,3), CSSR(3), CSRR(3), PHIR(2), PHII(2) + EXTERNAL ZABS + DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 / + DATA PI / 3.14159265358979324D0 / +C***FIRST EXECUTABLE STATEMENT ZUNK1 + KDFLG = 1 + NZ = 0 +C----------------------------------------------------------------------- +C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN +C THE UNDERFLOW LIMIT +C----------------------------------------------------------------------- + CSCL = 1.0D0/TOL + CRSC = TOL + CSSR(1) = CSCL + CSSR(2) = CONER + CSSR(3) = CRSC + CSRR(1) = CRSC + CSRR(2) = CONER + CSRR(3) = CSCL + BRY(1) = 1.0D+3*D1MACH(1)/TOL + BRY(2) = 1.0D0/BRY(1) + BRY(3) = D1MACH(2) + ZRR = ZR + ZRI = ZI + IF (ZR.GE.0.0D0) GO TO 10 + ZRR = -ZR + ZRI = -ZI + 10 CONTINUE + J = 2 + DO 70 I=1,N +C----------------------------------------------------------------------- +C J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J +C----------------------------------------------------------------------- + J = 3 - J + FN = FNU + (I-1) + INIT(J) = 0 + CALL ZUNIK(ZRR, ZRI, FN, 2, 0, TOL, INIT(J), PHIR(J), PHII(J), + * ZETA1R(J), ZETA1I(J), ZETA2R(J), ZETA2I(J), SUMR(J), SUMI(J), + * CWRKR(1,J), CWRKI(1,J)) + IF (KODE.EQ.1) GO TO 20 + STR = ZRR + ZETA2R(J) + STI = ZRI + ZETA2I(J) + RAST = FN/ZABS(STR,STI) + STR = STR*RAST*RAST + STI = -STI*RAST*RAST + S1R = ZETA1R(J) - STR + S1I = ZETA1I(J) - STI + GO TO 30 + 20 CONTINUE + S1R = ZETA1R(J) - ZETA2R(J) + S1I = ZETA1I(J) - ZETA2I(J) + 30 CONTINUE + RS1 = S1R +C----------------------------------------------------------------------- +C TEST FOR UNDERFLOW AND OVERFLOW +C----------------------------------------------------------------------- + IF (ABS(RS1).GT.ELIM) GO TO 60 + IF (KDFLG.EQ.1) KFLAG = 2 + IF (ABS(RS1).LT.ALIM) GO TO 40 +C----------------------------------------------------------------------- +C REFINE TEST AND SCALE +C----------------------------------------------------------------------- + APHI = ZABS(PHIR(J),PHII(J)) + RS1 = RS1 + LOG(APHI) + IF (ABS(RS1).GT.ELIM) GO TO 60 + IF (KDFLG.EQ.1) KFLAG = 1 + IF (RS1.LT.0.0D0) GO TO 40 + IF (KDFLG.EQ.1) KFLAG = 3 + 40 CONTINUE +C----------------------------------------------------------------------- +C SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR +C EXPONENT EXTREMES +C----------------------------------------------------------------------- + S2R = PHIR(J)*SUMR(J) - PHII(J)*SUMI(J) + S2I = PHIR(J)*SUMI(J) + PHII(J)*SUMR(J) + STR = EXP(S1R)*CSSR(KFLAG) + S1R = STR*COS(S1I) + S1I = STR*SIN(S1I) + STR = S2R*S1R - S2I*S1I + S2I = S1R*S2I + S2R*S1I + S2R = STR + IF (KFLAG.NE.1) GO TO 50 + CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) + IF (NW.NE.0) GO TO 60 + 50 CONTINUE + CYR(KDFLG) = S2R + CYI(KDFLG) = S2I + YR(I) = S2R*CSRR(KFLAG) + YI(I) = S2I*CSRR(KFLAG) + IF (KDFLG.EQ.2) GO TO 75 + KDFLG = 2 + GO TO 70 + 60 CONTINUE + IF (RS1.GT.0.0D0) GO TO 300 +C----------------------------------------------------------------------- +C FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW +C----------------------------------------------------------------------- + IF (ZR.LT.0.0D0) GO TO 300 + KDFLG = 1 + YR(I)=ZEROR + YI(I)=ZEROI + NZ=NZ+1 + IF (I.EQ.1) GO TO 70 + IF ((YR(I-1).EQ.ZEROR).AND.(YI(I-1).EQ.ZEROI)) GO TO 70 + YR(I-1)=ZEROR + YI(I-1)=ZEROI + NZ=NZ+1 + 70 CONTINUE + I = N + 75 CONTINUE + RAZR = 1.0D0/ZABS(ZRR,ZRI) + STR = ZRR*RAZR + STI = -ZRI*RAZR + RZR = (STR+STR)*RAZR + RZI = (STI+STI)*RAZR + CKR = FN*RZR + CKI = FN*RZI + IB = I + 1 + IF (N.LT.IB) GO TO 160 +C----------------------------------------------------------------------- +C TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW. SET SEQUENCE TO ZERO +C ON UNDERFLOW. +C----------------------------------------------------------------------- + FN = FNU + (N-1) + IPARD = 1 + IF (MR.NE.0) IPARD = 0 + INITD = 0 + CALL ZUNIK(ZRR, ZRI, FN, 2, IPARD, TOL, INITD, PHIDR, PHIDI, + * ZET1DR, ZET1DI, ZET2DR, ZET2DI, SUMDR, SUMDI, CWRKR(1,3), + * CWRKI(1,3)) + IF (KODE.EQ.1) GO TO 80 + STR = ZRR + ZET2DR + STI = ZRI + ZET2DI + RAST = FN/ZABS(STR,STI) + STR = STR*RAST*RAST + STI = -STI*RAST*RAST + S1R = ZET1DR - STR + S1I = ZET1DI - STI + GO TO 90 + 80 CONTINUE + S1R = ZET1DR - ZET2DR + S1I = ZET1DI - ZET2DI + 90 CONTINUE + RS1 = S1R + IF (ABS(RS1).GT.ELIM) GO TO 95 + IF (ABS(RS1).LT.ALIM) GO TO 100 +C----------------------------------------------------------------------- +C REFINE ESTIMATE AND TEST +C----------------------------------------------------------------------- + APHI = ZABS(PHIDR,PHIDI) + RS1 = RS1+LOG(APHI) + IF (ABS(RS1).LT.ELIM) GO TO 100 + 95 CONTINUE + IF (ABS(RS1).GT.0.0D0) GO TO 300 +C----------------------------------------------------------------------- +C FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW +C----------------------------------------------------------------------- + IF (ZR.LT.0.0D0) GO TO 300 + NZ = N + DO 96 I=1,N + YR(I) = ZEROR + YI(I) = ZEROI + 96 CONTINUE + RETURN +C----------------------------------------------------------------------- +C FORWARD RECUR FOR REMAINDER OF THE SEQUENCE +C----------------------------------------------------------------------- + 100 CONTINUE + S1R = CYR(1) + S1I = CYI(1) + S2R = CYR(2) + S2I = CYI(2) + C1R = CSRR(KFLAG) + ASCLE = BRY(KFLAG) + DO 120 I=IB,N + C2R = S2R + C2I = S2I + S2R = CKR*C2R - CKI*C2I + S1R + S2I = CKR*C2I + CKI*C2R + S1I + S1R = C2R + S1I = C2I + CKR = CKR + RZR + CKI = CKI + RZI + C2R = S2R*C1R + C2I = S2I*C1R + YR(I) = C2R + YI(I) = C2I + IF (KFLAG.GE.3) GO TO 120 + STR = ABS(C2R) + STI = ABS(C2I) + C2M = MAX(STR,STI) + IF (C2M.LE.ASCLE) GO TO 120 + KFLAG = KFLAG + 1 + ASCLE = BRY(KFLAG) + S1R = S1R*C1R + S1I = S1I*C1R + S2R = C2R + S2I = C2I + S1R = S1R*CSSR(KFLAG) + S1I = S1I*CSSR(KFLAG) + S2R = S2R*CSSR(KFLAG) + S2I = S2I*CSSR(KFLAG) + C1R = CSRR(KFLAG) + 120 CONTINUE + 160 CONTINUE + IF (MR.EQ.0) RETURN +C----------------------------------------------------------------------- +C ANALYTIC CONTINUATION FOR RE(Z).LT.0.0D0 +C----------------------------------------------------------------------- + NZ = 0 + FMR = MR + SGN = -DSIGN(PI,FMR) +C----------------------------------------------------------------------- +C CSPN AND CSGN ARE COEFF OF K AND I FUNCTIONS RESP. +C----------------------------------------------------------------------- + CSGNI = SGN + INU = FNU + FNF = FNU - INU + IFN = INU + N - 1 + ANG = FNF*SGN + CSPNR = COS(ANG) + CSPNI = SIN(ANG) + IF (MOD(IFN,2).EQ.0) GO TO 170 + CSPNR = -CSPNR + CSPNI = -CSPNI + 170 CONTINUE + ASC = BRY(1) + IUF = 0 + KK = N + KDFLG = 1 + IB = IB - 1 + IC = IB - 1 + DO 270 K=1,N + FN = FNU + (KK-1) +C----------------------------------------------------------------------- +C LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K +C FUNCTION ABOVE +C----------------------------------------------------------------------- + M=3 + IF (N.GT.2) GO TO 175 + 172 CONTINUE + INITD = INIT(J) + PHIDR = PHIR(J) + PHIDI = PHII(J) + ZET1DR = ZETA1R(J) + ZET1DI = ZETA1I(J) + ZET2DR = ZETA2R(J) + ZET2DI = ZETA2I(J) + SUMDR = SUMR(J) + SUMDI = SUMI(J) + M = J + J = 3 - J + GO TO 180 + 175 CONTINUE + IF ((KK.EQ.N).AND.(IB.LT.N)) GO TO 180 + IF ((KK.EQ.IB).OR.(KK.EQ.IC)) GO TO 172 + INITD = 0 + 180 CONTINUE + CALL ZUNIK(ZRR, ZRI, FN, 1, 0, TOL, INITD, PHIDR, PHIDI, + * ZET1DR, ZET1DI, ZET2DR, ZET2DI, SUMDR, SUMDI, + * CWRKR(1,M), CWRKI(1,M)) + IF (KODE.EQ.1) GO TO 200 + STR = ZRR + ZET2DR + STI = ZRI + ZET2DI + RAST = FN/ZABS(STR,STI) + STR = STR*RAST*RAST + STI = -STI*RAST*RAST + S1R = -ZET1DR + STR + S1I = -ZET1DI + STI + GO TO 210 + 200 CONTINUE + S1R = -ZET1DR + ZET2DR + S1I = -ZET1DI + ZET2DI + 210 CONTINUE +C----------------------------------------------------------------------- +C TEST FOR UNDERFLOW AND OVERFLOW +C----------------------------------------------------------------------- + RS1 = S1R + IF (ABS(RS1).GT.ELIM) GO TO 260 + IF (KDFLG.EQ.1) IFLAG = 2 + IF (ABS(RS1).LT.ALIM) GO TO 220 +C----------------------------------------------------------------------- +C REFINE TEST AND SCALE +C----------------------------------------------------------------------- + APHI = ZABS(PHIDR,PHIDI) + RS1 = RS1 + LOG(APHI) + IF (ABS(RS1).GT.ELIM) GO TO 260 + IF (KDFLG.EQ.1) IFLAG = 1 + IF (RS1.LT.0.0D0) GO TO 220 + IF (KDFLG.EQ.1) IFLAG = 3 + 220 CONTINUE + STR = PHIDR*SUMDR - PHIDI*SUMDI + STI = PHIDR*SUMDI + PHIDI*SUMDR + S2R = -CSGNI*STI + S2I = CSGNI*STR + STR = EXP(S1R)*CSSR(IFLAG) + S1R = STR*COS(S1I) + S1I = STR*SIN(S1I) + STR = S2R*S1R - S2I*S1I + S2I = S2R*S1I + S2I*S1R + S2R = STR + IF (IFLAG.NE.1) GO TO 230 + CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) + IF (NW.EQ.0) GO TO 230 + S2R = ZEROR + S2I = ZEROI + 230 CONTINUE + CYR(KDFLG) = S2R + CYI(KDFLG) = S2I + C2R = S2R + C2I = S2I + S2R = S2R*CSRR(IFLAG) + S2I = S2I*CSRR(IFLAG) +C----------------------------------------------------------------------- +C ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N +C----------------------------------------------------------------------- + S1R = YR(KK) + S1I = YI(KK) + IF (KODE.EQ.1) GO TO 250 + CALL ZS1S2(ZRR, ZRI, S1R, S1I, S2R, S2I, NW, ASC, ALIM, IUF) + NZ = NZ + NW + 250 CONTINUE + YR(KK) = S1R*CSPNR - S1I*CSPNI + S2R + YI(KK) = CSPNR*S1I + CSPNI*S1R + S2I + KK = KK - 1 + CSPNR = -CSPNR + CSPNI = -CSPNI + IF (C2R.NE.0.0D0 .OR. C2I.NE.0.0D0) GO TO 255 + KDFLG = 1 + GO TO 270 + 255 CONTINUE + IF (KDFLG.EQ.2) GO TO 275 + KDFLG = 2 + GO TO 270 + 260 CONTINUE + IF (RS1.GT.0.0D0) GO TO 300 + S2R = ZEROR + S2I = ZEROI + GO TO 230 + 270 CONTINUE + K = N + 275 CONTINUE + IL = N - K + IF (IL.EQ.0) RETURN +C----------------------------------------------------------------------- +C RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE +C K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP +C INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES. +C----------------------------------------------------------------------- + S1R = CYR(1) + S1I = CYI(1) + S2R = CYR(2) + S2I = CYI(2) + CSR = CSRR(IFLAG) + ASCLE = BRY(IFLAG) + FN = INU+IL + DO 290 I=1,IL + C2R = S2R + C2I = S2I + S2R = S1R + (FN+FNF)*(RZR*C2R-RZI*C2I) + S2I = S1I + (FN+FNF)*(RZR*C2I+RZI*C2R) + S1R = C2R + S1I = C2I + FN = FN - 1.0D0 + C2R = S2R*CSR + C2I = S2I*CSR + CKR = C2R + CKI = C2I + C1R = YR(KK) + C1I = YI(KK) + IF (KODE.EQ.1) GO TO 280 + CALL ZS1S2(ZRR, ZRI, C1R, C1I, C2R, C2I, NW, ASC, ALIM, IUF) + NZ = NZ + NW + 280 CONTINUE + YR(KK) = C1R*CSPNR - C1I*CSPNI + C2R + YI(KK) = C1R*CSPNI + C1I*CSPNR + C2I + KK = KK - 1 + CSPNR = -CSPNR + CSPNI = -CSPNI + IF (IFLAG.GE.3) GO TO 290 + C2R = ABS(CKR) + C2I = ABS(CKI) + C2M = MAX(C2R,C2I) + IF (C2M.LE.ASCLE) GO TO 290 + IFLAG = IFLAG + 1 + ASCLE = BRY(IFLAG) + S1R = S1R*CSR + S1I = S1I*CSR + S2R = CKR + S2I = CKI + S1R = S1R*CSSR(IFLAG) + S1I = S1I*CSSR(IFLAG) + S2R = S2R*CSSR(IFLAG) + S2I = S2I*CSSR(IFLAG) + CSR = CSRR(IFLAG) + 290 CONTINUE + RETURN + 300 CONTINUE + NZ = -1 + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zunk1.lo b/modules/elementary_functions/src/fortran/slatec/zunk1.lo new file mode 100755 index 000000000..210a510a8 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zunk1.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zunk1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zunk1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zunk2.f b/modules/elementary_functions/src/fortran/slatec/zunk2.f new file mode 100755 index 000000000..a69492f9f --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zunk2.f @@ -0,0 +1,516 @@ +*DECK ZUNK2 + SUBROUTINE ZUNK2 (ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, + + ALIM) +C***BEGIN PROLOGUE ZUNK2 +C***SUBSIDIARY +C***PURPOSE Subsidiary to ZBESK +C***LIBRARY SLATEC +C***TYPE ALL (CUNK2-A, ZUNK2-A) +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C ZUNK2 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE +C RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE +C UNIFORM ASYMPTOTIC EXPANSIONS FOR H(KIND,FNU,ZN) AND J(FNU,ZN) +C WHERE ZN IS IN THE RIGHT HALF PLANE, KIND=(3-MR)/2, MR=+1 OR +C -1. HERE ZN=ZR*I OR -ZR*I WHERE ZR=Z IF Z IS IN THE RIGHT +C HALF PLANE OR ZR=-Z IF Z IS IN THE LEFT HALF PLANE. MR INDIC- +C ATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION. +C NZ=-1 MEANS AN OVERFLOW WILL OCCUR +C +C***SEE ALSO ZBESK +C***ROUTINES CALLED D1MACH, ZABS, ZAIRY, ZS1S2, ZUCHK, ZUNHJ +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 910415 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE ZUNK2 +C COMPLEX AI,ARG,ARGD,ASUM,ASUMD,BSUM,BSUMD,CFN,CI,CIP,CK,CONE,CRSC, +C *CR1,CR2,CS,CSCL,CSGN,CSPN,CSR,CSS,CY,CZERO,C1,C2,DAI,PHI,PHID,RZ, +C *S1,S2,Y,Z,ZB,ZETA1,ZETA1D,ZETA2,ZETA2D,ZN,ZR + DOUBLE PRECISION AARG, AIC, AII, AIR, ALIM, ANG, APHI, ARGDI, + * ARGDR, ARGI, ARGR, ASC, ASCLE, ASUMDI, ASUMDR, ASUMI, ASUMR, + * BRY, BSUMDI, BSUMDR, BSUMI, BSUMR, CAR, CIPI, CIPR, CKI, CKR, + * CONER, CRSC, CR1I, CR1R, CR2I, CR2R, CSCL, CSGNI, CSI, + * CSPNI, CSPNR, CSR, CSRR, CSSR, CYI, CYR, C1I, C1R, C2I, C2M, + * C2R, DAII, DAIR, ELIM, FMR, FN, FNF, FNU, HPI, PHIDI, PHIDR, + * PHII, PHIR, PI, PTI, PTR, RAST, RAZR, RS1, RZI, RZR, SAR, SGN, + * STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, YY, ZBI, ZBR, ZEROI, + * ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZET1DI, ZET1DR, ZET2DI, + * ZET2DR, ZI, ZNI, ZNR, ZR, ZRI, ZRR, D1MACH, ZABS + INTEGER I, IB, IFLAG, IFN, IL, IN, INU, IUF, K, KDFLG, KFLAG, KK, + * KODE, MR, N, NAI, NDAI, NW, NZ, IDUM, J, IPARD, IC + DIMENSION BRY(3), YR(N), YI(N), ASUMR(2), ASUMI(2), BSUMR(2), + * BSUMI(2), PHIR(2), PHII(2), ARGR(2), ARGI(2), ZETA1R(2), + * ZETA1I(2), ZETA2R(2), ZETA2I(2), CYR(2), CYI(2), CIPR(4), + * CIPI(4), CSSR(3), CSRR(3) + EXTERNAL ZABS + DATA ZEROR,ZEROI,CONER,CR1R,CR1I,CR2R,CR2I / + 1 0.0D0, 0.0D0, 1.0D0, + 1 1.0D0,1.73205080756887729D0 , -0.5D0,-8.66025403784438647D-01 / + DATA HPI, PI, AIC / + 1 1.57079632679489662D+00, 3.14159265358979324D+00, + 1 1.26551212348464539D+00/ + DATA CIPR(1),CIPI(1),CIPR(2),CIPI(2),CIPR(3),CIPI(3),CIPR(4), + * CIPI(4) / + 1 1.0D0,0.0D0 , 0.0D0,-1.0D0 , -1.0D0,0.0D0 , 0.0D0,1.0D0 / +C***FIRST EXECUTABLE STATEMENT ZUNK2 + KDFLG = 1 + NZ = 0 +C----------------------------------------------------------------------- +C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN +C THE UNDERFLOW LIMIT +C----------------------------------------------------------------------- + CSCL = 1.0D0/TOL + CRSC = TOL + CSSR(1) = CSCL + CSSR(2) = CONER + CSSR(3) = CRSC + CSRR(1) = CRSC + CSRR(2) = CONER + CSRR(3) = CSCL + BRY(1) = 1.0D+3*D1MACH(1)/TOL + BRY(2) = 1.0D0/BRY(1) + BRY(3) = D1MACH(2) + ZRR = ZR + ZRI = ZI + IF (ZR.GE.0.0D0) GO TO 10 + ZRR = -ZR + ZRI = -ZI + 10 CONTINUE + YY = ZRI + ZNR = ZRI + ZNI = -ZRR + ZBR = ZRR + ZBI = ZRI + INU = FNU + FNF = FNU - INU + ANG = -HPI*FNF + CAR = COS(ANG) + SAR = SIN(ANG) + C2R = HPI*SAR + C2I = -HPI*CAR + KK = MOD(INU,4) + 1 + STR = C2R*CIPR(KK) - C2I*CIPI(KK) + STI = C2R*CIPI(KK) + C2I*CIPR(KK) + CSR = CR1R*STR - CR1I*STI + CSI = CR1R*STI + CR1I*STR + IF (YY.GT.0.0D0) GO TO 20 + ZNR = -ZNR + ZBI = -ZBI + 20 CONTINUE +C----------------------------------------------------------------------- +C K(FNU,Z) IS COMPUTED FROM H(2,FNU,-I*Z) WHERE Z IS IN THE FIRST +C QUADRANT. FOURTH QUADRANT VALUES (YY.LE.0.0E0) ARE COMPUTED BY +C CONJUGATION SINCE THE K FUNCTION IS REAL ON THE POSITIVE REAL AXIS +C----------------------------------------------------------------------- + J = 2 + DO 80 I=1,N +C----------------------------------------------------------------------- +C J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J +C----------------------------------------------------------------------- + J = 3 - J + FN = FNU + (I-1) + CALL ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIR(J), PHII(J), ARGR(J), + * ARGI(J), ZETA1R(J), ZETA1I(J), ZETA2R(J), ZETA2I(J), ASUMR(J), + * ASUMI(J), BSUMR(J), BSUMI(J)) + IF (KODE.EQ.1) GO TO 30 + STR = ZBR + ZETA2R(J) + STI = ZBI + ZETA2I(J) + RAST = FN/ZABS(STR,STI) + STR = STR*RAST*RAST + STI = -STI*RAST*RAST + S1R = ZETA1R(J) - STR + S1I = ZETA1I(J) - STI + GO TO 40 + 30 CONTINUE + S1R = ZETA1R(J) - ZETA2R(J) + S1I = ZETA1I(J) - ZETA2I(J) + 40 CONTINUE +C----------------------------------------------------------------------- +C TEST FOR UNDERFLOW AND OVERFLOW +C----------------------------------------------------------------------- + RS1 = S1R + IF (ABS(RS1).GT.ELIM) GO TO 70 + IF (KDFLG.EQ.1) KFLAG = 2 + IF (ABS(RS1).LT.ALIM) GO TO 50 +C----------------------------------------------------------------------- +C REFINE TEST AND SCALE +C----------------------------------------------------------------------- + APHI = ZABS(PHIR(J),PHII(J)) + AARG = ZABS(ARGR(J),ARGI(J)) + RS1 = RS1 + LOG(APHI) - 0.25D0*LOG(AARG) - AIC + IF (ABS(RS1).GT.ELIM) GO TO 70 + IF (KDFLG.EQ.1) KFLAG = 1 + IF (RS1.LT.0.0D0) GO TO 50 + IF (KDFLG.EQ.1) KFLAG = 3 + 50 CONTINUE +C----------------------------------------------------------------------- +C SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR +C EXPONENT EXTREMES +C----------------------------------------------------------------------- + C2R = ARGR(J)*CR2R - ARGI(J)*CR2I + C2I = ARGR(J)*CR2I + ARGI(J)*CR2R + CALL ZAIRY(C2R, C2I, 0, 2, AIR, AII, NAI, IDUM) + CALL ZAIRY(C2R, C2I, 1, 2, DAIR, DAII, NDAI, IDUM) + STR = DAIR*BSUMR(J) - DAII*BSUMI(J) + STI = DAIR*BSUMI(J) + DAII*BSUMR(J) + PTR = STR*CR2R - STI*CR2I + PTI = STR*CR2I + STI*CR2R + STR = PTR + (AIR*ASUMR(J)-AII*ASUMI(J)) + STI = PTI + (AIR*ASUMI(J)+AII*ASUMR(J)) + PTR = STR*PHIR(J) - STI*PHII(J) + PTI = STR*PHII(J) + STI*PHIR(J) + S2R = PTR*CSR - PTI*CSI + S2I = PTR*CSI + PTI*CSR + STR = EXP(S1R)*CSSR(KFLAG) + S1R = STR*COS(S1I) + S1I = STR*SIN(S1I) + STR = S2R*S1R - S2I*S1I + S2I = S1R*S2I + S2R*S1I + S2R = STR + IF (KFLAG.NE.1) GO TO 60 + CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) + IF (NW.NE.0) GO TO 70 + 60 CONTINUE + IF (YY.LE.0.0D0) S2I = -S2I + CYR(KDFLG) = S2R + CYI(KDFLG) = S2I + YR(I) = S2R*CSRR(KFLAG) + YI(I) = S2I*CSRR(KFLAG) + STR = CSI + CSI = -CSR + CSR = STR + IF (KDFLG.EQ.2) GO TO 85 + KDFLG = 2 + GO TO 80 + 70 CONTINUE + IF (RS1.GT.0.0D0) GO TO 320 +C----------------------------------------------------------------------- +C FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW +C----------------------------------------------------------------------- + IF (ZR.LT.0.0D0) GO TO 320 + KDFLG = 1 + YR(I)=ZEROR + YI(I)=ZEROI + NZ=NZ+1 + STR = CSI + CSI =-CSR + CSR = STR + IF (I.EQ.1) GO TO 80 + IF ((YR(I-1).EQ.ZEROR).AND.(YI(I-1).EQ.ZEROI)) GO TO 80 + YR(I-1)=ZEROR + YI(I-1)=ZEROI + NZ=NZ+1 + 80 CONTINUE + I = N + 85 CONTINUE + RAZR = 1.0D0/ZABS(ZRR,ZRI) + STR = ZRR*RAZR + STI = -ZRI*RAZR + RZR = (STR+STR)*RAZR + RZI = (STI+STI)*RAZR + CKR = FN*RZR + CKI = FN*RZI + IB = I + 1 + IF (N.LT.IB) GO TO 180 +C----------------------------------------------------------------------- +C TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW. SET SEQUENCE TO ZERO +C ON UNDERFLOW. +C----------------------------------------------------------------------- + FN = FNU + (N-1) + IPARD = 1 + IF (MR.NE.0) IPARD = 0 + CALL ZUNHJ(ZNR, ZNI, FN, IPARD, TOL, PHIDR, PHIDI, ARGDR, ARGDI, + * ZET1DR, ZET1DI, ZET2DR, ZET2DI, ASUMDR, ASUMDI, BSUMDR, BSUMDI) + IF (KODE.EQ.1) GO TO 90 + STR = ZBR + ZET2DR + STI = ZBI + ZET2DI + RAST = FN/ZABS(STR,STI) + STR = STR*RAST*RAST + STI = -STI*RAST*RAST + S1R = ZET1DR - STR + S1I = ZET1DI - STI + GO TO 100 + 90 CONTINUE + S1R = ZET1DR - ZET2DR + S1I = ZET1DI - ZET2DI + 100 CONTINUE + RS1 = S1R + IF (ABS(RS1).GT.ELIM) GO TO 105 + IF (ABS(RS1).LT.ALIM) GO TO 120 +C----------------------------------------------------------------------- +C REFINE ESTIMATE AND TEST +C----------------------------------------------------------------------- + APHI = ZABS(PHIDR,PHIDI) + RS1 = RS1+LOG(APHI) + IF (ABS(RS1).LT.ELIM) GO TO 120 + 105 CONTINUE + IF (RS1.GT.0.0D0) GO TO 320 +C----------------------------------------------------------------------- +C FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW +C----------------------------------------------------------------------- + IF (ZR.LT.0.0D0) GO TO 320 + NZ = N + DO 106 I=1,N + YR(I) = ZEROR + YI(I) = ZEROI + 106 CONTINUE + RETURN + 120 CONTINUE + S1R = CYR(1) + S1I = CYI(1) + S2R = CYR(2) + S2I = CYI(2) + C1R = CSRR(KFLAG) + ASCLE = BRY(KFLAG) + DO 130 I=IB,N + C2R = S2R + C2I = S2I + S2R = CKR*C2R - CKI*C2I + S1R + S2I = CKR*C2I + CKI*C2R + S1I + S1R = C2R + S1I = C2I + CKR = CKR + RZR + CKI = CKI + RZI + C2R = S2R*C1R + C2I = S2I*C1R + YR(I) = C2R + YI(I) = C2I + IF (KFLAG.GE.3) GO TO 130 + STR = ABS(C2R) + STI = ABS(C2I) + C2M = MAX(STR,STI) + IF (C2M.LE.ASCLE) GO TO 130 + KFLAG = KFLAG + 1 + ASCLE = BRY(KFLAG) + S1R = S1R*C1R + S1I = S1I*C1R + S2R = C2R + S2I = C2I + S1R = S1R*CSSR(KFLAG) + S1I = S1I*CSSR(KFLAG) + S2R = S2R*CSSR(KFLAG) + S2I = S2I*CSSR(KFLAG) + C1R = CSRR(KFLAG) + 130 CONTINUE + 180 CONTINUE + IF (MR.EQ.0) RETURN +C----------------------------------------------------------------------- +C ANALYTIC CONTINUATION FOR RE(Z).LT.0.0D0 +C----------------------------------------------------------------------- + NZ = 0 + FMR = MR + SGN = -DSIGN(PI,FMR) +C----------------------------------------------------------------------- +C CSPN AND CSGN ARE COEFF OF K AND I FUNCTIONS RESP. +C----------------------------------------------------------------------- + CSGNI = SGN + IF (YY.LE.0.0D0) CSGNI = -CSGNI + IFN = INU + N - 1 + ANG = FNF*SGN + CSPNR = COS(ANG) + CSPNI = SIN(ANG) + IF (MOD(IFN,2).EQ.0) GO TO 190 + CSPNR = -CSPNR + CSPNI = -CSPNI + 190 CONTINUE +C----------------------------------------------------------------------- +C CS=COEFF OF THE J FUNCTION TO GET THE I FUNCTION. I(FNU,Z) IS +C COMPUTED FROM EXP(I*FNU*HPI)*J(FNU,-I*Z) WHERE Z IS IN THE FIRST +C QUADRANT. FOURTH QUADRANT VALUES (YY.LE.0.0E0) ARE COMPUTED BY +C CONJUGATION SINCE THE I FUNCTION IS REAL ON THE POSITIVE REAL AXIS +C----------------------------------------------------------------------- + CSR = SAR*CSGNI + CSI = CAR*CSGNI + IN = MOD(IFN,4) + 1 + C2R = CIPR(IN) + C2I = CIPI(IN) + STR = CSR*C2R + CSI*C2I + CSI = -CSR*C2I + CSI*C2R + CSR = STR + ASC = BRY(1) + IUF = 0 + KK = N + KDFLG = 1 + IB = IB - 1 + IC = IB - 1 + DO 290 K=1,N + FN = FNU + (KK-1) +C----------------------------------------------------------------------- +C LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K +C FUNCTION ABOVE +C----------------------------------------------------------------------- + IF (N.GT.2) GO TO 175 + 172 CONTINUE + PHIDR = PHIR(J) + PHIDI = PHII(J) + ARGDR = ARGR(J) + ARGDI = ARGI(J) + ZET1DR = ZETA1R(J) + ZET1DI = ZETA1I(J) + ZET2DR = ZETA2R(J) + ZET2DI = ZETA2I(J) + ASUMDR = ASUMR(J) + ASUMDI = ASUMI(J) + BSUMDR = BSUMR(J) + BSUMDI = BSUMI(J) + J = 3 - J + GO TO 210 + 175 CONTINUE + IF ((KK.EQ.N).AND.(IB.LT.N)) GO TO 210 + IF ((KK.EQ.IB).OR.(KK.EQ.IC)) GO TO 172 + CALL ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIDR, PHIDI, ARGDR, + * ARGDI, ZET1DR, ZET1DI, ZET2DR, ZET2DI, ASUMDR, + * ASUMDI, BSUMDR, BSUMDI) + 210 CONTINUE + IF (KODE.EQ.1) GO TO 220 + STR = ZBR + ZET2DR + STI = ZBI + ZET2DI + RAST = FN/ZABS(STR,STI) + STR = STR*RAST*RAST + STI = -STI*RAST*RAST + S1R = -ZET1DR + STR + S1I = -ZET1DI + STI + GO TO 230 + 220 CONTINUE + S1R = -ZET1DR + ZET2DR + S1I = -ZET1DI + ZET2DI + 230 CONTINUE +C----------------------------------------------------------------------- +C TEST FOR UNDERFLOW AND OVERFLOW +C----------------------------------------------------------------------- + RS1 = S1R + IF (ABS(RS1).GT.ELIM) GO TO 280 + IF (KDFLG.EQ.1) IFLAG = 2 + IF (ABS(RS1).LT.ALIM) GO TO 240 +C----------------------------------------------------------------------- +C REFINE TEST AND SCALE +C----------------------------------------------------------------------- + APHI = ZABS(PHIDR,PHIDI) + AARG = ZABS(ARGDR,ARGDI) + RS1 = RS1 + LOG(APHI) - 0.25D0*LOG(AARG) - AIC + IF (ABS(RS1).GT.ELIM) GO TO 280 + IF (KDFLG.EQ.1) IFLAG = 1 + IF (RS1.LT.0.0D0) GO TO 240 + IF (KDFLG.EQ.1) IFLAG = 3 + 240 CONTINUE + CALL ZAIRY(ARGDR, ARGDI, 0, 2, AIR, AII, NAI, IDUM) + CALL ZAIRY(ARGDR, ARGDI, 1, 2, DAIR, DAII, NDAI, IDUM) + STR = DAIR*BSUMDR - DAII*BSUMDI + STI = DAIR*BSUMDI + DAII*BSUMDR + STR = STR + (AIR*ASUMDR-AII*ASUMDI) + STI = STI + (AIR*ASUMDI+AII*ASUMDR) + PTR = STR*PHIDR - STI*PHIDI + PTI = STR*PHIDI + STI*PHIDR + S2R = PTR*CSR - PTI*CSI + S2I = PTR*CSI + PTI*CSR + STR = EXP(S1R)*CSSR(IFLAG) + S1R = STR*COS(S1I) + S1I = STR*SIN(S1I) + STR = S2R*S1R - S2I*S1I + S2I = S2R*S1I + S2I*S1R + S2R = STR + IF (IFLAG.NE.1) GO TO 250 + CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) + IF (NW.EQ.0) GO TO 250 + S2R = ZEROR + S2I = ZEROI + 250 CONTINUE + IF (YY.LE.0.0D0) S2I = -S2I + CYR(KDFLG) = S2R + CYI(KDFLG) = S2I + C2R = S2R + C2I = S2I + S2R = S2R*CSRR(IFLAG) + S2I = S2I*CSRR(IFLAG) +C----------------------------------------------------------------------- +C ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N +C----------------------------------------------------------------------- + S1R = YR(KK) + S1I = YI(KK) + IF (KODE.EQ.1) GO TO 270 + CALL ZS1S2(ZRR, ZRI, S1R, S1I, S2R, S2I, NW, ASC, ALIM, IUF) + NZ = NZ + NW + 270 CONTINUE + YR(KK) = S1R*CSPNR - S1I*CSPNI + S2R + YI(KK) = S1R*CSPNI + S1I*CSPNR + S2I + KK = KK - 1 + CSPNR = -CSPNR + CSPNI = -CSPNI + STR = CSI + CSI = -CSR + CSR = STR + IF (C2R.NE.0.0D0 .OR. C2I.NE.0.0D0) GO TO 255 + KDFLG = 1 + GO TO 290 + 255 CONTINUE + IF (KDFLG.EQ.2) GO TO 295 + KDFLG = 2 + GO TO 290 + 280 CONTINUE + IF (RS1.GT.0.0D0) GO TO 320 + S2R = ZEROR + S2I = ZEROI + GO TO 250 + 290 CONTINUE + K = N + 295 CONTINUE + IL = N - K + IF (IL.EQ.0) RETURN +C----------------------------------------------------------------------- +C RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE +C K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP +C INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES. +C----------------------------------------------------------------------- + S1R = CYR(1) + S1I = CYI(1) + S2R = CYR(2) + S2I = CYI(2) + CSR = CSRR(IFLAG) + ASCLE = BRY(IFLAG) + FN = INU+IL + DO 310 I=1,IL + C2R = S2R + C2I = S2I + S2R = S1R + (FN+FNF)*(RZR*C2R-RZI*C2I) + S2I = S1I + (FN+FNF)*(RZR*C2I+RZI*C2R) + S1R = C2R + S1I = C2I + FN = FN - 1.0D0 + C2R = S2R*CSR + C2I = S2I*CSR + CKR = C2R + CKI = C2I + C1R = YR(KK) + C1I = YI(KK) + IF (KODE.EQ.1) GO TO 300 + CALL ZS1S2(ZRR, ZRI, C1R, C1I, C2R, C2I, NW, ASC, ALIM, IUF) + NZ = NZ + NW + 300 CONTINUE + YR(KK) = C1R*CSPNR - C1I*CSPNI + C2R + YI(KK) = C1R*CSPNI + C1I*CSPNR + C2I + KK = KK - 1 + CSPNR = -CSPNR + CSPNI = -CSPNI + IF (IFLAG.GE.3) GO TO 310 + C2R = ABS(CKR) + C2I = ABS(CKI) + C2M = MAX(C2R,C2I) + IF (C2M.LE.ASCLE) GO TO 310 + IFLAG = IFLAG + 1 + ASCLE = BRY(IFLAG) + S1R = S1R*CSR + S1I = S1I*CSR + S2R = CKR + S2I = CKI + S1R = S1R*CSSR(IFLAG) + S1I = S1I*CSSR(IFLAG) + S2R = S2R*CSSR(IFLAG) + S2I = S2I*CSSR(IFLAG) + CSR = CSRR(IFLAG) + 310 CONTINUE + RETURN + 320 CONTINUE + NZ = -1 + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zunk2.lo b/modules/elementary_functions/src/fortran/slatec/zunk2.lo new file mode 100755 index 000000000..8e6841a13 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zunk2.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zunk2.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zunk2.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zuoik.f b/modules/elementary_functions/src/fortran/slatec/zuoik.f new file mode 100755 index 000000000..2f1201fb9 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zuoik.f @@ -0,0 +1,207 @@ +*DECK ZUOIK + SUBROUTINE ZUOIK (ZR, ZI, FNU, KODE, IKFLG, N, YR, YI, NUF, TOL, + + ELIM, ALIM) +C***BEGIN PROLOGUE ZUOIK +C***SUBSIDIARY +C***PURPOSE Subsidiary to ZBESH, ZBESI and ZBESK +C***LIBRARY SLATEC +C***TYPE ALL (CUOIK-A, ZUOIK-A) +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C ZUOIK COMPUTES THE LEADING TERMS OF THE UNIFORM ASYMPTOTIC +C EXPANSIONS FOR THE I AND K FUNCTIONS AND COMPARES THEM +C (IN LOGARITHMIC FORM) TO ALIM AND ELIM FOR OVER AND UNDERFLOW +C WHERE ALIM.LT.ELIM. IF THE MAGNITUDE, BASED ON THE LEADING +C EXPONENTIAL, IS LESS THAN ALIM OR GREATER THAN -ALIM, THEN +C THE RESULT IS ON SCALE. IF NOT, THEN A REFINED TEST USING OTHER +C MULTIPLIERS (IN LOGARITHMIC FORM) IS MADE BASED ON ELIM. HERE +C EXP(-ELIM)=SMALLEST MACHINE NUMBER*1.0E+3 AND EXP(-ALIM)= +C EXP(-ELIM)/TOL +C +C IKFLG=1 MEANS THE I SEQUENCE IS TESTED +C =2 MEANS THE K SEQUENCE IS TESTED +C NUF = 0 MEANS THE LAST MEMBER OF THE SEQUENCE IS ON SCALE +C =-1 MEANS AN OVERFLOW WOULD OCCUR +C IKFLG=1 AND NUF.GT.0 MEANS THE LAST NUF Y VALUES WERE SET TO ZERO +C THE FIRST N-NUF VALUES MUST BE SET BY ANOTHER ROUTINE +C IKFLG=2 AND NUF.EQ.N MEANS ALL Y VALUES WERE SET TO ZERO +C IKFLG=2 AND 0.LT.NUF.LT.N NOT CONSIDERED. Y MUST BE SET BY +C ANOTHER ROUTINE +C +C***SEE ALSO ZBESH, ZBESI, ZBESK +C***ROUTINES CALLED D1MACH, ZABS, ZLOG, ZUCHK, ZUNHJ, ZUNIK +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 910415 Prologue converted to Version 4.0 format. (BAB) +C 930122 Added ZLOG to EXTERNAL statement. (RWC) +C***END PROLOGUE ZUOIK +C COMPLEX ARG,ASUM,BSUM,CWRK,CZ,CZERO,PHI,SUM,Y,Z,ZB,ZETA1,ZETA2,ZN, +C *ZR + DOUBLE PRECISION AARG, AIC, ALIM, APHI, ARGI, ARGR, ASUMI, ASUMR, + * ASCLE, AX, AY, BSUMI, BSUMR, CWRKI, CWRKR, CZI, CZR, ELIM, FNN, + * FNU, GNN, GNU, PHII, PHIR, RCZ, STR, STI, SUMI, SUMR, TOL, YI, + * YR, ZBI, ZBR, ZEROI, ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZI, + * ZNI, ZNR, ZR, ZRI, ZRR, D1MACH, ZABS + INTEGER I, IDUM, IFORM, IKFLG, INIT, KODE, N, NN, NUF, NW + DIMENSION YR(N), YI(N), CWRKR(16), CWRKI(16) + EXTERNAL ZABS, ZLOG + DATA ZEROR,ZEROI / 0.0D0, 0.0D0 / + DATA AIC / 1.265512123484645396D+00 / +C***FIRST EXECUTABLE STATEMENT ZUOIK + NUF = 0 + NN = N + ZRR = ZR + ZRI = ZI + IF (ZR.GE.0.0D0) GO TO 10 + ZRR = -ZR + ZRI = -ZI + 10 CONTINUE + ZBR = ZRR + ZBI = ZRI + AX = ABS(ZR)*1.7321D0 + AY = ABS(ZI) + IFORM = 1 + IF (AY.GT.AX) IFORM = 2 + GNU = MAX(FNU,1.0D0) + IF (IKFLG.EQ.1) GO TO 20 + FNN = NN + GNN = FNU + FNN - 1.0D0 + GNU = MAX(GNN,FNN) + 20 CONTINUE +C----------------------------------------------------------------------- +C ONLY THE MAGNITUDE OF ARG AND PHI ARE NEEDED ALONG WITH THE +C REAL PARTS OF ZETA1, ZETA2 AND ZB. NO ATTEMPT IS MADE TO GET +C THE SIGN OF THE IMAGINARY PART CORRECT. +C----------------------------------------------------------------------- + IF (IFORM.EQ.2) GO TO 30 + INIT = 0 + CALL ZUNIK(ZRR, ZRI, GNU, IKFLG, 1, TOL, INIT, PHIR, PHII, + * ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) + CZR = -ZETA1R + ZETA2R + CZI = -ZETA1I + ZETA2I + GO TO 50 + 30 CONTINUE + ZNR = ZRI + ZNI = -ZRR + IF (ZI.GT.0.0D0) GO TO 40 + ZNR = -ZNR + 40 CONTINUE + CALL ZUNHJ(ZNR, ZNI, GNU, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R, + * ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) + CZR = -ZETA1R + ZETA2R + CZI = -ZETA1I + ZETA2I + AARG = ZABS(ARGR,ARGI) + 50 CONTINUE + IF (KODE.EQ.1) GO TO 60 + CZR = CZR - ZBR + CZI = CZI - ZBI + 60 CONTINUE + IF (IKFLG.EQ.1) GO TO 70 + CZR = -CZR + CZI = -CZI + 70 CONTINUE + APHI = ZABS(PHIR,PHII) + RCZ = CZR +C----------------------------------------------------------------------- +C OVERFLOW TEST +C----------------------------------------------------------------------- + IF (RCZ.GT.ELIM) GO TO 210 + IF (RCZ.LT.ALIM) GO TO 80 + RCZ = RCZ + LOG(APHI) + IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*LOG(AARG) - AIC + IF (RCZ.GT.ELIM) GO TO 210 + GO TO 130 + 80 CONTINUE +C----------------------------------------------------------------------- +C UNDERFLOW TEST +C----------------------------------------------------------------------- + IF (RCZ.LT.(-ELIM)) GO TO 90 + IF (RCZ.GT.(-ALIM)) GO TO 130 + RCZ = RCZ + LOG(APHI) + IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*LOG(AARG) - AIC + IF (RCZ.GT.(-ELIM)) GO TO 110 + 90 CONTINUE + DO 100 I=1,NN + YR(I) = ZEROR + YI(I) = ZEROI + 100 CONTINUE + NUF = NN + RETURN + 110 CONTINUE + ASCLE = 1.0D+3*D1MACH(1)/TOL + CALL ZLOG(PHIR, PHII, STR, STI, IDUM) + CZR = CZR + STR + CZI = CZI + STI + IF (IFORM.EQ.1) GO TO 120 + CALL ZLOG(ARGR, ARGI, STR, STI, IDUM) + CZR = CZR - 0.25D0*STR - AIC + CZI = CZI - 0.25D0*STI + 120 CONTINUE + AX = EXP(RCZ)/TOL + AY = CZI + CZR = AX*COS(AY) + CZI = AX*SIN(AY) + CALL ZUCHK(CZR, CZI, NW, ASCLE, TOL) + IF (NW.NE.0) GO TO 90 + 130 CONTINUE + IF (IKFLG.EQ.2) RETURN + IF (N.EQ.1) RETURN +C----------------------------------------------------------------------- +C SET UNDERFLOWS ON I SEQUENCE +C----------------------------------------------------------------------- + 140 CONTINUE + GNU = FNU + (NN-1) + IF (IFORM.EQ.2) GO TO 150 + INIT = 0 + CALL ZUNIK(ZRR, ZRI, GNU, IKFLG, 1, TOL, INIT, PHIR, PHII, + * ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) + CZR = -ZETA1R + ZETA2R + CZI = -ZETA1I + ZETA2I + GO TO 160 + 150 CONTINUE + CALL ZUNHJ(ZNR, ZNI, GNU, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R, + * ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) + CZR = -ZETA1R + ZETA2R + CZI = -ZETA1I + ZETA2I + AARG = ZABS(ARGR,ARGI) + 160 CONTINUE + IF (KODE.EQ.1) GO TO 170 + CZR = CZR - ZBR + CZI = CZI - ZBI + 170 CONTINUE + APHI = ZABS(PHIR,PHII) + RCZ = CZR + IF (RCZ.LT.(-ELIM)) GO TO 180 + IF (RCZ.GT.(-ALIM)) RETURN + RCZ = RCZ + LOG(APHI) + IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*LOG(AARG) - AIC + IF (RCZ.GT.(-ELIM)) GO TO 190 + 180 CONTINUE + YR(NN) = ZEROR + YI(NN) = ZEROI + NN = NN - 1 + NUF = NUF + 1 + IF (NN.EQ.0) RETURN + GO TO 140 + 190 CONTINUE + ASCLE = 1.0D+3*D1MACH(1)/TOL + CALL ZLOG(PHIR, PHII, STR, STI, IDUM) + CZR = CZR + STR + CZI = CZI + STI + IF (IFORM.EQ.1) GO TO 200 + CALL ZLOG(ARGR, ARGI, STR, STI, IDUM) + CZR = CZR - 0.25D0*STR - AIC + CZI = CZI - 0.25D0*STI + 200 CONTINUE + AX = EXP(RCZ)/TOL + AY = CZI + CZR = AX*COS(AY) + CZI = AX*SIN(AY) + CALL ZUCHK(CZR, CZI, NW, ASCLE, TOL) + IF (NW.NE.0) GO TO 180 + RETURN + 210 CONTINUE + NUF = -1 + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zuoik.lo b/modules/elementary_functions/src/fortran/slatec/zuoik.lo new file mode 100755 index 000000000..24919a97d --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zuoik.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zuoik.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zuoik.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec/zwrsk.f b/modules/elementary_functions/src/fortran/slatec/zwrsk.f new file mode 100755 index 000000000..78ed02731 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zwrsk.f @@ -0,0 +1,107 @@ +*DECK ZWRSK + SUBROUTINE ZWRSK (ZRR, ZRI, FNU, KODE, N, YR, YI, NZ, CWR, CWI, + + TOL, ELIM, ALIM) +C***BEGIN PROLOGUE ZWRSK +C***SUBSIDIARY +C***PURPOSE Subsidiary to ZBESI and ZBESK +C***LIBRARY SLATEC +C***TYPE ALL (CWRSK-A, ZWRSK-A) +C***AUTHOR Amos, D. E., (SNL) +C***DESCRIPTION +C +C ZWRSK COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY +C NORMALIZING THE I FUNCTION RATIOS FROM ZRATI BY THE WRONSKIAN +C +C***SEE ALSO ZBESI, ZBESK +C***ROUTINES CALLED D1MACH, ZABS, ZBKNU, ZRATI +C***REVISION HISTORY (YYMMDD) +C 830501 DATE WRITTEN +C 910415 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE ZWRSK +C COMPLEX CINU,CSCL,CT,CW,C1,C2,RCT,ST,Y,ZR + DOUBLE PRECISION ACT, ACW, ALIM, ASCLE, CINUI, CINUR, CSCLR, CTI, + * CTR, CWI, CWR, C1I, C1R, C2I, C2R, ELIM, FNU, PTI, PTR, RACT, + * STI, STR, TOL, YI, YR, ZRI, ZRR, ZABS, D1MACH + INTEGER I, KODE, N, NW, NZ + DIMENSION YR(N), YI(N), CWR(2), CWI(2) + EXTERNAL ZABS +C***FIRST EXECUTABLE STATEMENT ZWRSK +C----------------------------------------------------------------------- +C I(FNU+I-1,Z) BY BACKWARD RECURRENCE FOR RATIOS +C Y(I)=I(FNU+I,Z)/I(FNU+I-1,Z) FROM CRATI NORMALIZED BY THE +C WRONSKIAN WITH K(FNU,Z) AND K(FNU+1,Z) FROM CBKNU. +C----------------------------------------------------------------------- +C + NZ = 0 + CALL ZBKNU(ZRR, ZRI, FNU, KODE, 2, CWR, CWI, NW, TOL, ELIM, ALIM) + IF (NW.NE.0) GO TO 50 + CALL ZRATI(ZRR, ZRI, FNU, N, YR, YI, TOL) +C----------------------------------------------------------------------- +C RECUR FORWARD ON I(FNU+1,Z) = R(FNU,Z)*I(FNU,Z), +C R(FNU+J-1,Z)=Y(J), J=1,...,N +C----------------------------------------------------------------------- + CINUR = 1.0D0 + CINUI = 0.0D0 + IF (KODE.EQ.1) GO TO 10 + CINUR = COS(ZRI) + CINUI = SIN(ZRI) + 10 CONTINUE +C----------------------------------------------------------------------- +C ON LOW EXPONENT MACHINES THE K FUNCTIONS CAN BE CLOSE TO BOTH +C THE UNDER AND OVERFLOW LIMITS AND THE NORMALIZATION MUST BE +C SCALED TO PREVENT OVER OR UNDERFLOW. CUOIK HAS DETERMINED THAT +C THE RESULT IS ON SCALE. +C----------------------------------------------------------------------- + ACW = ZABS(CWR(2),CWI(2)) + ASCLE = 1.0D+3*D1MACH(1)/TOL + CSCLR = 1.0D0 + IF (ACW.GT.ASCLE) GO TO 20 + CSCLR = 1.0D0/TOL + GO TO 30 + 20 CONTINUE + ASCLE = 1.0D0/ASCLE + IF (ACW.LT.ASCLE) GO TO 30 + CSCLR = TOL + 30 CONTINUE + C1R = CWR(1)*CSCLR + C1I = CWI(1)*CSCLR + C2R = CWR(2)*CSCLR + C2I = CWI(2)*CSCLR + STR = YR(1) + STI = YI(1) +C----------------------------------------------------------------------- +C CINU=CINU*(CONJG(CT)/ABS(CT))*(1.0D0/ABS(CT) PREVENTS +C UNDER- OR OVERFLOW PREMATURELY BY SQUARING ABS(CT) +C----------------------------------------------------------------------- + PTR = STR*C1R - STI*C1I + PTI = STR*C1I + STI*C1R + PTR = PTR + C2R + PTI = PTI + C2I + CTR = ZRR*PTR - ZRI*PTI + CTI = ZRR*PTI + ZRI*PTR + ACT = ZABS(CTR,CTI) + RACT = 1.0D0/ACT + CTR = CTR*RACT + CTI = -CTI*RACT + PTR = CINUR*RACT + PTI = CINUI*RACT + CINUR = PTR*CTR - PTI*CTI + CINUI = PTR*CTI + PTI*CTR + YR(1) = CINUR*CSCLR + YI(1) = CINUI*CSCLR + IF (N.EQ.1) RETURN + DO 40 I=2,N + PTR = STR*CINUR - STI*CINUI + CINUI = STR*CINUI + STI*CINUR + CINUR = PTR + STR = YR(I) + STI = YI(I) + YR(I) = CINUR*CSCLR + YI(I) = CINUI*CSCLR + 40 CONTINUE + RETURN + 50 CONTINUE + NZ = -1 + IF(NW.EQ.(-2)) NZ=-2 + RETURN + END diff --git a/modules/elementary_functions/src/fortran/slatec/zwrsk.lo b/modules/elementary_functions/src/fortran/slatec/zwrsk.lo new file mode 100755 index 000000000..7fe43bb67 --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec/zwrsk.lo @@ -0,0 +1,12 @@ +# src/fortran/slatec/zwrsk.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zwrsk.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/slatec_f_Import.def b/modules/elementary_functions/src/fortran/slatec_f_Import.def new file mode 100755 index 000000000..5e96710bb --- /dev/null +++ b/modules/elementary_functions/src/fortran/slatec_f_Import.def @@ -0,0 +1,5 @@ +LIBRARY slatec_f.dll + + +EXPORTS +balanc_
\ No newline at end of file diff --git a/modules/elementary_functions/src/fortran/sparse_f_Import.def b/modules/elementary_functions/src/fortran/sparse_f_Import.def new file mode 100755 index 000000000..fea109b19 --- /dev/null +++ b/modules/elementary_functions/src/fortran/sparse_f_Import.def @@ -0,0 +1,5 @@ +LIBRARY sparse_f.dll + + +EXPORTS +spreshape_
\ No newline at end of file diff --git a/modules/elementary_functions/src/fortran/split.f b/modules/elementary_functions/src/fortran/split.f new file mode 100755 index 000000000..a91a98ac4 --- /dev/null +++ b/modules/elementary_functions/src/fortran/split.f @@ -0,0 +1,133 @@ + subroutine split(a, v, n, l, e1, e2, na, nv) +c +c!purpose +c +c given the upper hessenberg matrix a with a 2x2 block +c starting at a(l,l), split determines if the +c corresponding eigenvalues are real or complex, if they +c are real, a rotation is determined that reduces the +c block to upper triangular form with the eigenvalue +c of largest absolute value appearing first. the +c rotation is accumulated in v. the eigenvalues (real +c or complex) are returned in e1 and e2. +c!calling sequence +c +c subroutine split(a, v, n, l, e1, e2, na, nv) +c +c double precision a,v,e1,e2 +c integer n,l,na,nv +c dimension a(na,n),v(nv,n) +c +c starred parameters are altered by the subroutine +c +c *a the upper hessenberg matrix whose 2x2 +c block is to be dsplit. +c *v the array in which the dsplitting trans- +c formation is to be accumulated. +c n the order of the matrix a. +c l the position of the 2x2 block. +c *e1 on return if the eigenvalues are complex +c *e2 e1 contains their common real part and +c e2 contains the positive imaginary part. +c if the eigenvalues are real. e1 contains +c the one largest in absolute value and f2 +c contains the other one. +c na the first dimension of the array a. +c nv the first dimension of the array v. +c!auxiliary routines +c abs sqrt (fortran) +c! +c originator +c + double precision a,v,e1,e2 + integer n,l,na,nv + dimension a(na,n),v(nv,n) +c internal variables +c +c internal variables + double precision p,q,r,t,u,w,x,y,z,zero,two + integer i,j,l1 + data zero, two /0.0d+0,2.0d+0/ + l1 = l + 1 +c + x = a(l1,l1) + y = a(l,l) + w = a(l,l1)*a(l1,l) + p = (y-x)/two + q = p**2 + w + if (q.ge.zero) go to 10 +c +c complex eigenvalue. +c + e1 = p + x + e2 = sqrt(-q) + return + 10 continue +c +c two real eigenvalues. set up transformation. +c + z = sqrt(q) + if (p.lt.zero) go to 20 + z = p + z + go to 30 + 20 continue + z = p - z + 30 continue + if (z.eq.zero) go to 40 + r = -w/z + go to 50 + 40 continue + r = zero + 50 continue + if (abs(x+z).ge.abs(x+r)) z = r + y = y - x - z + x = -z + t = a(l,l1) + u = a(l1,l) + if (abs(y)+abs(u).le.abs(t)+abs(x)) go to 60 + q = u + p = y + go to 70 + 60 continue + q = x + p = t + 70 continue + r = sqrt(p**2+q**2) + if (r.gt.zero) go to 80 + e1 = a(l,l) + e2 = a(l1,l1) + a(l1,l) = zero + return + 80 continue + p = p/r + q = q/r +c +c premultiply. +c + do 90 j=l,n + z = a(l,j) + a(l,j) = p*z + q*a(l1,j) + a(l1,j) = p*a(l1,j) - q*z + 90 continue +c +c postmultiply. +c + do 100 i=1,l1 + z = a(i,l) + a(i,l) = p*z + q*a(i,l1) + a(i,l1) = p*a(i,l1) - q*z + 100 continue +c +c accumulate the transformation in v. +c + do 110 i=1,n + z = v(i,l) + v(i,l) = p*z + q*v(i,l1) + v(i,l1) = p*v(i,l1) - q*z + 110 continue + a(l1,l) = zero + e1 = a(l,l) + e2 = a(l1,l1) + return + end + diff --git a/modules/elementary_functions/src/fortran/split.lo b/modules/elementary_functions/src/fortran/split.lo new file mode 100755 index 000000000..75e40f47b --- /dev/null +++ b/modules/elementary_functions/src/fortran/split.lo @@ -0,0 +1,12 @@ +# src/fortran/split.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/split.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/urand.f b/modules/elementary_functions/src/fortran/urand.f new file mode 100755 index 000000000..98b409d72 --- /dev/null +++ b/modules/elementary_functions/src/fortran/urand.f @@ -0,0 +1,80 @@ +C/MEMBR ADD NAME=URAND,SSI=0 + double precision function urand(iy) + integer iy + save +c!purpose +c +c +c URAND, A UNIVERSAL RANDOM NUMBER GENERATOR +c BY, MICHAEL A. MALCOLM, CLEVE B. MOLER, +c STAN-CS-73-334, JANUARY 1973, +c COMPUTER SCIENCE DEPARTMENT, +c School of Humanities and Sciences, STANFORD UNIVERSITY, +c ftp://reports.stanford.edu/pub/cstr/reports/cs/tr/73/334/CS-TR-73-334.pdf +c +c urand is a uniform random number generator based on theory and +c suggestions given in d.e. knuth (1969), vol 2. the integer iy +c should be initialized to an arbitrary integer prior to the first call +c to urand. the calling program should not alter the value of iy +c between subsequent calls to urand. values of urand will be returned +c in the interval (0,1). +c +c!calling sequence +c double precision function urand(iy) +c integer iy +c! +cc symbolics version +c double precision function urand(iy) +c integer iy +c lispfunction random 'cl-user::random' (integer) integer +c urand=dble(real(random(2**31)))/(dble(real(2**31))-1.0d+0) +c return +c end +cc end +c + integer ia,ic,itwo,m2,m,mic + double precision halfm,s + data m2/0/,itwo/2/ + if (m2 .ne. 0) go to 20 +c +c if first entry, compute machine integer word length +c + m = 1 + 10 m2 = m + m = itwo*m2 + if (m .gt. m2) go to 10 + halfm = m2 +c +c compute multiplier and increment for linear congruential method +c + ia = 8*nint(halfm*atan(1.0d+0)/8.0d+0) + 5 + ic = 2*nint(halfm*(0.50d+0-sqrt(3.0d+0)/6.0d+0)) + 1 + mic = (m2 - ic) + m2 +c +c s is the scale factor for converting to floating point +c + s = 0.50d+0/halfm +c +c compute next random number +c + 20 iy = iy*ia +c +c the following statement is for computers which do not allow +c integer overflow on addition +c + if (iy .gt. mic) iy = (iy - m2) - m2 +c + iy = iy + ic +c +c the following statement is for computers where the +c word length for addition is greater than for multiplication +c + if (iy/2 .gt. m2) iy = (iy - m2) - m2 +c +c the following statement is for computers where integer +c overflow affects the sign bit +c + if (iy .lt. 0) iy = (iy + m2) + m2 + urand = dble(iy)*s + return + end diff --git a/modules/elementary_functions/src/fortran/urand.lo b/modules/elementary_functions/src/fortran/urand.lo new file mode 100755 index 000000000..429f75a43 --- /dev/null +++ b/modules/elementary_functions/src/fortran/urand.lo @@ -0,0 +1,12 @@ +# src/fortran/urand.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/urand.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/vpythag.f b/modules/elementary_functions/src/fortran/vpythag.f new file mode 100755 index 000000000..f7134822b --- /dev/null +++ b/modules/elementary_functions/src/fortran/vpythag.f @@ -0,0 +1,21 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine vpythag(n,xr,xi) +c +c xr(i) = pythag(xr(i),xi(i)) + double precision xr(*),xi(*),pythag + integer n + do 10 i=1,n + xr(i) = pythag(xr(i),xi(i)) + 10 continue + return + end + + diff --git a/modules/elementary_functions/src/fortran/vpythag.lo b/modules/elementary_functions/src/fortran/vpythag.lo new file mode 100755 index 000000000..87c1ca012 --- /dev/null +++ b/modules/elementary_functions/src/fortran/vpythag.lo @@ -0,0 +1,12 @@ +# src/fortran/vpythag.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/vpythag.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wacos.f b/modules/elementary_functions/src/fortran/wacos.f new file mode 100755 index 000000000..1b64f4317 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wacos.f @@ -0,0 +1,164 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) Bruno Pincon +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + subroutine wacos(zr, zi, ar, ai) +* +* PURPOSE +* Compute the arccosine of a complex number +* a = ar + i ai = acos(z), z = zr + i zi +* +* CALLING LIST / PARAMETERS +* subroutine wacos(zr,zi,ar,ai) +* double precision zr,zi,ar,ai +* +* zr,zi: real and imaginary parts of the complex number +* ar,ai: real and imaginary parts of the result +* ar,ai may have the same memory cases than zr et zi +* +* REFERENCE +* This is a Fortran-77 translation of an algorithm by +* T.E. Hull, T. F. Fairgrieve and P.T.P. Tang which +* appears in their article : +* "Implementing the Complex Arcsine and Arccosine +* Functions Using Exception Handling", ACM, TOMS, +* Vol 23, No. 3, Sept 1997, p. 299-335 +* +* with some modifications so as don't rely on ieee handle +* trap functions. +* +* AUTHOR +* Bruno Pincon <Bruno.Pincon@iecn.u-nancy.fr> +* Thanks to Tom Fairgrieve +* + implicit none + +* PARAMETERS + double precision zr, zi, ar, ai + +* EXTERNAL FUNCTIONS + double precision dlamch, logp1 + external dlamch, logp1 + integer isanan + external isanan + +* CONSTANTS + double precision LN2, PI, HALFPI, Across, Bcross + parameter (LN2 = 0.6931471805599453094172321d0, + $ HALFPI = 1.5707963267948966192313216d0, + $ PI = 3.1415926535897932384626433d0, + $ Across = 1.5d0, + $ Bcross = 0.6417d0) +* LOCAL VARIABLES + double precision x, y, A, B, R, S, Am1, szr, szi + + +* STATIC VARIABLES + double precision LSUP, LINF, EPSM + save LSUP, LINF, EPSM + logical first + save first + data first /.true./ + +* TEXT +* got f.p. parameters used by the algorithm + if (first) then + LSUP = sqrt(dlamch('o'))/8.d0 + LINF = 4.d0*sqrt(dlamch('u')) + EPSM = sqrt(dlamch('e')) + first = .false. + endif + +* avoid memory pb ... + x = abs(zr) + y = abs(zi) + szr = sign(1.d0,zr) + szi = sign(1.d0,zi) + + + if (LINF .le. min(x,y) .and. max(x,y) .le. LSUP ) then +* we are in the safe region + R = sqrt((x+1.d0)**2 + y**2) + S = sqrt((x-1.d0)**2 + y**2) + A = 0.5d0*(R + S) + B = x/A + +* compute the real part + if ( B .le. Bcross ) then + ar = acos(B) + elseif ( x .le. 1.d0 ) then + ar = atan( sqrt( 0.5d0*(A+x) * + $ ( (y**2)/(R+(x+1.d0)) + (S+(1.d0-x)) ) ) / x ) + else + ar = atan((y*sqrt(0.5d0*((A+x)/(R+(x+1.d0)) + $ +(A+x)/(S+(x-1.d0))))) / x) + endif + +* compute the imaginary part + if ( A .le. Across ) then + if ( x .lt. 1.d0 ) then + Am1 = 0.5d0*((y**2)/(R+(x+1.d0))+(y**2)/(S+(1.d0-x))) + else + Am1 = 0.5d0*((y**2)/(R+(x+1.d0))+(S+(x-1.d0))) + endif + ai = logp1(Am1 + sqrt(Am1*(A+1.d0))) + else + ai = log(A + sqrt(A**2 - 1.d0)) + endif + + else +* HANDLE BLOC : evaluation in the special regions ... + if ( y .le. EPSM*abs(x-1.d0) ) then + if (x .lt. 1.d0 ) then + ar = acos(x) + ai = y/sqrt((1.d0+x)*(1.d0-x)) + else + ar = 0.d0 + if ( x .le. LSUP ) then + ai = logp1((x-1.d0) + sqrt((x-1.d0)*(x+1.d0))) + else + ai = LN2 + log(x) + endif + endif + elseif (y .lt. LINF) then + if (isanan(x).eq.1) then + ar = x + ai = y + else + ar = sqrt(y) + ai = ar + endif + elseif (EPSM*y - 1.d0 .ge. x) then + ar = HALFPI + ai = LN2 + log(y) + elseif (x .gt. 1.d0) then + ar = atan(y/x) + ai = LN2 + log(y) + 0.5d0*logp1((x/y)**2) + else + if (isanan(x).eq.1) then + ar = x + else + ar = HALFPI + endif + A = sqrt(1.d0 + y**2) + ai = 0.5d0*logp1(2.d0*y*(y+A)) + endif + endif + +* recover the signs + if (szr .lt. 0.d0) then + ar = PI - ar + endif + + if (y.ne.0.d0 .or. szr.lt.0.d0) then + ai = - szi * ai + endif + + end + + diff --git a/modules/elementary_functions/src/fortran/wacos.lo b/modules/elementary_functions/src/fortran/wacos.lo new file mode 100755 index 000000000..7365c88fd --- /dev/null +++ b/modules/elementary_functions/src/fortran/wacos.lo @@ -0,0 +1,12 @@ +# src/fortran/wacos.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wacos.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wasin.f b/modules/elementary_functions/src/fortran/wasin.f new file mode 100755 index 000000000..c1a7e58d4 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wasin.f @@ -0,0 +1,160 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine wasin(zr, zi, ar, ai) +* +* PURPOSE +* Compute the arcsin of a complex number +* a = ar + i ai = asin(z), z = zr + i zi +* +* CALLING LIST / PARAMETERS +* subroutine wasin(zr,zi,ar,ai) +* double precision zr,zi,ar,ai +* +* zr,zi: real and imaginary parts of the complex number +* ar,ai: real and imaginary parts of the result +* ar,ai may have the same memory cases than zr et zi +* +* REFERENCE +* This is a Fortran-77 translation of an algorithm by +* T.E. Hull, T. F. Fairgrieve and P.T.P. Tang which +* appears in their article : +* "Implementing the Complex Arcsine and Arccosine +* Functions Using Exception Handling", ACM, TOMS, +* Vol 23, No. 3, Sept 1997, p. 299-335 +* +* with some modifications so as don't rely on ieee handle +* trap functions. +* +* AUTHOR +* Bruno Pincon <Bruno.Pincon@iecn.u-nancy.fr> +* Thanks to Tom Fairgrieve +* + implicit none + +* PARAMETERS + double precision zr, zi, ar, ai + +* EXTERNAL FUNCTIONS + double precision dlamch, logp1 + external dlamch, logp1 + integer isanan + external isanan + +* CONSTANTS + double precision LN2, HALFPI, Across, Bcross + parameter (LN2 = 0.6931471805599453094172321d0, + $ HALFPI = 1.5707963267948966192313216d0, + $ Across = 1.5d0, + $ Bcross = 0.6417d0) + +* LOCAL VARIABLES + double precision x, y, A, B, R, S, Am1, szr, szi + + +* STATIC VARIABLES + double precision LSUP, LINF, EPSM + save LSUP, LINF, EPSM + logical first + save first + data first /.true./ +* TEXT +* got f.p. parameters used by the algorithm + if (first) then + LSUP = sqrt(dlamch('o'))/8.d0 + LINF = 4.d0*sqrt(dlamch('u')) + EPSM = sqrt(dlamch('e')) + first = .false. + endif + +* avoid memory pb ... + x = abs(zr) + y = abs(zi) + szr = sign(1.d0,zr) + szi = sign(1.d0,zi) + + + if (LINF .le. min(x,y) .and. max(x,y) .le. LSUP ) then +* we are in the safe region + R = sqrt((x+1.d0)**2 + y**2) + S = sqrt((x-1.d0)**2 + y**2) + A = 0.5d0*(R + S) + B = x/A + +* compute the real part + if ( B .le. Bcross ) then + ar = asin(B) + elseif ( x .le. 1.d0 ) then + ar = atan( x / sqrt( + $ 0.5d0*(A+x)*((y**2)/(R+(x+1.d0))+(S+(1.d0-x)))) ) + else + ar = atan( x / + $ (y*sqrt(0.5d0*((A+x)/(R+(x+1.d0))+(A+x)/(S+(x-1.d0)))))) + endif + +* compute the imaginary part + if ( A .le. Across ) then + if ( x .lt. 1.d0 ) then + Am1 = 0.5d0*((y**2)/(R+(x+1.d0))+(y**2)/(S+(1.d0-x))) + else + Am1 = 0.5d0*((y**2)/(R+(x+1.d0))+(S+(x-1.d0))) + endif + ai = logp1(Am1 + sqrt(Am1*(A+1.d0))) + else + ai = log(A + sqrt(A**2 - 1.d0)) + endif + + else +* HANDLE BLOC : evaluation in the special regions ... + if ( y .le. EPSM*abs(x-1.d0) ) then + if (x .lt. 1.d0 ) then + ar = asin(x) + ai = y/sqrt((1.d0+x)*(1.d0-x)) + else + ar = HALFPI + if ( x .le. LSUP ) then + ai = logp1((x-1.d0) + sqrt((x-1.d0)*(x+1.d0))) + else + ai = LN2 + log(x) + endif + endif + + elseif (y .lt. LINF) then + if (isanan(x).eq.1) then + ar = x + else + ar = HALFPI - sqrt(y) + endif + ai = sqrt(y) + + elseif (EPSM*y - 1.d0 .ge. x) then + ar = x/y + ai = LN2 + log(y) + + elseif (x .gt. 1.d0) then + ar = atan(x/y) + ai = LN2 + log(y) + 0.5d0*logp1((x/y)**2) + + else + A = sqrt(1 + y**2) + ar = x/A + ai = 0.5*logp1(2.d0*y*(y+A)) + endif + endif + +* recover the signs + ar = szr * ar + if (y.eq.0d00 .and. szr.gt.0d00) then + szi = - szi + endif + ai = szi * ai + + end + + diff --git a/modules/elementary_functions/src/fortran/wasin.lo b/modules/elementary_functions/src/fortran/wasin.lo new file mode 100755 index 000000000..af786b56f --- /dev/null +++ b/modules/elementary_functions/src/fortran/wasin.lo @@ -0,0 +1,12 @@ +# src/fortran/wasin.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wasin.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wasum.f b/modules/elementary_functions/src/fortran/wasum.f new file mode 100755 index 000000000..6ef1c9e75 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wasum.f @@ -0,0 +1,39 @@ +C/MEMBR ADD NAME=WASUM,SSI=0 + double precision function wasum(n,xr,xi,incx) +c!but +c +c cette fonction determine la addition des normes l1 des +c composantes d'un vecteur complexe dont les parties reelles +c sont rangees dans le vecteur double precision xr et les +c parties imaginaires dans le vecteur double precision xi. +c +c!liste d'appel +c +c double precision function wasum(n,xr,xi,incx) +c +c n: entier, taille du vecteur traite +c +c xr, xi: vecteurs double precision contenant, +c respectivement, les parties reelles et imaginaires du +c vecteur traite. +c +c incx: increment entre deux composantes consecutives des +c vecteurs xr ou xi. +c +c!auteur +c +c cleve moler.- matlab. +c +c! + double precision xr(*),xi(*),s +c norm1(x) + s = 0.0d+0 + if (n .le. 0) go to 20 + ix = 1 + do 10 i = 1, n + s = s + abs(xr(ix)) + abs(xi(ix)) + ix = ix + incx + 10 continue + 20 wasum = s + return + end diff --git a/modules/elementary_functions/src/fortran/wasum.lo b/modules/elementary_functions/src/fortran/wasum.lo new file mode 100755 index 000000000..5f7528f65 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wasum.lo @@ -0,0 +1,12 @@ +# src/fortran/wasum.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wasum.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/watan.f b/modules/elementary_functions/src/fortran/watan.f new file mode 100755 index 000000000..2ffe21009 --- /dev/null +++ b/modules/elementary_functions/src/fortran/watan.f @@ -0,0 +1,352 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) Bruno Pincon +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine watan(xr,xi,yr,yi) +c +c PURPOSE +c watan compute the arctangent of a complex number +c y = yr + i yi = atan(x), x = xr + i xi +c +c CALLING LIST / PARAMETERS +c subroutine watan(xr,xi,yr,yi) +c double precision xr,xi,yr,yi +c +c xr,xi: real and imaginary parts of the complex number +c yr,yi: real and imaginary parts of the result +c yr,yi may have the same memory cases than xr et xi +c +c COPYRIGHT (C) 2001 Bruno Pincon and Lydia van Dijk +c Written by Bruno Pincon <Bruno.Pincon@iecn.u-nancy.fr> so +c as to get more precision. Also to fix the +c behavior at the singular points and at the branch cuts. +c Polished by Lydia van Dijk +c <lvandijk@hammersmith-consulting.com> +c +c CHANGES : - (Bruno on 2001 May 22) for ysptrk use a +c minimax polynome to enlarge the special +c evaluation zone |s| < SLIM. Also rename +c this function as lnp1m1. +c - (Bruno on 2001 June 7) better handling +c of spurious over/underflow ; remove +c the call to pythag ; better accuracy +c in the real part for z near +-i +c +c EXTERNALS FUNCTIONS +c dlamch +c lnp1m1 (at the end of this file) +c +c ALGORITHM : noting z = a + i*b, we have: +c Z = yr + yi*b = arctan(z) = (i/2) * log( (i+z)/(i-z) ) +c +c This function has two branch points at +i and -i and the +c chosen branch cuts are the two half-straight lines +c D1 = [i, i*oo) and D2 = (-i*oo, i]. The function is then +c analytic in C \ (D1 U D2)). +c +c From the definition it follows that: +c +c yr = 0.5 Arg ( (i+z)/(i-z) ) (1) +c yi = 0.5 log (|(i+z)/(i-z)|) (2) +c +c so lim (z -> +- i) yr = undefined (and Nan is logical) +c lim (z -> +i) yi = +oo +c lim (z -> -i) yi = -oo +c +c The real part of arctan(z) is discontinuous across D1 and D2 +c and we impose the following definitions: +c if imag(z) > 1 then +c Arg(arctan(z)) = pi/2 (=lim real(z) -> 0+) +c if imag(z) < 1 then +c Arg(arctan(z)) = -pi/2 (=lim real(z) -> 0-) +c +c +c Basic evaluation: if we write (i+z)/(i-z) using +c z = a + i*b, we get: +c +c i+z 1-(a**2+b**2) + i*(2a) +c --- = ---------------------- +c i-z a**2 + (1-b)**2 +c +c then, with r2 = |z|^2 = a**2 + b**2 : +c +c yr = 0.5 * Arg(1-r2 + (2*a)*i) +c = 0.5 * atan2(2a, (1-r2)) (3) +c +c This formula is changed when r2 > RMAX (max pos float) +c and also when |1-r2| and |a| are near 0 (see comments +c in the code). +c +c After some math: +c +c yi = 0.25 * log( (a**2 + (b + 1)**2) / +c (a**2 + (b - 1)**2) ) (4) +c +c Evaluation for "big" |z| +c ------------------------ +c +c If |z| is "big", the direct evaluation of yi by (4) may +c suffer of innaccuracies and of spurious overflow. Noting +c that s = 2 b / (1 + |z|**2), we have: +c +c yi = 0.25 log ( (1 + s)/(1 - s) ) (5) +c +c 3 5 +c yi = 0.25*( 2 * ( s + 1/3 s + 1/5 s + ... )) +c +c yi = 0.25 * lnp1m1(s) if |s| < SLIM +c +c So if |s| is less than SLIM we switch to a special +c evaluation done by the function lnp1m1. The +c threshold value SLIM is chosen by experiment +c (with the Pari-gp software). For |s| +c "very small" we used a truncated taylor dvp, +c else a minimax polynome (see lnp1m1). +c +c To avoid spurious overflows (which result in spurious +c underflows for s) in computing s with s= 2 b / (1 + |z|**2) +c when |z|^2 > RMAX (max positive float) we use : +c +c s = 2d0 / ( (a/b)*a + b ) +c +c but if |b| = Inf this formula leads to NaN when +c |a| is also Inf. As we have : +c +c |s| <= 2 / |b| +c +c we impose simply : s = 0 when |b| = Inf +c +c Evaluation for z very near to i or -i: +c -------------------------------------- +c Floating point numbers of the form a+i or a-i with 0 < +c a**2 < tiny (approximately 1d-308) may lead to underflow +c (i.e., a**2 = 0) and the logarithm will break formula (4). +c So we switch to the following formulas: +c +c If b = +-1 and |a| < sqrt(tiny) approximately 1d-150 (say) +c then (by using that a**2 + 4 = 4 in machine for such a): +c +c yi = 0.5 * log( 2/|a| ) for b=1 +c +c yi = 0.5 * log( |a|/2 ) for b=-1 +c +c finally: yi = 0.5 * sign(b) * log( 2/|a| ) +c yi = 0.5 * sign(b) * (log(2) - log(|a|)) (6) +c +c The last trick is to avoid overflow for |a|=tiny! In fact +c this formula may be used until a**2 + 4 = 4 so that the +c threshold value may be larger. +c + implicit none +c + include 'stack.h' +c + double precision xr, xi, yr, yi + +c EXTERNAL + external dlamch, lnp1m1 + double precision dlamch, lnp1m1 +c + double precision a, b, r2, s, SLIM, ALIM, TOL, LN2 + parameter (SLIM = 0.2d0, + $ ALIM = 1.d-150, + $ TOL = 0.3d0, + $ LN2 = 0.69314718055994531d0) + +c STATIC VAR + logical first + double precision RMAX, HALFPI + + save first + data first /.true./ + save RMAX, HALFPI + + if (first) then + RMAX = dlamch('O') + first = .false. + HALFPI = 2.d0*atan(1.d0) + endif + +c Avoid problems due to sharing the same memory locations by +c xr, yr and xi, yi. + a = xr + b = xi +c + if (b .eq. 0d0) then +c z is real + yr = atan(xr) + yi = 0d0 + else +c z is complex +c (1) Compute the imaginary part of arctan(z) + r2 = a*a + b*b + if (r2 .gt. RMAX) then + if ( abs(b) .gt. RMAX ) then +c |b| is Inf => s = 0 + s = 0.d0 + else +c try to avoid the spurious underflow in s when |b| is not +c negligible with respect to |a| + s = 1d0 / ( ((0.5d0*a)/b)*a + 0.5d0*b ) + endif + else + s = 2d0*b / (1d0 + r2) + endif + + if (abs(s) .lt. SLIM) then +c s is small: |s| < SLIM <=> |z| outside the following disks: +c D+ = D(center = [0; 1/slim], radius = sqrt(1/slim**2 - 1)) if b > 0 +c D- = D(center = [0; -1/slim], radius = sqrt(1/slim**2 - 1)) if b < 0 +c use the special evaluation of log((1+s)/(1-s)) (5) + yi = 0.25d0*lnp1m1(s) + else +c |s| >= SLIM => |z| is inside D+ or D- + if ((abs(b) .eq. 1d0) .and. (abs(a) .le. ALIM)) then +c z is very near +- i : use formula (6) + yi = sign(0.5d0, b) * (LN2 - log(abs(a))) + else +c use formula (4) + yi = 0.25d0 * log( (a*a + (b + 1d0)*(b + 1d0)) / + $ (a*a + (b - 1d0)*(b - 1d0)) ) + endif + endif + +c (2) Compute the real part of arctan(z) + if (a .eq. 0d0) then +c z is purely imaginary + if (abs(b) .gt. 1d0) then +c got sign(b) * pi/2 + yr = sign(1d0,b) * HALFPI + elseif (abs(b) .eq. 1d0) then +c got a Nan with 0/0 + yr = (a - a) / (a - a) + else + yr = 0d0 + endif + elseif (r2 .gt. RMAX) then +c yr is necessarily very near sign(a)* pi/2 + yr = sign(1.d0, a) * HALFPI + elseif ( abs(1.d0 - r2) + abs(a) .le.TOL ) then +c |b| is very near 1 (and a is near 0) some +c cancellation occur in the (next) generic formula + yr = 0.5d0 * atan2(2d0*a, (1.d0-b)*(1.d0+b) - a*a) + else +c generic formula + yr = 0.5d0 * atan2(2d0*a, 1d0 - r2) + endif + endif + end + + + double precision function lnp1m1(s) + implicit none + double precision s +c +c PURPOSE : Compute v = log ( (1 + s)/(1 - s) ) +c for small s, this is for |s| < SLIM = 0.20 +c +c ALGORITHM : +c 1/ if |s| is "very small" we use a truncated +c taylor dvp (by keeping 3 terms) from : +c 2 4 6 +c t = 2 * s * ( 1 + 1/3 s + 1/5 s + [ 1/7 s + ....] ) +c 2 4 +c t = 2 * s * ( 1 + 1/3 s + 1/5 s + er) +c +c The limit E until we use this formula may be simply +c gotten so that the negliged part er is such that : +c 2 4 +c (#) er <= epsm * ( 1 + 1/3 s + 1/5 s ) for all |s|<= E +c +c As er = 1/7 s^6 + 1/9 s^8 + ... +c er <= 1/7 * s^6 ( 1 + s^2 + s^4 + ...) = 1/7 s^6/(1-s^2) +c +c the inequality (#) is forced if : +c +c 1/7 s^6 / (1-s^2) <= epsm * ( 1 + 1/3 s^2 + 1/5 s^4 ) +c +c s^6 <= 7 epsm * (1 - 2/3 s^2 - 3/15 s^4 - 1/5 s^6) +c +c So that E is very near (7 epsm)^(1/6) (approximately 3.032d-3): +c +c 2/ For larger |s| we used a minimax polynome : +c +c yi = s * (2 + d3 s^3 + d5 s^5 .... + d13 s^13 + d15 s^15) +c +c This polynome was computed (by some remes algorithm) following +c (*) the sin(x) example (p 39) of the book : +c +c "ELEMENTARY FUNCTIONS" +c "Algorithms and implementation" +c J.M. Muller (Birkhauser) +c +c (*) without the additional raffinement to get the first coefs +c very near floating point numbers) +c + double precision s2 + double precision E, C3, C5 + parameter (E = 3.032d-3, C3 = 2d0 / 3d0, C5 = 2d0 / 5d0) + +c minimax poly coefs + double precision D3, D5, D7, D9, D11, D13, D15 + parameter ( + $ D3 = 0.66666666666672679472d0, D5 = 0.39999999996176889299d0, + $ D7 = 0.28571429392829380980d0, D9 = 0.22222138684562683797d0, + $ D11= 0.18186349187499222459d0, D13= 0.15250315884469364710d0, + $ D15= 0.15367270224757008114d0 ) + + s2 = s * s + if (abs(s) .le. E) then + lnp1m1 = s * (2d0 + s2*(C3 + C5*s2)) + else + lnp1m1 = s * (2.d0 + s2*(D3 + s2*(D5 + s2*( + $ D7 + s2*(D9 + s2*(D11 + s2*(D13 + s2*D15))))))) + endif + end + +c +c a log(1+x) function for scilab .... +c +c + double precision function logp1(x) + implicit none + double precision x + + double precision g + double precision a, b + parameter ( a = -1d0/3d0, + $ b = 0.5d0 ) + + double precision lnp1m1 + external lnp1m1 + + if ( x .lt. -1.d0 ) then +c got NaN + logp1 = (x - x)/(x - x) + elseif ( a .le. x .and. x .le. b ) then +c use the function log((1+g)/(1-g)) with g = x/(x + 2) + g = x/(x + 2.d0) + logp1 = lnp1m1(g) + else +c use the standard formula + logp1 = log(x + 1.d0) + endif + + end + + + + + + + + + + + + diff --git a/modules/elementary_functions/src/fortran/watan.lo b/modules/elementary_functions/src/fortran/watan.lo new file mode 100755 index 000000000..8cafbb5c7 --- /dev/null +++ b/modules/elementary_functions/src/fortran/watan.lo @@ -0,0 +1,12 @@ +# src/fortran/watan.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/watan.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/waxpy.f b/modules/elementary_functions/src/fortran/waxpy.f new file mode 100755 index 000000000..44cfd6c52 --- /dev/null +++ b/modules/elementary_functions/src/fortran/waxpy.f @@ -0,0 +1,52 @@ +C/MEMBR ADD NAME=WAXPY,SSI=0 + subroutine waxpy(n,sr,si,xr,xi,incx,yr,yi,incy) +c!but +c +c cette subroutine multiplie la constante complexe double +c precision s (dont la partie reelle est sr et la partie +c imaginaire si) par le vecteur complexe double precision +c (dont les parties reelles de ses composantes sont dans +c le vecteur double precision xr). le produit ainsi +c obtenu est additionne au vecteur complexe y (dont les +c parties reelles de ses composantes sont rangees dans le +c vecteur double precision yr et les parties imaginaires +c dans le vecteur double precision yr). le resultat de +c l'addition reste dans y. +c +c!liste d'appel +c +c subroutine waxpy(n,sr,si,xr,xi,incx,yr,yi,incy) +c +c n: entier, taille des vecteurs traites +c +c sr, si: double precision, parties reel et imaginaire de s +c +c xr, xi: vecteurs double precision, parties rellees et +c imaginaires, respectivement du vecteur complexe x. +c +c yr, yi: vecteurs double precision, parties rellees et +c imaginaires, respectivement du vecteur complexe y. +c +c incx, incy: entiers, increments entre deux composantes +c successives des vecteurs x et y. +c +c!auteur +c +c cleve moler.- matlab. +c +c! + double precision sr,si,xr(*),xi(*),yr(*),yi(*) + if (n .le. 0) return + if (sr .eq. 0.0d+0 .and. si .eq. 0.0d+0) return + 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 + yr(iy) = yr(iy) + sr*xr(ix) - si*xi(ix) + yi(iy) = yi(iy) + sr*xi(ix) + si*xr(ix) + ix = ix + incx + iy = iy + incy + 10 continue + return + end diff --git a/modules/elementary_functions/src/fortran/waxpy.lo b/modules/elementary_functions/src/fortran/waxpy.lo new file mode 100755 index 000000000..75ef89ac9 --- /dev/null +++ b/modules/elementary_functions/src/fortran/waxpy.lo @@ -0,0 +1,12 @@ +# src/fortran/waxpy.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/waxpy.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wbdiag.f b/modules/elementary_functions/src/fortran/wbdiag.f new file mode 100755 index 000000000..85c107ebd --- /dev/null +++ b/modules/elementary_functions/src/fortran/wbdiag.f @@ -0,0 +1,427 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine wbdiag(lda,n,ar,ai,rmax,er,ei,bs,xr,xi, + * yr,yi,scale,job,fail) +c +c!purpose +c wbdiag reduces a matrix a to block diagonal form by first +c reducing it to triangular form by comqr3 and then by +c solving the matrix equation -a11*p+p*a22=a12 to introduce zeros +c above the diagonal. +c right transformation is factored : p*d*u*y ;where: +c p is a permutation matrix and d positive diagonal matrix, +c p and d are given by scale +c u is orthogonal and y block upper triangular with identity +c blocks on the diagonal +c +c!calling sequence +c +c subroutine wbdiag(lda,n,ar,ai,rmaxr,er,ei,bs,xr,xi, +c * yr,yi,scale,job,fail) +c +c integer lda, n, bs, job +c double precision ar,ai,er,ei,xr,xi,yr,yi,rmax,scale(n) +c dimension ar(lda,n),ai(lda,n) +c dimension xr(lda,n),xi(lda,n),yr(lda,n),yi(lda,n), +c er(n),ei(n),bs(n) +c logical fail +c +c starred parameters are altered by the subroutine +c +c +c *ar,ai an array that initially contains the n x n matrix +c to be reduced. on return, see job +c +c lda the leading dimension of array a. and array x,y. +c +c n the order of the matrices a,x,y +c +c rmax the maximum size allowed for any element of the +c transformations. +c +c *er a singly subscripted real array containing the real +c parts of the eigenvalues. +c +c *ei a singly subscripted real array containg the imaginary +c parts of the eigenvalues. +c +c *bs a singly subscripted integer array that contains block +c structure information. if there is a block of order +c k starting at a(l,l) in the output matrix a, then +c bs(l) contains the positive integer k, bs(l+1) contains +c -(k-1), bs(l+2) = -(k-2), ..., bs(l+k-1) = -1. +c thus a positive integer in the l-th entry of bs +c indicates a new block of order bs(l) starting at a(l,l). +c +c *xr,xi contains, either right reducing transformation u*y, +c either orthogonal tranformation u (see job) +c +c *yr,yi contains the inverse reducing matrix transformation +c or y matrix (see job) +c +c *scale contains the scale factor and definitions of p and d +c size(n) +c +c job integer parametre specifying outputed transformations +c job=0 : a contains block diagonal form +c x right transformation +c y dummy variable +c job=1:like job=0 and y contain x**-1 +c job=2 a contains block diagonal form +c x contains u and y contain y +c job=3: a contains: +c -block diagonal form in the diagonal blocks +c -a factorization of y in the upper triangular +c x contains u +c y dummy +c *fail a logical variable which is false on normal return and +c true if there is any error in wbdiag. +c +c +c!auxiliary routines +c corth cortr comqr3 cbal balbak (eispack) +c wexchn (eispack.extensions) +c dset ddot (blas) +c wshrsl dad +c + integer lda, n, bs, job + double precision ar,ai,er,ei,xr,xi,yr,yi,rmax,scale(n) + dimension ar(lda,n),ai(lda,n),xr(lda,n),xi(lda,n) + dimension yr(lda,n),yi(lda,n),er(n),ei(n),bs(n) + logical fail,fails +c + double precision c,cav,d,rav,temp,zero,one,mone,ddot,eps + double precision dlamch + integer da11,da22,i,j,k,km1,l11,l22,l22m1,err + integer low,igh +c character*100 cw +c integer iw(200) + data zero, one, mone /0.0d+0,1.0d+0,-1.0d+0/ +c +c + fail = .true. +c +c compute l1 norm of a +c + eps=0.0d0 + do 11 j=1,n + temp=0.0d0 + do 10 i=1,n + temp=temp+abs(ar(i,j))+abs(ai(i,j)) + 10 continue + eps=max(eps,temp) + 11 continue + if (eps.eq.0.0d0) eps=1.0d0 + eps=dlamch('p')*eps +c +c convert a to upper hessenberg form. +c + call cbal(lda,n,ar,ai,low,igh,scale) + call corth(lda,n,1,n,ar,ai,er,ei) + call cortr(lda, n, 1, n, ar, ai, er, ei, xr, xi) +c +c convert a to upper triangular form by qr method. +c + call comqr3(lda,n,1,n,ar,ai,er,ei,xr,xi,err,11) +c +c check to see if comqr3 failed in computing any eigenvalue +c +c + if(err.gt.1) go to 600 +c +c reduce a to block diagonal form +c +c segment a into 4 matrices: a11, a 1 x 1 block +c whose (1,1)-element is at a(l11,l11)) a22, a 1 x 1 +c block whose (1,1)-element is at a(l22,l22)) a12, +c a 1 x 1 block whose (1,1)-element is at a(l11,l22)) +c and a21, a 1 x 1 block = 0 whose (1,1)- +c element is at a(l22,l11). +c +c +c +c this loop uses l11 as loop index and splits off a block +c starting at a(l11,l11). +c +c + l11 = 1 + 40 continue +c call wmdsp(ar,ai,n,n,n,10,1,80,6,cw,iw) + if (l11.gt.n) go to 350 + l22 = l11 +c +c this loop uses da11 as loop variable and attempts to split +c off a block of size da11 starting at a(l11,l11) +c + 50 continue + if (l22.ne.l11) go to 60 + da11 = 1 + l22 = l11 + 1 + l22m1 = l22 - 1 + go to 240 + 60 continue +c +c +c compute the average of the eigenvalues in a11 +c + rav = zero + cav = zero + do 70 i=l11,l22m1 + rav = rav + er(i) + cav = cav + abs(ei(i)) + 70 continue + rav = rav/dble(real(da11) ) + cav = cav/dble(real(da11) ) +c +c loop on eigenvalues of a22 to find the one closest to the av +c + d = (rav-er(l22))**2 + (cav-ei(l22))**2 + k = l22 + l = l22 + 1 + 80 continue + if (l.gt.n) go to 100 + c = (rav-er(l))**2 + (cav-ei(l))**2 + if (c.ge.d) go to 90 + k = l + d = c + 90 continue + l = l + 1 + go to 80 + 100 continue +c +c +c loop to move the eigenvalue just located +c into first position of block a22. +c +c +c the block we're moving to add to a11 is a 1 x 1 +c + 110 continue + if (k.eq.l22) go to 230 + km1 = k - 1 + call wexchn(ar,ai,xr,xi,n, km1, fail, lda, lda) + if (fail) go to 600 + temp = er(k) + er(k) = er(km1) + er(km1) = temp + temp = ei(k) + ei(k) = ei(km1) + ei(km1) = temp + k = km1 + if (k.le.l22) go to 230 + go to 110 +c + 230 continue + da11 = da11 + 1 + l22 = l11 + da11 + l22m1 = l22 - 1 + 240 continue + if (l22.gt.n) go to 290 +c +c attempt to split off a block of size da11. +c + da22 = n - l22 + 1 +c +c save a12 in its transpose form in block a21. +c + do 260 j=l11,l22m1 + do 250 i=l22,n + ar(i,j) = ar(j,i) + ai(i,j) = ai(j,i) + 250 continue + 260 continue +c +c +c convert a11 to lower quasi-triangular and multiply it by -1 and +c a12 appropriately (for solving -a11*p+p*a22=a12). +c +c write(6,'(''da11='',i2,''da22='',i2)') da11,da22 +c write(6,'(''a'')') +c call wmdsp(ar,ai,n,n,n,10,1,80,6,cw,iw) + call dad(ar, lda, l11, l22m1, l11, n, one, 0) + call dad(ar, lda, l11, l22m1, l11, l22m1, mone, 1) + call dad(ai, lda, l11, l22m1, l11, n, one, 0) + call dad(ai, lda, l11, l22m1, l11, l22m1, mone, 1) +c +c solve -a11*p + p*a22 = a12. +c + call wshrsl(ar(l11,l11),ai(l11,l11), ar(l22,l22),ai(l22,l22), + 1 ar(l11,l22),ai(l11,l22),da11,da22,lda,lda,lda,eps,rmax,fails) + if (.not.fails) go to 290 +c +c change a11 back to upper quasi-triangular. +c + call dad(ar, lda, l11, l22m1, l11, l22m1, one, 1) + call dad(ar, lda, l11, l22m1, l11, l22m1, mone, 0) + call dad(ai, lda, l11, l22m1, l11, l22m1, one, 1) + call dad(ai, lda, l11, l22m1, l11, l22m1, mone, 0) +c write(6,'(''failed a'')') +c call wmdsp(ar,ai,n,n,n,10,1,80,6,cw,iw) +c +c was unable to solve for p - try again +c +c +c move saved a12 back into its correct position. +c + do 280 j=l11,l22m1 + do 270 i=l22,n + ar(j,i) = ar(i,j) + ar(i,j) = zero + ai(j,i) = ai(i,j) + ai(i,j) = zero + 270 continue + 280 continue +c +c + go to 50 + 290 continue +c +c change solution to p to proper form. +c + if (l22.gt.n) go to 300 + call dad(ar, lda, l11, l22m1, l11, n, one, 0) + call dad(ar, lda, l11, l22m1, l11, l22m1, mone, 1) + call dad(ai, lda, l11, l22m1, l11, n, one, 0) + call dad(ai, lda, l11, l22m1, l11, l22m1, mone, 1) +c write(6,'(''not failed a'')') +c call wmdsp(ar,ai,n,n,n,10,1,80,6,cw,iw) +c +c +c store block size in array da11s. +c + 300 bs(l11) = da11 + j = da11 - 1 + if (j.eq.0) go to 320 + do 310 i=1,j + l11pi = l11 + i + bs(l11pi) = -(da11-i) + 310 continue + 320 continue + l11 = l22 + go to 40 + 350 continue + fail=.false. +c +c set transformations matrices as required +c + if(job.eq.3) return +c +c compute inverse transformation + if(job.ne.1) goto 450 + do 410 i=1,n + do 410 j=1,n + yr(i,j)=xr(j,i) + yi(i,j)=-xi(j,i) + 410 continue + l22=1 + 420 l11=l22 + l22=l11+bs(l11) + if(l22.gt.n) goto 431 + l22m1=l22-1 + do 430 i=l11,l22m1 + do 430 j=1,n + yr(i,j)=yr(i,j)-ddot(n-l22m1,ar(i,l22),lda,yr(l22,j),1) + 1 +ddot(n-l22m1,ai(i,l22),lda,yi(l22,j),1) + yi(i,j)=yi(i,j)-ddot(n-l22m1,ar(i,l22),lda,yi(l22,j),1) + 1 -ddot(n-l22m1,ai(i,l22),lda,yr(l22,j),1) + 430 continue + goto 420 +c +c in-lines back-tranfc in-lines right transformations of xi + 431 continue + if (igh .ne. low) then + do 435 j=low,igh + temp=1.0d+00/scale(j) + do 434 i=1,n + yr(i,j)=yr(i,j)*temp + yi(i,j)=yi(i,j)*temp + 434 continue + 435 continue + endif + do 445 ii=1,n + i=ii + if (i.ge.low .and. i.le.igh) goto 445 + if (i.lt.low) i=low-ii + k=scale(i) + if (k.eq.i) goto 445 + do 444 j=1,n + temp=yr(j,i) + yr(j,i)=yr(j,k) + yr(j,k)=temp + temp=yi(j,i) + yi(j,i)=yi(j,k) + yi(j,k)=temp + 444 continue + 445 continue +c +c + 450 continue + if(job.eq.2) goto 500 +c compute right transformation + l22=1 + 460 l11=l22 + l22=l11+bs(l11) + if(l22.gt.n) goto 480 + do 470 j=l22,n + do 470 i=1,n + xr(i,j)=xr(i,j)+ddot(l22-l11,xr(i,l11),lda,ar(l11,j),1) + 1 -ddot(l22-l11,xi(i,l11),lda,ai(l11,j),1) + xi(i,j)=xi(i,j)+ddot(l22-l11,xr(i,l11),lda,ai(l11,j),1) + 1 +ddot(l22-l11,xi(i,l11),lda,ar(l11,j),1) + 470 continue + goto 460 +c + 480 continue + call balbak( lda, n, low, igh, scale, n, xr) + call balbak( lda, n, low, igh, scale, n, xi) + goto 550 +c +c extract non orthogonal tranformation from a + 500 continue + do 510 j=1,n + call dset(n,zero,yr(1,j),1) + call dset(n,zero,yi(1,j),1) + 510 continue + call dset(n,one,yr(1,1),lda+1) + call dset(n,one,yi(1,1),lda+1) + l22=1 + 520 l11=l22 + if(l11.gt.n) goto 550 + l22=l11+bs(l11) + do 530 j=l22,n + do 530 i=1,n + yr(i,j)=yr(i,j)+ddot(l22-l11,yr(i,l11),lda,ar(l11,j),1) + 1 -ddot(l22-l11,yi(i,l11),lda,ai(l11,j),1) + yi(i,j)=yi(i,j)+ddot(l22-l11,yr(i,l11),lda,ai(l11,j),1) + 1 +ddot(l22-l11,yi(i,l11),lda,ar(l11,j),1) + 530 continue + goto 520 +c +c set zeros in the matrix a + 550 l11=1 + 560 l22=l11+bs(l11) + if(l22.gt.n) return + l22m1=l22-1 + do 570 j=l11,l22m1 + call dset(n-l22m1,zero,ar(j,l22),lda) + call dset(n-l22m1,zero,ar(l22,j),1) + call dset(n-l22m1,zero,ai(j,l22),lda) + call dset(n-l22m1,zero,ai(l22,j),1) + 570 continue + l11=l22 + goto 560 +c +c error return. +c + 600 continue + fail = .true. + return + end + diff --git a/modules/elementary_functions/src/fortran/wbdiag.lo b/modules/elementary_functions/src/fortran/wbdiag.lo new file mode 100755 index 000000000..66bcf82cc --- /dev/null +++ b/modules/elementary_functions/src/fortran/wbdiag.lo @@ -0,0 +1,12 @@ +# src/fortran/wbdiag.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wbdiag.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wcerr.f b/modules/elementary_functions/src/fortran/wcerr.f new file mode 100755 index 000000000..0b12282a0 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wcerr.f @@ -0,0 +1,129 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c +C/MEMBR ADD NAME=WCERR,SSI=0 +c + subroutine wcerr(ar,ai,w,ia,n,ndng,m,maxc) +c!purpose +c wcerr evaluate the error introduced by pade +c approximant and normalise the complex matrix a accordingly +c!calling sequence +c +c subroutine wcerr(ar,ai,w,ia,n,ndng,m,maxc) +c +c ar,ai : array containing the matrix a +c +c w : work space array of size 4*n*n + 2*n +c +c ia : leading dimension of array a +c +c n : size of matrix a +c +c ndng : degree of pade approximant +c +c m : the factor of normalization is 2**(-m) +c +c maxc : maximum admissible for m +c +c!auxiliary routines +c wmmul dmcopy gdcp2i (blas.extension) +c dset dcopy (blas) +c ddot (blas) +c abs real dble (fortran) +c! +c w tableau de travail de taille 4*n*n+2*n +c + integer ia,n,ndng,m,maxc + double precision ar,ai,w + dimension ar(ia,n),ai(ia,n),w(*) +c +c internal variables + integer k,mm,i,j,mt,kr,ki,ker,kei,kwr,kwi + double precision norm,alpha,zero,two,norm1,one,ddot + logical itab(15) +c + data zero, one, two /0.0d+0,1.0d+0,2.0d+0/ +c +c + n2=n*n + kr=1 + ki=kr+n2 + ker=ki+n2 + kei=ker+n2 + kwr=kei+n2 + kwi=kwr+n + k = 2*ndng + call wmmul(ar,ai,ia,ar,ai,ia,w(ker),w(kei),n,n,n,n) + call gdcp2i(k, itab, mt) + if (.not.itab(1)) go to 30 + norm = zero + do 20 i=1,n + alpha = zero + do 10 j=1,n + alpha = alpha + abs(ar(i,j)) + abs(ai(i,j)) + 10 continue + if (alpha.gt.norm) norm = alpha + 20 continue + call dmcopy(ar,ia,w(kr),n,n,n) + call dmcopy(ai,ia,w(ki),n,n,n) + go to 40 + 30 call dset(n2,0.0d+0,w(kr),1) + call dset(n,1.0d+0,w(kr),n+1) + call dset(n2,0.0d+0,w(ki),1) + 40 if (mt.eq.1) go to 110 + do 100 i1=2,mt + do 70 j=1,n + l = 0 + do 50 i=1,n + w(kwr-1+i) = ddot(n,w(kr-1+j),n,w(ker+l),1) + 1 -ddot(n,w(ki-1+j),n,w(kei+l),1) + w(kwi-1+i) = ddot(n,w(kr-1+j),n,w(kei+l),1) + 1 +ddot(n,w(ki-1+j),n,w(ker+l),1) + l = l + n + 50 continue + call dcopy(n,w(kwr),1,w(kr-1+j),n) + call dcopy(n,w(kwi),1,w(ki-1+j),n) + 70 continue + if (.not.itab(i1)) go to 100 + norm1 = zero + do 90 i=1,n + alpha = zero + l = i - 1 + do 80 j=1,n + alpha = alpha + abs(w(kr+l)) + abs(w(ki+l)) + l = l + n + 80 continue + if (alpha.gt.norm1) norm1 = alpha + 90 continue + norm = norm*norm1 + 100 continue + 110 continue + norm = norm/dble(real(k+1)) + do 120 i=1,ndng + norm = norm/dble(real((k-i+1)**2)) + 120 continue + norm = 8.0d+0*norm + mm = 0 + 130 if (norm+one .le. one) go to 140 + mm = mm + 1 + alpha = two**mm + norm = norm/alpha + if ((mm+m).gt.maxc) go to 140 + go to 130 + 140 continue + alpha = (two**mm) + do 160 i=1,n + do 150 j=1,n + ar(i,j) = ar(i,j)/alpha + ai(i,j) = ai(i,j)/alpha + 150 continue + 160 continue + m = m + mm + return + end diff --git a/modules/elementary_functions/src/fortran/wcerr.lo b/modules/elementary_functions/src/fortran/wcerr.lo new file mode 100755 index 000000000..94881edb5 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wcerr.lo @@ -0,0 +1,12 @@ +# src/fortran/wcerr.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wcerr.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wclmat.f b/modules/elementary_functions/src/fortran/wclmat.f new file mode 100755 index 000000000..5d67d20a9 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wclmat.f @@ -0,0 +1,90 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c +C/MEMBR ADD NAME=WCLMAT,SSI=0 +c + subroutine wclmat(ia, n, ar, ai, br, bi, ib, w, c, ndng) +c +c%purpose +c computes a complex matrix polynomial representated in a +c chebychev base by the clenshaw method. +c +c%calling sequence +c +c subroutine wclmat(ia, n, ar, ai, br, bi, ib, w, c, ndng) +c +c integer ia,n,ib,ndng +c double precision ar,ai,br,bi,w,c +c dimension ar(ia,n),ai(ia,n),br(ib,n),bi(ib,n),c(*),w(*) +c +c ia: the leading dimension of array a. +c n: the order of the matrices a,b. +c ar,ai : the array that contains the n*n matrix a +c br,bi : the array that contains the n*n matrix +c pol(a). +c ib:the leading dimension of array b. +c w : work-space array of size 4*n +c c: vectors which contains the coefficients +c of the polynome. +c ndng: the polynomial order. +c +c%auxiliary routines +c wmmul (blas.extension) +c% +c + integer ia,n,ib,ndng + double precision ar,ai,br,bi,w,c + dimension ar(ia,n),ai(ia,n),br(ib,n),bi(ib,n),c(*),w(*) +c internal variables +c + integer k1r,k1i,k2r,k2i,i1,i,im1,j,ndng1,ndng2 + double precision two,zero,rc,wd,w1,half + data zero, two, half /0.0d+0,2.0d+0,0.50d+0/ +c + k1r=1 + k1i=k1r+n + k2r=k1i+n + k2i=k2r+n + n4=4*n + ndng1 = ndng + 2 + ndng2 = ndng - 1 + rc = c(ndng1-1) + wd = c(1) + do 60 j=1,n + do 10 i=1,n4 + w(i) = zero + 10 continue + do 30 i1=1,ndng + im1 = ndng1 - i1 + call wmmul(ar,ai,ia,w(k1r),w(k1i),n,br(1,j),bi(1,j), + * ib,n,n,1) + do 20 i=1,n + w1 = two*br(i,j) - w(k2r-1+i) + w(k2r-1+i) = w(k1r-1+i) + w(k1r-1+i) = w1 + w1 = two*bi(i,j) - w(k2i-1+i) + w(k2i-1+i) = w(k1i-1+i) + w(k1i-1+i) = w1 + 20 continue + w(j) = w(j) + c(im1) + 30 continue + call wmmul(ar,ai,ia,w(k1r),w(k1i),n,br(1,j),bi(1,j),ib,n,n,1) + do 40 i=1,n + w(k1r-1+i) = two*br(i,j) - w(k2r-1+i) + w(k1i-1+i) = two*bi(i,j) - w(k2i-1+i) + 40 continue + w(j) = w(j) + wd + do 50 i=1,n + br(i,j) = (w(k1r-1+i)-w(k2r-1+i))*half + bi(i,j) = (w(k1i-1+i)-w(k2i-1+i))*half + 50 continue + br(j,j) = br(j,j) + half*wd + 60 continue + return + end diff --git a/modules/elementary_functions/src/fortran/wclmat.lo b/modules/elementary_functions/src/fortran/wclmat.lo new file mode 100755 index 000000000..ba3685993 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wclmat.lo @@ -0,0 +1,12 @@ +# src/fortran/wclmat.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wclmat.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wddiv.f b/modules/elementary_functions/src/fortran/wddiv.f new file mode 100755 index 000000000..4fc330874 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wddiv.f @@ -0,0 +1,41 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA - Serge STEER +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine wddiv(ar,ai,br,cr,ci,ierr) +c!but +c +c This subroutine wddiv computes c=a/b where a is a complex number +c and b a real number +c +c!Calling sequence +c +c subroutine wddiv(ar,ai,br,bi,cr,ci,ierr) +c +c ar, ai: double precision, a real and complex parts. +c +c br, bi: double precision, b real and complex parts. +c +c cr, ci: double precision, c real and complex parts. +c +c!author +c +c Serge Steer +c + double precision ar,ai,br,cr,ci +c + ierr=0 + + if (br .eq. 0.0d+0) then + ierr=1 +c return + endif + cr = ar/br + ci = ai/br + return + end diff --git a/modules/elementary_functions/src/fortran/wddiv.lo b/modules/elementary_functions/src/fortran/wddiv.lo new file mode 100755 index 000000000..bfa12e7cc --- /dev/null +++ b/modules/elementary_functions/src/fortran/wddiv.lo @@ -0,0 +1,12 @@ +# src/fortran/wddiv.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wddiv.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wdiv.f b/modules/elementary_functions/src/fortran/wdiv.f new file mode 100755 index 000000000..be83f54ef --- /dev/null +++ b/modules/elementary_functions/src/fortran/wdiv.f @@ -0,0 +1,38 @@ + subroutine wdiv(ar,ai,br,bi,cr,ci) +c!but +c +c cette subroutine wdiv calcule la division c=a/b de +c nombres complexes de double precision. les parties +c reelles de a, b et c sont rangees, respectivement dans +c ar, br et cr. de facon analogue les parties imaginaires +c de a, b et c son rangees dans ai, bi et ci. +c +c!liste d'appel +c +c subroutine wdiv(ar,ai,br,bi,cr,ci) +c +c ar, ai: double precision, parties reelle et imaginaire de a. +c +c br, bi: double precision, parties reelle et imaginaire de b. +c +c cr, ci: double precision, parties reelle et imaginaire de c. +c +c!auteur +c +c cleve moler. +c +c! + double precision ar,ai,br,bi,cr,ci +c c = a/b + double precision s,d,ars,ais,brs,bis + s = abs(br) + abs(bi) + if (s .eq. 0.0d+0) return + ars = ar/s + ais = ai/s + brs = br/s + bis = bi/s + d = brs**2 + bis**2 + cr = (ars*brs + ais*bis)/d + ci = (ais*brs - ars*bis)/d + return + end diff --git a/modules/elementary_functions/src/fortran/wdiv.lo b/modules/elementary_functions/src/fortran/wdiv.lo new file mode 100755 index 000000000..94ee4612a --- /dev/null +++ b/modules/elementary_functions/src/fortran/wdiv.lo @@ -0,0 +1,12 @@ +# src/fortran/wdiv.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wdiv.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wdotci.f b/modules/elementary_functions/src/fortran/wdotci.f new file mode 100755 index 000000000..09eb710fe --- /dev/null +++ b/modules/elementary_functions/src/fortran/wdotci.f @@ -0,0 +1,27 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c +C/MEMBR ADD NAME=WDOTCI,SSI=0 +c + double precision function wdotci(n,xr,xi,incx,yr,yi,incy) + double precision xr(*),xi(*),yr(*),yi(*),s + s = 0.0d+0 + if (n .le. 0) go to 20 + 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 + s = s + xr(ix)*yi(iy) - xi(ix)*yr(iy) + ix = ix + incx + iy = iy + incy + 10 continue + 20 wdotci = s + return + end diff --git a/modules/elementary_functions/src/fortran/wdotci.lo b/modules/elementary_functions/src/fortran/wdotci.lo new file mode 100755 index 000000000..a797c8468 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wdotci.lo @@ -0,0 +1,12 @@ +# src/fortran/wdotci.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wdotci.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wdotcr.f b/modules/elementary_functions/src/fortran/wdotcr.f new file mode 100755 index 000000000..74015567c --- /dev/null +++ b/modules/elementary_functions/src/fortran/wdotcr.f @@ -0,0 +1,27 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c +C/MEMBR ADD NAME=WDOTCR,SSI=0 +c + double precision function wdotcr(n,xr,xi,incx,yr,yi,incy) + double precision xr(*),xi(*),yr(*),yi(*),s + s = 0.0d+0 + if (n .le. 0) go to 20 + 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 + s = s + xr(ix)*yr(iy) + xi(ix)*yi(iy) + ix = ix + incx + iy = iy + incy + 10 continue + 20 wdotcr = s + return + end diff --git a/modules/elementary_functions/src/fortran/wdotcr.lo b/modules/elementary_functions/src/fortran/wdotcr.lo new file mode 100755 index 000000000..f30fe3d70 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wdotcr.lo @@ -0,0 +1,12 @@ +# src/fortran/wdotcr.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wdotcr.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wdpow.f b/modules/elementary_functions/src/fortran/wdpow.f new file mode 100755 index 000000000..a023991fd --- /dev/null +++ b/modules/elementary_functions/src/fortran/wdpow.f @@ -0,0 +1,66 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) 1989 - INRIA - Serge STEER +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine wdpow(n,vr,vi,iv,dpow,ierr) +c!but +c eleve les elements d'un vecteur complexe a une puissance reelle +c!liste d'appel +c subroutine wdpow(n,vr,vi,iv,dpow,ierr) +c integer n,iv,ierr +c double precision vr(n*iv),vi(n*iw),dpow +c +c n : nombre d'element du vecteur +c vr : tableau contenant les parties reelles des elements du vecteur +c vi : tableau contenant les parties imaginaires des elements du vecteur +c iv : increment entre deux element consecutif du vecteur dans le +c tableau v +c dpow : la puissance a la quelle doivent etre +c eleves les elements du vecteur +c ierr : indicateur d'erreur +c ierr=0 si ok +c ierr=1 si 0**0 +c ierr=2 si 0**k avec k<0 +c!origine +c Serge Steer INRIA 1989 +c + integer n,iv,ierr + double precision vr(*),vi(*),dpow,sr,si +c + ierr=0 +c + if(dble(int(dpow)).ne.dpow) goto 01 +c puissance entieres + call wipow(n,vr,vi,iv,int(dpow),ierr) + return +c + 01 continue +c puissance reelles + ii=1 + do 20 i=1,n + if(abs(vr(ii))+abs(vi(ii)).ne.0.0d+0) then + call wlog(vr(ii),vi(ii),sr,si) + sr=exp(sr*dpow) + si=si*dpow + vr(ii)=sr*cos(si) + vi(ii)=sr*sin(si) + ii=ii+iv + else + if(dpow.gt.0.0d+0) then + vr(ii)=0.0d+0 + vi(ii)=0.0d+0 + ii=ii+iv + else + ierr=2 + endif + return + endif + 20 continue +c + return + end diff --git a/modules/elementary_functions/src/fortran/wdpow.lo b/modules/elementary_functions/src/fortran/wdpow.lo new file mode 100755 index 000000000..5e1b6a0ba --- /dev/null +++ b/modules/elementary_functions/src/fortran/wdpow.lo @@ -0,0 +1,12 @@ +# src/fortran/wdpow.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wdpow.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wdpow1.f b/modules/elementary_functions/src/fortran/wdpow1.f new file mode 100755 index 000000000..7e03526f7 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wdpow1.f @@ -0,0 +1,58 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) 1996 - INRIA - Serge STEER +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine wdpow1(n,vr,vi,iv,p,ip,rr,ri,ir,ierr) +c!purpose +c computes V^P with V complex vector and P real vector +c!calling sequence +c subroutine wdpow1(n,vr,vi,iv,p,ip,rr,ri,ir,ierr) +c integer n,iv,ip,ir,ierr +c double precision vr(*),vi(*),p(*),rr(*),ri(*) +c +c n : number of elements of V and P vectors +c vr : array containing real part of V elements +c real(V(i))=vr(1+(i-1)*iv) +c vi : array containing imaginary part of V elements +c imag(V(i))=vi(1+(i-1)*iv) +c iv : increment between two V elements in v (may be 0) +c p : array containing P elements P(i)=p(1+(i-1)*ip) +c ip : increment between two P elements in p (may be 0) +c rr : array containing real part of the results vector R: +c real(R(i))=rr(1+(i-1)*ir) +c ri : array containing imaginary part of the results vector R: +c imag(R(i))=ri(1+(i-1)*ir) +c ir : increment between two R elements in rr and ri +c ierr : error flag +c ierr=0 if ok +c ierr=1 if 0**0 +c ierr=2 if 0**k with k<0 +c!origin +c Serge Steer INRIA 1996 +c + integer n,iv,ierr,ierr1 + double precision vr(*),vi(*),p(*),rr(*),ri(*) +c + ierr=0 + iscmpl=0 +c + + ii=1 + iip=1 + iir=1 + do 20 i=1,n + call wdpowe(vr(ii),vi(ii),p(iip),rr(iir),ri(iir),ierr1) +c if(ierr.ne.0) return + ierr=max(ierr,ierr1) + ii=ii+iv + iip=iip+ip + iir=iir+ir + 20 continue +c + return + end diff --git a/modules/elementary_functions/src/fortran/wdpow1.lo b/modules/elementary_functions/src/fortran/wdpow1.lo new file mode 100755 index 000000000..f1282aa06 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wdpow1.lo @@ -0,0 +1,12 @@ +# src/fortran/wdpow1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wdpow1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wdpowe.f b/modules/elementary_functions/src/fortran/wdpowe.f new file mode 100755 index 000000000..171035d8a --- /dev/null +++ b/modules/elementary_functions/src/fortran/wdpowe.f @@ -0,0 +1,58 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) 1996 - INRIA - Serge STEER +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine wdpowe(vr,vi,p,rr,ri,ierr) +c!purpose +c computes v^p with v complex and p real +c!calling sequence +c subroutine wdpowe(vr,vi,p,rr,ri,ierr) +c integer ierr +c double precision vr,vi,p,rr,ri +c vr : real part of v +c vi : imaginary part of v +c rr : result's real part +c ri : result's imaginary part +c ierr : error flag +c ierr=0 if ok +c ierr=1 if 0**0 +c ierr=2 if 0**k with k<0 +c!origin +c Serge Steer INRIA 1996 +c + integer ierr + double precision vr,vi,p,sr,si,rr,ri,infinity +c + ierr=0 +c + if(dble(int(p)).eq.p) then + call wipowe(vr,vi,int(p),rr,ri,ierr) + else + if(abs(vr)+abs(vi).ne.0.0d+0) then + call wlog(vr,vi,sr,si) + sr=exp(sr*p) + si=si*p + rr=sr*cos(si) + ri=sr*sin(si) + else + if(p.gt.0.0d+0) then + rr=0.0d+0 + ri=0.0d+0 + elseif(p.lt.0.0d+0) then + ri=0.0d+0 + rr=infinity(ri) + ierr=2 + else + rr=1.0d+0 + ri=0.0d+0 + endif + endif + endif +c + return + end diff --git a/modules/elementary_functions/src/fortran/wdpowe.lo b/modules/elementary_functions/src/fortran/wdpowe.lo new file mode 100755 index 000000000..eec454d35 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wdpowe.lo @@ -0,0 +1,12 @@ +# src/fortran/wdpowe.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wdpowe.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wdrdiv.f b/modules/elementary_functions/src/fortran/wdrdiv.f new file mode 100755 index 000000000..76c1668ba --- /dev/null +++ b/modules/elementary_functions/src/fortran/wdrdiv.f @@ -0,0 +1,70 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine wdrdiv(ar,ai,ia,br,ib,rr,ri,ir,n,ierr) +c! purpose +c computes r=a./b with a real vector and b complex vector +c +c ia,ib,ir : increment between two consecutive element of vectors a +c b and r +c ar,ai : arrays containing a real and imaginary parts +c br : array containing b vector +c rr,ri : arrays containing r real and imaginary parts +c n : vectors length +c ierr : returned error flag: +c o : ok +c <>0 : b(ierr)=0 +c + double precision ar(*),ai(*),br(*),rr(*),ri(*) + integer ia,ib,ir,n +c wr, wi used because rr, ri may share same mem as ar,ai or br,bi + double precision wr,wi + jr=1 + jb=1 + ja=1 + ierr=0 + if (ia.eq.0) then + do 10 k=1,n + call wddiv(ar(ja),ai(ja),br(jb),wr,wi,ierr1) + rr(jr)=wr + ri(jr)=wi + if(ierr1.ne.0) then + ierr=k +c return + endif + jr=jr+ir + jb=jb+ib + 10 continue + elseif(ib.eq.0) then + if(br(jb).eq.0.0d0) then + ierr=1 +c return + endif + do 11 k=1,n + call wddiv(ar(ja),ai(ja),br(jb),wr,wi,ierr1) + rr(jr)=wr + ri(jr)=wi + jr=jr+ir + ja=ja+ia + 11 continue + else + do 12 k=1,n + call wddiv(ar(ja),ai(ja),br(jb),wr,wi,ierr1) + rr(jr)=wr + ri(jr)=wi + if(ierr1.ne.0) then + ierr=k +c return + endif + jr=jr+ir + jb=jb+ib + ja=ja+ia + 12 continue + endif + end diff --git a/modules/elementary_functions/src/fortran/wdrdiv.lo b/modules/elementary_functions/src/fortran/wdrdiv.lo new file mode 100755 index 000000000..12c5cea57 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wdrdiv.lo @@ -0,0 +1,12 @@ +# src/fortran/wdrdiv.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wdrdiv.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wexchn.f b/modules/elementary_functions/src/fortran/wexchn.f new file mode 100755 index 000000000..f4256ba5e --- /dev/null +++ b/modules/elementary_functions/src/fortran/wexchn.f @@ -0,0 +1,111 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA - Serge STEER +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine wexchn(ar, ai, vr, vi, n, l, fail, na, nv) +c!purpose +c +c given the upper triangular complex matrix a ,wexchn produce a +c unitary transformation which exchange the two consecutive blocks +c starting at a(l,l),along with their eigenvalues. +c the transformation is accumulated in v. +c!calling sequence +c +c subroutine exchng(ar, ai, vr, vi, n, l, fail, na, nv) +c +c integer l, na, nv +c double precision ar, ai, vr, vi +c dimension ar(na,n) , ai(na,n) ,vr(nv,n) ,vi(nv,n) +c logical fail +c +c starred parameters are altered by the subroutine +c +c *ar,ai the matrix whose blocks are to be +c interchanged. +c *vr,vi the array into which the transformations +c are to re accumulated. +c n the order of the matrix a. +c l the position of the blocks. +c *fail a logical variable which is false on a +c normal return. if thirty iterations were +c performed without convergence, fail is set +c to true and the element +c a(l+b2,l+b2-1) cannot be assumed zero. +c na the first dimension of the array a. +c nv the first dimension of the array v. +c +c!auxiliary routines +c max sqrt abs (fortran) +c!originator +c steer i.n.r.i.a from routine exchng +c + integer l,na,nv + double precision ar,ai,vr,vi + dimension ar(na, n), ai(na, n), vr(nv, n), vi(nv, n) + logical fail +c +c internal variables. +c + double precision pr,pi,qr,qi,r,sr,si,tr,ti,zero + integer i, j, l1 + data zero /0.0d+0/ + l1 = l + 1 +c + fail = .false. +c +c interchange 1x1 and 1x1 blocks. +c + qr = ar(l1,l1) - ar(l,l) + pr = ar(l,l1) + qi = ai(l1,l1) - ai(l,l) + pi = ai(l,l1) + r = max(abs(pr),abs(pi),abs(qr),abs(qi)) + if (r.eq.zero) return + pr = pr/r + qr = qr/r + pi = pi/r + qi = qi/r + r = sqrt(pr*pr + pi*pi + qr*qr + qi*qi) + pr = pr/r + qr = qr/r + pi = pi/r + qi = qi/r + do 10 j = l,n + sr = ar(l,j) + si = ai(l,j) + tr = ar(l1,j) + ti = ai(l1,j) + ar(l,j) = pr*sr + pi*si + qr*tr + qi*ti + ai(l,j) = pr*si - pi*sr + qr*ti - qi*tr + ar(l1,j) = pr*tr - pi*ti - qr*sr + qi*si + ai(l1,j) = pr*ti + pi*tr - qr*si - qi*sr + 10 continue + do 20 i = 1,l1 + sr = ar(i,l) + si = ai(i,l) + tr = ar(i,l1) + ti = ai(i,l1) + ar(i,l) = pr*sr + qr*tr - pi*si - qi*ti + ai(i,l) = pi*sr + qi*tr + pr*si + qr*ti + ar(i,l1) = pr*tr + pi*ti - qr*sr - qi*si + ai(i,l1) = pr*ti - pi*tr - qr*si + qi*sr + 20 continue + do 30 i = 1,n + sr = vr(i,l) + si = vi(i,l) + tr = vr(i,l1) + ti = vi(i,l1) + vr(i,l) = pr*sr + qr*tr - pi*si - qi*ti + vi(i,l) = pi*sr + qi*tr + pr*si + qr*ti + vr(i,l1) = pr*tr + pi*ti - qr*sr - qi*si + vi(i,l1) = pr*ti - pi*tr - qr*si + qi*sr + 30 continue + ar(l1,l) = zero + ai(l1,l) = zero + return + end diff --git a/modules/elementary_functions/src/fortran/wexchn.lo b/modules/elementary_functions/src/fortran/wexchn.lo new file mode 100755 index 000000000..16ec35f27 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wexchn.lo @@ -0,0 +1,12 @@ +# src/fortran/wexchn.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wexchn.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wexpm1.f b/modules/elementary_functions/src/fortran/wexpm1.f new file mode 100755 index 000000000..44500433d --- /dev/null +++ b/modules/elementary_functions/src/fortran/wexpm1.f @@ -0,0 +1,186 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine wexpm1(n,ar,ai,ia,ear,eai,iea,w,iw,ierr) +c +c!purpose +c compute the exponential of a complex matrix a by the pade's +c approximants(subroutine pade).a block diagonalization +c is performed prior call pade. +c!calling sequence +c subroutine wexpm1(n,ar,ai,ia,ear,eai,iea,w,iw,ierr) +c +c integer ia,n,iw,ierr +c double precision ar,ai,ear,eai,w +c dimension ar(ia,n),ai(ia,n),ear(iea,n),eai(iea,n),w(*),iw(*) +c +c n: the order of the matrices a,ea, . +c ar,ai :the array that contains :the n*n matrix a +c ia: the leading dimension of array a. +c ear,eai: the array that contains the n*n exponential of a. +c iea :the leading dimension of ea +c w : work space array of size: n*(4*ia+4*n+7) +c iw : integer work space array of size 2*n +c ierr: =0 if the prosessus is normal. +c =-1 if n>ia. +c =-2 if the block diagonalization is not possible. +c =-4 if the subroutine dpade can not computes exp(a) +c +c!auxiliary routines +c cos sin exp abs sqrt dble real (fortran) +c wbdiag wbalin (eispack.extension) +c cbal (eispack) +c wmmul (blas.extension) +c wpade +c! originator +c S Steer INRIA from dexpm1: +c j roche laboratoire d'automatique de grenoble +c + integer ia,n,iw,ierr + double precision ar,ai,ear,eai,w + dimension ar(ia,n),ai(ia,n),ear(iea,n),eai(iea,n),w(*),iw(*) +c internal variables +c + integer i,j,k,ni,nii,ndng + double precision anorm,alpha,bvecr,bveci,bbvec,rn,zero,c(41) + logical fail +c +cDEC$ IF DEFINED (FORDLL) +cDEC$ ATTRIBUTES DLLIMPORT:: /dcoeff/ +cDEC$ ENDIF + common /dcoeff/ c,ndng +c + data zero /0.0d+0/ + ndng=-1 +c + ierr=0 + nn=n*n + kscal=1 + kxr=kscal+n + kxi=kxr+n*ia + kyr=kxi+n*ia + kyi=kyr+n*ia + ker=kyi+n*ia + kei=ker+n + kw=kei+n +c + kbs=1 + kpvt=kbs+n +c + if (n.gt.ia) go to 110 +c +c compute the norm one of a. +c + anorm = 0.0d+0 + do 20 j=1,n + alpha = zero + do 10 i=1,n + alpha = alpha + abs(ar(i,j)) + abs(ai(i,j)) + 10 continue + if (alpha.gt.anorm) anorm = alpha + 20 continue + if (anorm.eq.0.0d0) then +c null matrix special case (Serge Steer 96) + do 21 j=1,n + call dset(n,0.0d+0,ear(j,1),iea) + call dset(n,0.0d+0,eai(j,1),iea) + ear(j,j)=1.0d0 + 21 continue + return + endif + anorm=max(anorm,1.0d0) +c +c call wbdiag whith rmax equal to the norm one of matrix a. +c + call wbdiag(ia,n,ar,ai,anorm,w(ker),w(kei), + * iw(kbs),w(kxr),w(kxi),w(kyr),w(kyi),w(kscal),1,fail) + if (fail) go to 120 +c +c clear matrix ea + do 25 j=1,n + call dset(n,0.0d+0,ear(j,1),iea) + call dset(n,0.0d+0,eai(j,1),iea) + 25 continue +c +c compute the pade's approximants of the block. +c block origin is shifted before calling pade. +c + ni = 1 + k = 0 +c +c loop on the block. +c + 30 k = k + ni + if (k.gt.n) go to 100 + ni = iw(kbs-1+k) + if (ni.eq.1) go to 90 + nii = k + ni - 1 + bvecr = zero + bveci = zero + do 40 i=k,nii + bvecr = bvecr + w(ker-1+i) + bveci = bveci + w(kei-1+i) + 40 continue + bvecr = bvecr/dble(real(ni)) + bveci = bveci/dble(real(ni)) + do 50 i=k,nii + w(ker-1+i) = w(ker-1+i) - bvecr + w(kei-1+i) = w(kei-1+i) - bveci + ar(i,i) = ar(i,i) - bvecr + ai(i,i) = ai(i,i) - bveci + 50 continue + alpha = zero + do 60 i=k,nii + rn = w(ker-1+i)**2 + w(kei-1+i)**2 + rn = sqrt(rn) + if (rn.gt.alpha) alpha = rn + 60 continue +c +c call pade subroutine. +c + call wpade(ar(k,k),ai(k,k),ia,ni,ear(k,k),eai(k,k),iea, + * alpha,w(kw),iw(kpvt),ierr) + if (ierr.lt.0) go to 130 +c +c remove the effect of origin shift on the block. +c + bbvec = exp(bvecr) + bvecr=bbvec*cos(bveci) + bveci=bbvec*sin(bveci) + do 80 i=k,nii + do 70 j=k,nii + bbvec = ear(i,j)*bvecr - eai(i,j)*bveci + eai(i,j) = ear(i,j)*bveci + eai(i,j)*bvecr + ear(i,j) = bbvec + 70 continue + 80 continue + go to 30 + 90 bbvec=exp(ar(k,k)) + ear(k,k) = bbvec * cos(ai(k,k)) + eai(k,k) = bbvec * sin(ai(k,k)) + go to 30 +c +c end of loop. +c + 100 continue +c +c remove the effect of block diagonalization. +c + call wmmul(w(kxr),w(kxi),ia,ear,eai,iea,w(kw),w(kw+nn),n,n,n,n) + call wmmul(w(kw),w(kw+nn),n,w(kyr),w(kyi),ia,ear,eai,iea,n,n,n) +c +c error output +c + go to 130 + 110 ierr = -1 + go to 130 + 120 ierr = -2 + 130 continue + return + end diff --git a/modules/elementary_functions/src/fortran/wexpm1.lo b/modules/elementary_functions/src/fortran/wexpm1.lo new file mode 100755 index 000000000..3cd1bbdd3 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wexpm1.lo @@ -0,0 +1,12 @@ +# src/fortran/wexpm1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wexpm1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wipow.f b/modules/elementary_functions/src/fortran/wipow.f new file mode 100755 index 000000000..06f5c33c4 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wipow.f @@ -0,0 +1,81 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) 1989 - INRIA - Serge STEER +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine wipow(n,vr,vi,iv,ipow,ierr) +c!but +c eleve a une puissance entiere les elements d'un vecteur de flottants +c complexes +c!liste d'appel +c subroutine wipow(n,vr,vi,iv,ipow,ierr) +c integer n,iv,ipow ,ierr +c double precision vr(n*iv),vi(n*iw) +c +c n : nombre d'element du vecteur +c vr : tableau contenant les parties reelles des elements du vecteur +c vi : tableau contenant les parties imaginaires des elements du vecteur +c iv : increment entre deux element consecutif du vecteur dans le +c tableau v +c ipow : puissance a la quelle doivent etre eleves les elements du +c vecteur +c ierr : indicateur d'erreur +c ierr=0 si ok +c ierr=1 si 0**0 +c ierr=2 si 0**k avec k<0 +c!origine +c Serge Steer INRIA 1989 +c + integer n,iv,ipow ,ierr + double precision vr(*),vi(*),xr,xi +c + ierr=0 +c + if(ipow.eq.1) return + if(ipow.eq.0) then +c puissance 0 + ii=1 + do 10 i=1,n + if(abs(vr(ii))+abs(vi(ii)).ne.0.0d+0) then + vr(ii)=1.0d+0 + vi(ii)=0.0d+0 + ii=ii+iv + else + ierr=1 + return + endif + 10 continue + return +c + else if(ipow.lt.0) then +c puissance negative + ii=1 + do 20 i=1,n + if(abs(vr(ii))+abs(vi(ii)).ne.0.0d+0) then + call wdiv(1.0d+0,0.0d+0,vr(ii),vi(ii),vr(ii),vi(ii)) + ii=ii+iv + else + ierr=2 + return + endif + 20 continue + if(ipow.eq.-1) return + endif +c +c puissance positive et fin puissance negatives + ii=1 + do 30 i=1,n + xr=vr(ii) + xi=vi(ii) + do 31 k=2,abs(ipow) + call wmul(xr,xi,vr(ii),vi(ii),vr(ii),vi(ii)) + 31 continue + ii=ii+iv + 30 continue +c + return + end diff --git a/modules/elementary_functions/src/fortran/wipow.lo b/modules/elementary_functions/src/fortran/wipow.lo new file mode 100755 index 000000000..1679e71b7 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wipow.lo @@ -0,0 +1,12 @@ +# src/fortran/wipow.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wipow.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wipowe.f b/modules/elementary_functions/src/fortran/wipowe.f new file mode 100755 index 000000000..20e56cfd3 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wipowe.f @@ -0,0 +1,59 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) 1996 - INRIA - Serge STEER +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine wipowe(vr,vi,p,rr,ri,ierr) +c!purpose +c computes v^p with v complex and p integer +c!calling sequence +c subroutine wipowe(vr,vi,p,rr,ri,ierr) +c integer ierr +c double precision vr,vi,p,rr,ri +c vr : real part of v +c vi : imaginary part of v +c rr : result's real part +c ri : result's imaginary part +c ierr : error flag +c ierr=0 if ok +c ierr=1 if 0**0 +c ierr=2 if 0**k with k<0 +c!origin +c Serge Steer INRIA 1996 +c + integer p,ierr + double precision vr,vi,xr,xi,rr,ri,infinity +c + ierr=0 +c + if(p.eq.0) then + rr=1.0d+0 + ri=0.0d+0 + elseif(p.lt.0) then + if(abs(vr)+abs(vi).ne.0.0d+0) then + call wdiv(1.0d+0,0.0d+0,vr,vi,rr,ri) + xr=rr + xi=ri + do 10 k=2,abs(p) + call wmul(xr,xi,rr,ri,rr,ri) + 10 continue + else + ri=0.0d0 + rr=infinity(ri) + ierr=2 + endif + else + rr=vr + ri=vi + xr=rr + xi=ri + do 20 k=2,abs(p) + call wmul(xr,xi,rr,ri,rr,ri) + 20 continue + endif + return + end diff --git a/modules/elementary_functions/src/fortran/wipowe.lo b/modules/elementary_functions/src/fortran/wipowe.lo new file mode 100755 index 000000000..469254d41 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wipowe.lo @@ -0,0 +1,12 @@ +# src/fortran/wipowe.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wipowe.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wlog.f b/modules/elementary_functions/src/fortran/wlog.f new file mode 100755 index 000000000..da7d303b4 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wlog.f @@ -0,0 +1,106 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) Bruno Pincon +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + subroutine wlog(xr,xi,yr,yi) +* +* PURPOSE +* wlog compute the logarithm of a complex number +* y = yr + i yi = log(x), x = xr + i xi +* +* CALLING LIST / PARAMETERS +* subroutine wlog(xr,xi,yr,yi) +* double precision xr,xi,yr,yi +* +* xr,xi: real and imaginary parts of the complex number +* yr,yi: real and imaginary parts of the result +* yr,yi may have the same memory cases than xr et xi +* +* METHOD +* adapted with some modifications from Hull, +* Fairgrieve, Tang, "Implementing Complex +* Elementary Functions Using Exception Handling", +* ACM TOMS, Vol. 20 (1994), pp 215-244 +* +* y = yr + i yi = log(x) +* yr = log(|x|) = various formulae depending where x is ... +* yi = Arg(x) = atan2(xi, xr) +* +* AUTHOR +* Bruno Pincon <Bruno.Pincon@iecn.u-nancy.fr> +* + implicit none + +* PARAMETER + double precision xr, xi, yr, yi + +* LOCAL VAR + double precision a, b, t, r +* CONSTANTS + double precision R2 + parameter (R2 = 1.41421356237309504d0) + +* EXTERNAL + double precision dlamch, logp1, pythag + external dlamch, logp1, pythag + + +* STATIC VAR + logical first + double precision RMAX, LSUP, LINF + + save first + data first /.true./ + save RMAX, LSUP, LINF + + if (first) then + RMAX = dlamch('O') + LINF = sqrt(dlamch('U')) + LSUP = sqrt(0.5d0*RMAX) + first = .false. + endif + +* (0) avoid memory pb ... + a = xr + b = xi + +* (1) compute the imaginary part + yi = atan2(b, a) + +* (2) compute the real part + a = abs(a) + b = abs(b) + +* Order a and b such that 0 <= b <= a + if (b .gt. a) then + t = b + b = a + a = t + endif + + if ( (0.5d0 .le. a) .and. (a .le. R2) ) then + yr = 0.5d0*logp1((a-1.d0)*(a+1.d0) + b*b) + elseif (LINF .lt. b .and. a .lt. LSUP) then +* no overflow or underflow can occur in computing a*a + b*b + yr = 0.5d0*log(a*a + b*b) + elseif (a .gt. RMAX) then +* overflow + yr = a + else + t = pythag(a,b) + if (t .le. RMAX) then + yr = log(t) + else +* handle rare spurious overflow with : + r = b/a + yr = log(a) + 0.5d0*logp1(r*r) + endif + endif + + end + diff --git a/modules/elementary_functions/src/fortran/wlog.lo b/modules/elementary_functions/src/fortran/wlog.lo new file mode 100755 index 000000000..6cd8b674b --- /dev/null +++ b/modules/elementary_functions/src/fortran/wlog.lo @@ -0,0 +1,12 @@ +# src/fortran/wlog.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wlog.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wmmul.f b/modules/elementary_functions/src/fortran/wmmul.f new file mode 100755 index 000000000..70c9e719b --- /dev/null +++ b/modules/elementary_functions/src/fortran/wmmul.f @@ -0,0 +1,58 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine wmmul(Ar,Ai,na,Br,Bi,nb,Cr,Ci,nc,l,m,n) +* +* PURPOSE +* computes the matrix product C = A * B where the +* matrices are complex with the scilab storage +* C = A * B +* (l,n) (l,m) * (m,n) +* +* PARAMETERS +* input +* ----- +* Ar, Ai : real and imaginary part of the matrix A +* (double) arrays (l, m) with leading dim na +* +* Br, Bi : real and imaginary part of the matrix B +* (double) arrays (m, n) with leading dim nb +* +* na, nb, nc, l, m, n : integers +* +* output +* ------ +* Cr, Ci : real and imaginary part of the matrix C +* (double) arrays (l, n) with leading dim nc +* +* METHOD +* Cr = Ar * Br - Ai * Bi +* Ci = Ar * Bi + Ai * Br +* +* NOTE +* modification of the old wmmul to use blas calls +* + implicit none + + integer na, nb, nc, l, m, n + double precision Ar(na,m), Ai(na,m), Br(nb,n), Bi(nb,n), + $ Cr(nc,n), Ci(nc,n) + +* Cr <- 1*Ar*Br + 0*Cr + call dgemm('n','n', l, n, m, 1.d0, Ar, na, Br, nb, 0.d0, Cr, nc) +* Cr <- -1*Ai*Bi + 1*Cr + call dgemm('n','n', l, n, m,-1.d0, Ai, na, Bi, nb, 1.d0, Cr, nc) +* Ci <- 1*Ar*Bi + 0*Ci + call dgemm('n','n', l, n, m, 1.d0, Ar, na, Bi, nb, 0.d0, Ci, nc) +* Ci <- 1*Ai*Br + 1*Ci + call dgemm('n','n', l, n, m, 1.d0, Ai, na, Br, nb, 1.d0, Ci, nc) + + end + + diff --git a/modules/elementary_functions/src/fortran/wmmul.lo b/modules/elementary_functions/src/fortran/wmmul.lo new file mode 100755 index 000000000..7265d9aa8 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wmmul.lo @@ -0,0 +1,12 @@ +# src/fortran/wmmul.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wmmul.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wmprod.f b/modules/elementary_functions/src/fortran/wmprod.f new file mode 100755 index 000000000..4533e4294 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wmprod.f @@ -0,0 +1,72 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine wmprod(flag,ar,ai,na,m,n,vr,vi,nv) +c!purpose +c computes the product of the entries of a complex matrix according to flag +c!calling sequence +c subroutine wmprod(flag,ar,ai,na,m,n,vr,vi,nv) +c double precision ar(na,n),ai(na,n),vr(*),vi(*) +c integer na,n,m,nv +c integer flag +c!parameters +c flag : indicates operation to perform +c 0 : returns in v(1) the product of all entries of a +c 1 : returns in v(j) the product of jth column of a +c 2 : returns in v(i) the product of ith row of a +c a : array containing the a matrix +c na : a matrix leading dimension +c m : a matrix row dimension +c n : a matrix column dimension +c v : array containing the result, +c vr (resp vi) may be confused with a row or +c a column of the ar (resp ai) matrix +c if flag==0 size(v)>=1 +c if flag==1 size(v)>=n*nv +c if flag==1 size(v)>=m*nv +c nv : increment between to consecutive entries ov v +c + double precision ar(na,n),ai(na,n),vr(*),vi(*) + integer na,n,m,nv + integer flag +c + double precision tr,ti + integer iv +c + iv=1 + if(flag.eq.0) then +c product of all the entries + tr=1.0d0 + ti=0.0d0 + do 10 j=1,n + call wvmul(m,ar(1,j),ai(1,j),1,tr,ti,0) + 10 continue + vr(1)=tr + vi(1)=ti + elseif(flag.eq.1) then + do 20 j=1,n + tr=1.0d0 + ti=0.0d0 + call wvmul(m,ar(1,j),ai(1,j),1,tr,ti,0) + vr(iv)=tr + vi(iv)=ti + iv=iv+nv + 20 continue + elseif(flag.eq.2) then + do 30 i=1,m + tr=1.0d0 + ti=0.0d0 + call wvmul(n,ar(i,1),ai(i,1),m,tr,ti,0) + vr(iv)=tr + vi(iv)=ti + iv=iv+nv + 30 continue + endif + return + end diff --git a/modules/elementary_functions/src/fortran/wmprod.lo b/modules/elementary_functions/src/fortran/wmprod.lo new file mode 100755 index 000000000..dcb5bb794 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wmprod.lo @@ -0,0 +1,12 @@ +# src/fortran/wmprod.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wmprod.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wmsum.f b/modules/elementary_functions/src/fortran/wmsum.f new file mode 100755 index 000000000..b6c5b764f --- /dev/null +++ b/modules/elementary_functions/src/fortran/wmsum.f @@ -0,0 +1,70 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine wmsum(flag,ar,ai,na,m,n,vr,vi,nv) +c!purpose +c computes the sum of the entries of a complexmatrix according to flag +c!calling sequence +c subroutine wmsum(flag,ar,ai,na,m,n,vr,vi,nv) +c double precision ar(na,n),ai(na,n),vr(*),vi(*) +c integer na,n,m,nv +c integer flag +c!parameters +c flag : indicates operation to perform +c 0 : returns in v(1) the sum of all entries of a +c 1 : returns in v(j) the sum of jth column of a +c 2 : returns in v(i) the sum of ith row of a +c a : array containing the a matrix +c na : a matrix leading dimension +c m : a matrix row dimension +c n : a matrix column dimension +c v : array containing the result, may be confused with a row or +c a column of the a matrix +c if flag==0 size(v)>=1 +c if flag==1 size(v)>=n*nv +c if flag==1 size(v)>=m*nv +c nv : increment between to consecutive entries ov v +c + double precision ar(na,n),ai(na,n),vr(*),vi(*) + integer na,n,m,nv + integer flag +c + double precision tr,ti,dsum + integer iv +c + iv=1 + if(flag.eq.0) then +c sum of all the entries + tr=0.0d0 + ti=0.0d0 + do 10 j=1,n + tr=tr+dsum(m,ar(1,j),1) + ti=ti+dsum(m,ai(1,j),1) + 10 continue + vr(1)=tr + vi(1)=ti + elseif(flag.eq.1) then + do 20 j=1,n + tr=dsum(m,ar(1,j),1) + ti=dsum(m,ai(1,j),1) + vr(iv)=tr + vi(iv)=ti + iv=iv+nv + 20 continue + elseif(flag.eq.2) then + do 30 i=1,m + tr=dsum(n,ar(i,1),m) + ti=dsum(n,ai(i,1),m) + vr(iv)=tr + vi(iv)=ti + iv=iv+nv + 30 continue + endif + return + end diff --git a/modules/elementary_functions/src/fortran/wmsum.lo b/modules/elementary_functions/src/fortran/wmsum.lo new file mode 100755 index 000000000..1601a6fd4 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wmsum.lo @@ -0,0 +1,12 @@ +# src/fortran/wmsum.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wmsum.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wmul.f b/modules/elementary_functions/src/fortran/wmul.f new file mode 100755 index 000000000..f939d5692 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wmul.f @@ -0,0 +1,18 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine wmul(ar,ai,br,bi,cr,ci) +c + double precision ar,ai,br,bi,cr,ci,t +c c = a*b + t = ar*bi + ai*br + cr = ar*br - ai*bi + ci = t + return + end diff --git a/modules/elementary_functions/src/fortran/wmul.lo b/modules/elementary_functions/src/fortran/wmul.lo new file mode 100755 index 000000000..3beb17022 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wmul.lo @@ -0,0 +1,12 @@ +# src/fortran/wmul.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wmul.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wrscal.f b/modules/elementary_functions/src/fortran/wrscal.f new file mode 100755 index 000000000..9b2b1eeea --- /dev/null +++ b/modules/elementary_functions/src/fortran/wrscal.f @@ -0,0 +1,37 @@ +C/MEMBR ADD NAME=WRSCAL,SSI=0 + subroutine wrscal(n,s,xr,xi,incx) +c!but +c +c cette subroutine calcule le produit d'une constante reelle +c double precision s par un vecteur complexe x, dont les +c reelles de ses composantes sont rangees dans xr et les +c parties imaginaires dans xi. +c +c!liste d'appel +c +c subroutine wrscal(n,s,xr,xi,incx) +c +c n: entier, longueur du vecteur x. +c +c s: double precision. the real factor +c +c xr, xi: doubles precision, parties reelles et imaginaires, +c respectivement, des composantes du vecteur x. +c +c incx: increment entre deux composantes consecutives de x. +c +c!auteur +c +c cleve moler.- matlab. +c +c! + double precision s,xr(*),xi(*) + if (n .le. 0) return + ix = 1 + do 10 i = 1, n + xr(ix) = s*xr(ix) + xi(ix) = s*xi(ix) + ix = ix + incx + 10 continue + return + end diff --git a/modules/elementary_functions/src/fortran/wrscal.lo b/modules/elementary_functions/src/fortran/wrscal.lo new file mode 100755 index 000000000..f50279b67 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wrscal.lo @@ -0,0 +1,12 @@ +# src/fortran/wrscal.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wrscal.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wscal.f b/modules/elementary_functions/src/fortran/wscal.f new file mode 100755 index 000000000..930d3bce8 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wscal.f @@ -0,0 +1,42 @@ + subroutine wscal(n,sr,si,xr,xi,incx) +c!but +c +c cette subroutine wscal multiplie une contante complexe s +c (dont la partie reelle est rangee dans sr et la partie +c imaginaire dans si) par un vecteur x (dont les parties +c reelles de ses composantes sont rangees dans xr et les +c parties imaginaires dans xi). le resultat reste dans x. +c +c!liste d'appel +c +c subroutine wscal(n,sr,si,xr,xi,incx) +c +c n: entier, taille du vecteur x. +c +c sr, si: double precision, parties reelle et imaginaire +c de s. +c +c xr, xi: vecteurs double precision, contiennent, +c respectivement, les parties reelles et imaginaires des +c composants du vecteur x. +c +c incx: entier, increment entre deux composantes consecutives +c de x. +c +c!routines auxilieres +c +c wmul +c +c!auteur +c +c cleve moler. +c + double precision sr,si,xr(*),xi(*) + if (n .le. 0) return + ix = 1 + do 10 i = 1, n + call wmul(sr,si,xr(ix),xi(ix),xr(ix),xi(ix)) + ix = ix + incx + 10 continue + return + end diff --git a/modules/elementary_functions/src/fortran/wscal.lo b/modules/elementary_functions/src/fortran/wscal.lo new file mode 100755 index 000000000..5689edd7e --- /dev/null +++ b/modules/elementary_functions/src/fortran/wscal.lo @@ -0,0 +1,12 @@ +# src/fortran/wscal.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wscal.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wshrsl.f b/modules/elementary_functions/src/fortran/wshrsl.f new file mode 100755 index 000000000..87d5488fa --- /dev/null +++ b/modules/elementary_functions/src/fortran/wshrsl.f @@ -0,0 +1,103 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA - Serge STEER +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c +C/MEMBR ADD NAME=WSHRSL,SSI=0 +c + subroutine wshrsl(ar,ai,br,bi,cr,ci,m,n,na,nb,nc,eps,rmax,fail) +c +c!purpose +c wshrsl is a fortran iv subroutine to solve the complex matrix +c equation ax + xb = c, where a is in lower triangular form +c and b is in upper triangular form, +c +c!calling sequence +c +c subroutine wshrsl(ar,ai,br,bi,cr,ci,m,n,na,nb,nc,eps,rmax,fail) +c ar,ai a doubly subscripted array containg the matrix a in +c lower triangular form +c +c br,bi a doubly subscripted array containing tbe matrix br,bi +c in upper triangular form +c +c cr,ci a doubly subscripted array containing the matrix c. +c +c m the order of the matrix a +c +c n the order of the matrix b +c +c na the first dimension of the array a +c +c nb the first dimension of the array b +c +c nc the first dimension of the array c +c +c eps tolerance on a(k,k)+b(l,l) +c if |a(k,k)+b(l,l)|<eps algorithm suppose that |a(k,k)+b(l,l)|=eps +c +c rmax maximum allowed size of any element of the transformation +c +c fail indicates if wshrsl failed +c +c!auxiliary routines +c ddot (blas) +c abs sqrt (fortran) +c!originator +c Steer Serge I.N.R.I.A from shrslv (Bartels and Steward) +c + integer m, n, na, nb, nc + double precision ar,ai, br,bi, cr,ci, eps,rmax + dimension ar(na,m),ai(na,m),br(nb,n),bi(nb,n),cr(nc,n),ci(nc,n) + logical fail +c internal variables +c + integer k,km1,l,lm1,i + double precision t,tr,ti,ddot +c + fail = .true. +c + l = 1 + 10 lm1 = l - 1 + if (l.eq.1) go to 30 + do 20 i=1,m + cr(i,l)=cr(i,l)-ddot(lm1,cr(i,1),nc,br(1,l),1) + 1 +ddot(lm1,ci(i,1),nc,bi(1,l),1) + ci(i,l)=ci(i,l)-ddot(lm1,cr(i,1),nc,bi(1,l),1) + 1 -ddot(lm1,ci(i,1),nc,br(1,l),1) + 20 continue +c + 30 k = 1 + 40 km1 = k - 1 + if (k.eq.1) go to 50 + cr(k,l) = cr(k,l) - ddot(km1,ar(k,1),na,cr(1,l),1) + 1 + ddot(km1,ai(k,1),na,ci(1,l),1) + ci(k,l) = ci(k,l) - ddot(km1,ar(k,1),na,ci(1,l),1) + 1 - ddot(km1,ai(k,1),na,cr(1,l),1) +c + 50 tr = ar(k,k) + br(l,l) + ti = ai(k,k) + bi(l,l) + t=tr*tr+ti*ti + if(t.lt.eps*eps) then + tr=1.0d0/eps + else + tr=tr/t + ti=ti/t + endif +c + t=cr(k,l)*tr+ci(k,l)*ti + ci(k,l)=-cr(k,l)*ti+ci(k,l)*tr + cr(k,l)=t + t=sqrt(t*t+ci(k,l)*ci(k,l)) + if (t.ge.rmax) return + k = k + 1 + if (k.le.m) go to 40 + l = l + 1 + if (l.le.n) go to 10 + fail = .false. + return + end diff --git a/modules/elementary_functions/src/fortran/wshrsl.lo b/modules/elementary_functions/src/fortran/wshrsl.lo new file mode 100755 index 000000000..ae4f1ef28 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wshrsl.lo @@ -0,0 +1,12 @@ +# src/fortran/wshrsl.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wshrsl.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wsign.f b/modules/elementary_functions/src/fortran/wsign.f new file mode 100755 index 000000000..fe687f64e --- /dev/null +++ b/modules/elementary_functions/src/fortran/wsign.f @@ -0,0 +1,20 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine wsign(xr,xi,yr,yi,zr,zi) +c + double precision xr,xi,yr,yi,zr,zi,pythag,t +c if y .ne. 0, z = x*y/abs(y) +c if y .eq. 0, z = x + t = pythag(yr,yi) + zr = xr + zi = xi + if (t .ne. 0.0d+0) call wmul(yr/t,yi/t,zr,zi,zr,zi) + return + end diff --git a/modules/elementary_functions/src/fortran/wsign.lo b/modules/elementary_functions/src/fortran/wsign.lo new file mode 100755 index 000000000..5aed4e223 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wsign.lo @@ -0,0 +1,12 @@ +# src/fortran/wsign.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wsign.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wsqrt.f b/modules/elementary_functions/src/fortran/wsqrt.f new file mode 100755 index 000000000..32898d3df --- /dev/null +++ b/modules/elementary_functions/src/fortran/wsqrt.f @@ -0,0 +1,172 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) Bruno Pincon +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + subroutine wsqrt(xr,xi,yr,yi) +* +* PURPOSE +* wsqrt compute the square root of a complex number +* y = yr + i yi = sqrt(x), x = xr + i xi +* +* CALLING LIST / PARAMETERS +* subroutine wsqrt(xr,xi,yr,yi) +* double precision xr,xi,yr,yi +* +* xr,xi: real and imaginary parts of the complex number +* yr,yi: real and imaginary parts of the result +* yr,yi may have the same memory cases than xr et xi +* +* ALGORITHM +* essentially the classic one which consists in +* choosing the good formula such as avoid cancellation ; +* Also rare spurious overflow are treated with a +* "manual" method. For some more "automated" methods +* (but currently difficult to implement in a portable +* way) see : +* +* Hull, Fairgrieve, Tang, +* "Implementing Complex Elementary Functions Using +* Exception Handling", ACM TOMS, Vol. 20 (1994), pp 215-244 +* +* for xr > 0 : +* yr = sqrt(2( xr + sqrt( xr^2 + xi^2)) )/ 2 +* yi = xi / sqrt(2(xr + sqrt(xr^2 + xi^2))) +* +* and for xr < 0 : +* yr = |xi| / sqrt( 2( -xr + sqrt( xr^2 + xi^2 )) ) +* yi = sign(xi) sqrt(2(-xr + sqrt( xr^2 + xi^2))) / 2 +* +* for xr = 0 use +* yr = sqrt(0.5)*sqrt(|xi|) when |xi| is such that 0.5*|xi| may underflow +* = sqrt(0.5*|xi|) else +* yi = sign(xi) yr +* +* Noting t = sqrt( 2( |xr| + sqrt( xr^2 + yr^2)) ) +* = sqrt( 2( |xr| + pythag(xr,xi) ) ) +* it comes : +* +* for xr > 0 | for xr < 0 +* --------------+--------------------- +* yr = 0.5*t | yr = |xi| / t +* yi = xi / t | yi = sign(xi)*0.5* t +* +* as the function pythag must not underflow (and overflow only +* if sqrt(x^2+y^2) > rmax) only spurious (rare) case of overflow +* occurs in which case a scaling is done. +* +* AUTHOR +* Bruno Pincon <Bruno.Pincon@iecn.u-nancy.fr> +* + implicit none + +* PARAMETER + double precision xr, xi, yr, yi + +* LOCAL VAR + double precision a, b, t +* EXTERNAL + double precision pythag, dlamch + external pythag, dlamch + integer isanan + external isanan + +* STATIC VAR + logical first + double precision RMAX, BRMIN + save first + data first /.true./ + save RMAX, BRMIN + + + if (first) then + RMAX = dlamch('O') + BRMIN = 2.d0*dlamch('U') + first = .false. + endif + + a = xr + b = xi + + if ( a .eq. 0.d0 ) then +* pure imaginary case + if ( abs(b) .ge. BRMIN ) then + yr = sqrt(0.5d0*abs(b)) + else + yr = sqrt(abs(b))*sqrt(0.5d0) + endif + yi = sign(1.d0, b)*yr + + elseif ( abs(a).le.RMAX .and. abs(b).le.RMAX ) then +* standard case : a (not zero) and b are finite + t = sqrt(2.d0*(abs(a) + pythag(a,b))) +* overflow test + if ( t .gt. RMAX ) goto 100 +* classic switch to get the stable formulas + if ( a .ge. 0.d0 ) then + yr = 0.5d0*t + yi = b/t + else + yr = abs(b)/t + if ( b .ge. 0 ) then + yi = 0.5d0*t + else + yi = -0.5d0*t + endif + endif + else +* Here we treat the special cases where a and b are +- 00 or NaN. +* The following is the treatment recommended by the C99 standard +* with the simplification of returning NaN + i NaN if the +* the real part or the imaginary part is NaN (C99 recommends +* something more complicated) + if ( (isanan(a) .eq. 1) .or. (isanan(b) .eq. 1) ) then +* got NaN + i NaN + yr = a + b + yi = yr + elseif ( abs(b) .gt. RMAX ) then +* case a +- i oo -> result must be +oo +- i oo for all a (finite or not) + yr = abs(b) + yi = b + elseif ( a .lt. -RMAX ) then +* here a is -Inf and b is finite + yr = 0.d0 + if ( b .ge. 0 ) then + yi = 1.d0*abs(a) + else + yi = -1.d0*abs(a) + endif + else +* here a is +Inf and b is finite + yr = a + yi = 0.d0 + endif + endif + + return + +* handle (spurious) overflow by scaling a and b + 100 continue + a = a/16.d0 + b = b/16.d0 + t = sqrt(2.d0*(abs(a) + pythag(a,b))) + if ( a .ge. 0.d0 ) then + yr = 2.d0*t + yi = 4.d0*b/t + else + yr = 4.d0*abs(b)/t + if ( b .ge. 0 ) then + yi = 2.d0*t + else + yi = -2.d0*t + endif + endif + + end + + + diff --git a/modules/elementary_functions/src/fortran/wsqrt.lo b/modules/elementary_functions/src/fortran/wsqrt.lo new file mode 100755 index 000000000..a5ca35bd4 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wsqrt.lo @@ -0,0 +1,12 @@ +# src/fortran/wsqrt.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wsqrt.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wswap.f b/modules/elementary_functions/src/fortran/wswap.f new file mode 100755 index 000000000..77e8df996 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wswap.f @@ -0,0 +1,50 @@ +C/MEMBR ADD NAME=WSWAP,SSI=0 + subroutine wswap(n,xr,xi,incx,yr,yi,incy) +c!but +c +c cette subroutine wswap echange le contenu de deux vecteurs +c complexes x et y (dont les parties reelles de ses +c composantes sont rangees, respectivement, dans xr et yr +c et les parties imaginaires dans xi et yi). +c +c!liste d'appel +c +c subroutine wswap(n,xr,xi,incx,yr,yi,incy) +c +c n: entier, taille des vecteur x et y. +c +c xr, xi: vecteurs double precision, parties reelles et +c imaginaires, respectivement, des composantes du vecteur x. +c +c incx: entier, increment entre deux elements consecutifs +c de x. +c +c yr, yi: vecteurs double precision, parties reelles et +c imaginaire, respectivement, des composantes du vecteur y. +c +c incy: entier, increment entre deux elements consecutifs +c de x. +c +c!auteur +c +c cleve moler.- matlab. +c +c! + double precision xr(*),xi(*),yr(*),yi(*),t + if (n .le. 0) return + 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 + t = xr(ix) + xr(ix) = yr(iy) + yr(iy) = t + t = xi(ix) + xi(ix) = yi(iy) + yi(iy) = t + ix = ix + incx + iy = iy + incy + 10 continue + return + end diff --git a/modules/elementary_functions/src/fortran/wswap.lo b/modules/elementary_functions/src/fortran/wswap.lo new file mode 100755 index 000000000..cb7a4631c --- /dev/null +++ b/modules/elementary_functions/src/fortran/wswap.lo @@ -0,0 +1,12 @@ +# src/fortran/wswap.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wswap.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wtan.f b/modules/elementary_functions/src/fortran/wtan.f new file mode 100755 index 000000000..0a80c8437 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wtan.f @@ -0,0 +1,123 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) Bruno Pincon +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + subroutine wtan(xr,xi,yr,yi) +* +* PURPOSE +* wtan compute the tangent of a complex number +* y = yr + i yi = tan(x), x = xr + i xi +* +* CALLING LIST / PARAMETERS +* subroutine wtan(xr,xi,yr,yi) +* double precision xr,xi,yr,yi +* +* xr,xi: real and imaginary parts of the complex number +* yr,yi: real and imaginary parts of the result +* yr,yi may have the same memory cases than xr et xi +* +* ALGORITHM +* based on the formula : +* +* 0.5 sin(2 xr) + i 0.5 sinh(2 xi) +* tan(xr + i xi) = --------------------------------- +* cos(xr)^2 + sinh(xi)^2 +* +* noting d = cos(xr)^2 + sinh(xi)^2, we have : +* +* yr = 0.5 * sin(2 * xr) / d (1) +* +* yi = 0.5 * sinh(2 * xi) / d (2) +* +* to avoid spurious overflows in computing yi with +* formula (2) (which results in NaN for yi) +* we use also the following formula : +* +* yi = sign(xi) when |xi| > LIM (3) +* +* Explanations for (3) : +* +* we have d = sinh(xi)^2 ( 1 + (cos(xr)/sinh(xi))^2 ), +* so when : +* +* (cos(xr)/sinh(xi))^2 < epsm ( epsm = max relative error +* for coding a real in a f.p. +* number set F(b,p,emin,emax) +* epsm = 0.5 b^(1-p) ) +* which is forced when : +* +* 1/sinh(xi)^2 < epsm (4) +* <=> |xi| > asinh(1/sqrt(epsm)) (= 19.06... in ieee 754 double) +* +* sinh(xi)^2 is a good approximation for d (relative to the f.p. +* arithmetic used) and then yr may be approximate with : +* +* yr = cosh(xi)/sinh(xi) +* = sign(xi) (1 + exp(-2 |xi|))/(1 - exp(-2|xi|)) +* = sign(xi) (1 + 2 u + 2 u^2 + 2 u^3 + ...) +* +* with u = exp(-2 |xi|)). Now when : +* +* 2 exp(-2|xi|) < epsm (2) +* <=> |xi| > 0.5 * log(2/epsm) (= 18.71... in ieee 754 double) +* +* sign(xi) is a good approximation for yr. +* +* Constraint (1) is stronger than (2) and we take finaly +* +* LIM = 1 + log(2/sqrt(epsm)) +* +* (log(2/sqrt(epsm)) being very near asinh(1/sqrt(epsm)) +* +* AUTHOR +* Bruno Pincon <Bruno.Pincon@iecn.u-nancy.fr> +* + implicit none + +* PARAMETER + double precision xr, xi, yr, yi + +* LOCAL VAR + double precision sr, si, d +* EXTERNAL + double precision dlamch + external dlamch + +* STATIC VAR + logical first + double precision LIM + + save first + data first /.true./ + save LIM + + + if (first) then +* epsm is gotten with dlamch('e') + LIM = 1.d0 + log(2.d0/sqrt(dlamch('e'))) + first = .false. + endif + +* (0) avoid memory pb ... + sr = xr + si = xi + +* (1) go on .... + d = cos(sr)**2 + sinh(si)**2 + yr= 0.5d0*sin(2.d0*sr)/d + if (abs(si) .lt. LIM) then + yi=0.5d0*sinh(2.d0*si)/d + else + yi=sign(1.d0,si) + endif + + end + + + + diff --git a/modules/elementary_functions/src/fortran/wtan.lo b/modules/elementary_functions/src/fortran/wtan.lo new file mode 100755 index 000000000..5ce91aa80 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wtan.lo @@ -0,0 +1,12 @@ +# src/fortran/wtan.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wtan.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wvmul.f b/modules/elementary_functions/src/fortran/wvmul.f new file mode 100755 index 000000000..b973b87c8 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wvmul.f @@ -0,0 +1,66 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA - Serge STEER +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c +C/MEMBR ADD NAME=WVMUL,SSI=0 +c + subroutine wvmul(n,dxr,dxi,incx,dyr,dyi,incy) +c!but +c +c etant donne un vecteur dx et un vecteur dy complexes, +c cette subroutine fait: +c dy = dy * dx +c quand les deux increments sont egaux a un, cette +c subroutine emploie des boucles "epanouis". dans le cas ou +c les increments sont negatifs, cette subroutine prend +c les composantes en ordre inverse. +c +c!liste d'appel +c +c subroutine wvmul(n,dxr,dxi,incx,dyr,dyi,incy) +c +c dy, dx: vecteurs double precision. +c +c incx, incy: increments entre deux composantes successives +c des vecteurs. +c +c!auteur +c +c serge steer inria +c! + double precision dxr(*),dxi(*),dyr(*),dyi(*),sr + integer i,incx,incy,n +c + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments not equal to 1 +c + 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 + sr=dyr(iy) + dyr(iy)=sr*dxr(ix) - dyi(iy)*dxi(ix) + dyi(iy)=sr*dxi(ix) + dyi(iy)*dxr(ix) + ix = ix + incx + iy = iy + incy + 10 continue + return +c +c code for both increments equal to 1 +c + 20 continue + do 30 i = 1,n + sr=dyr(i) + dyr(i)=sr*dxr(i) - dyi(i)*dxi(i) + dyi(i)=sr*dxi(i) + dyi(i)*dxr(i) + 30 continue +c + end diff --git a/modules/elementary_functions/src/fortran/wvmul.lo b/modules/elementary_functions/src/fortran/wvmul.lo new file mode 100755 index 000000000..6248d746f --- /dev/null +++ b/modules/elementary_functions/src/fortran/wvmul.lo @@ -0,0 +1,12 @@ +# src/fortran/wvmul.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wvmul.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wwdiv.f b/modules/elementary_functions/src/fortran/wwdiv.f new file mode 100755 index 000000000..8aa81646d --- /dev/null +++ b/modules/elementary_functions/src/fortran/wwdiv.f @@ -0,0 +1,77 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) Bruno Pincon +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + + subroutine wwdiv(ar, ai, br, bi, cr, ci, ierr) +* +* PURPOSE +* complex division algorithm : compute c := a / b +* where : +* +* a = ar + i ai +* b = br + i bi +* c = cr + i ci +* +* inputs : ar, ai, br, bi (double precision) +* outputs : cr, ci (double precision) +* ierr (integer) ierr = 1 if b = 0 (else 0) +* +* IMPLEMENTATION NOTES +* 1/ Use scaling with ||b||_oo; the original wwdiv.f used a scaling +* with ||b||_1. It results fewer operations. From the famous +* Golberg paper. This is known as Smith's method. +* 2/ Currently set c = NaN + i NaN in case of a division by 0 ; +* is that the good choice ? +* +* AUTHOR +* Bruno Pincon <Bruno.Pincon@iecn.u-nancy.fr> +* + implicit none + +* PARAMETERS + double precision ar, ai, br, bi, cr, ci + integer ierr + +* LOCAL VARIABLES + double precision r, d + +* TEXT + ierr = 0 + +* Treat special cases + if (bi .eq. 0d0) then + if (br .eq. 0d0) then + ierr = 1 +* got NaN + i NaN + cr = bi / br + ci = cr + else + cr = ar / br + ci = ai / br + endif + elseif (br .eq. 0d0) then + cr = ai / bi + ci = (-ar) / bi + else +* Generic division algorithm + if (abs(br) .ge. abs(bi)) then + r = bi / br + d = br + r*bi + cr = (ar + ai*r) / d + ci = (ai - ar*r) / d + else + r = br / bi + d = bi + r*br + cr = (ar*r + ai) / d + ci = (ai*r - ar) / d + endif + endif + + end + + diff --git a/modules/elementary_functions/src/fortran/wwdiv.lo b/modules/elementary_functions/src/fortran/wwdiv.lo new file mode 100755 index 000000000..b8698e337 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wwdiv.lo @@ -0,0 +1,12 @@ +# src/fortran/wwdiv.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wwdiv.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wwpow.f b/modules/elementary_functions/src/fortran/wwpow.f new file mode 100755 index 000000000..8743148c7 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wwpow.f @@ -0,0 +1,62 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) 1989 - INRIA - Serge STEER +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine wwpow(n,vr,vi,iv,powr,powi,ierr) +c!but +c eleve les elements d'un vecteur complexe a une puissance complexe +c!liste d'appel +c subroutine wwpow(n,vr,vi,iv,powr,powi,ierr) +c integer n,iv,ierr +c double precision vr(n*iv),vi(n*iw),powr,powi +c +c n : nombre d'element du vecteur +c vr : tableau contenant les parties reelles des elements du vecteur +c vi : tableau contenant les parties imaginaires des elements du vecteur +c iv : increment entre deux element consecutif du vecteur dans le +c tableau v +c powr : partie reelle de la puissance a la quelle doivent etre +c eleves les elements du vecteur +c powi : partie imaginaire de la puissance a la quelle doivent etre +c eleves les elements du vecteur +c ierr : indicateur d'erreur +c ierr=0 si ok +c ierr=1 si 0**0 +c ierr=2 si 0**k avec k<0 +c!origine +c Serge Steer INRIA 1989 +c + integer n,iv,ierr + double precision vr(*),vi(*),powr,powi,sr,si +c + ierr=0 +c + if(powi.ne.0.0d+0) goto 01 +c puissance reelle + call wdpow(n,vr,vi,iv,powr,ierr) + return +c + 01 continue +c puissance complexes + ii=1 + do 20 i=1,n + if(abs(vr(ii))+abs(vi(ii)).ne.0.0d+0) then + call wlog(vr(ii),vi(ii),sr,si) + call wmul(sr,si,powr,powi,sr,si) + sr=exp(sr) + vr(ii)=sr*cos(si) + vi(ii)=sr*sin(si) + ii=ii+iv + else + ierr=0 + return + endif + 20 continue +c + return + end diff --git a/modules/elementary_functions/src/fortran/wwpow.lo b/modules/elementary_functions/src/fortran/wwpow.lo new file mode 100755 index 000000000..4e69e813c --- /dev/null +++ b/modules/elementary_functions/src/fortran/wwpow.lo @@ -0,0 +1,12 @@ +# src/fortran/wwpow.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wwpow.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wwpow1.f b/modules/elementary_functions/src/fortran/wwpow1.f new file mode 100755 index 000000000..af6971848 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wwpow1.f @@ -0,0 +1,62 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) 1996 - INRIA - Serge STEER +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine wwpow1(n,vr,vi,iv,pr,pi,ip,rr,ri,ir,ierr) +c!purpose +c computes V^P with V and P complex vectors +c!calling sequence +c subroutine wwpow1(n,vr,vi,iv,pr,pi,ip,rr,ri,ir,ierr) +c integer n,iv,ip,ir,ierr +c double precision vr(*),vi(*),pr(*),pi(*),rr(*),ri(*) +c +c n : number of elements of V and P vectors +c vr : array containing real part of V elements +c real(V(i))=vr(1+(i-1)*iv) +c vi : array containing imaginary part of V elements +c imag(V(i))=vi(1+(i-1)*iv) +c iv : increment between two V elements in v (may be 0) +c pr : array containing real part of P elements +c real(P(i))=pr(1+(i-1)*iv) +c pi : array containing imaginary part of P elements +c imag(P(i))=pi(1+(i-1)*iv) +c ip : increment between two P elements in p (may be 0) +c rr : array containing real part of the results vector R: +c real(R(i))=rr(1+(i-1)*ir) +c ri : array containing imaginary part of the results vector R: +c imag(R(i))=ri(1+(i-1)*ir) +c ir : increment between two R elements in rr and ri +c ierr : error flag +c ierr=0 if ok +c ierr=1 if 0**0 +c ierr=2 if 0**k with k<0 +c!origin +c Serge Steer INRIA 1996 +c + integer n,iv,ierr,ierr1 + double precision vr(*),vi(*),pr(*),pi(*),rr(*),ri(*) +c + ierr=0 + iscmpl=0 +c + + ii=1 + iip=1 + iir=1 + do 20 i=1,n + call wwpowe(vr(ii),vi(ii),pr(iip),pi(iip), + $ rr(iir),ri(iir),ierr1) + ierr=max(ierr,ierr1) +c if(ierr.ne.0) return + ii=ii+iv + iip=iip+ip + iir=iir+ir + 20 continue +c + return + end diff --git a/modules/elementary_functions/src/fortran/wwpow1.lo b/modules/elementary_functions/src/fortran/wwpow1.lo new file mode 100755 index 000000000..e141c7ed2 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wwpow1.lo @@ -0,0 +1,12 @@ +# src/fortran/wwpow1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wwpow1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wwpowe.f b/modules/elementary_functions/src/fortran/wwpowe.f new file mode 100755 index 000000000..251cfd258 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wwpowe.f @@ -0,0 +1,52 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) 1996 - INRIA - Serge STEER +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine wwpowe(vr,vi,pr,pi,rr,ri,ierr) +c!purpose +c computes v^p with v complex and p complex +c!calling sequence +c subroutine wdpowe(vr,vi,p,rr,ri,ierr) +c integer ierr +c double precision vr,vi,pr,pi,rr,ri +c vr : real part of v +c vi : imaginary part of v +c pr : real part of p +c pi : imaginary part of p +c rr : result's real part +c ri : result's imaginary part +c ierr : error flag +c ierr=0 if ok +c ierr=1 if 0**0 +c ierr=2 if 0**k with k<0 +c!origin +c Serge Steer INRIA 1996 +c + integer ierr + double precision vr,vi,pr,pi,sr,si,rr,ri,infinity +c + ierr=0 +c + if(pi.eq.0.0d+0) then + call wdpowe(vr,vi,pr,rr,ri,ierr) + else + if(abs(vr)+abs(vi).ne.0.0d+0) then + call wlog(vr,vi,sr,si) + call wmul(sr,si,pr,pi,sr,si) + sr=exp(sr) + rr=sr*cos(si) + ri=sr*sin(si) + else + ri=0.0d0 + rr=infinity(ri) + ierr=2 + endif + endif +c + return + end diff --git a/modules/elementary_functions/src/fortran/wwpowe.lo b/modules/elementary_functions/src/fortran/wwpowe.lo new file mode 100755 index 000000000..83fc3d51e --- /dev/null +++ b/modules/elementary_functions/src/fortran/wwpowe.lo @@ -0,0 +1,12 @@ +# src/fortran/wwpowe.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wwpowe.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/elementary_functions/src/fortran/wwrdiv.f b/modules/elementary_functions/src/fortran/wwrdiv.f new file mode 100755 index 000000000..c88c780a9 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wwrdiv.f @@ -0,0 +1,70 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine wwrdiv(ar,ai,ia,br,bi,ib,rr,ri,ir,n,ierr) +c! purpose +c computes r=a./b with a and b complex vectors +c +c ia,ib,ir : increment between two consecutive element of vectors a +c b and r +c ar,ai : arrays containing a real and imaginary parts +c br,bi : arrays containing b real and imaginary parts +c rr,ri : arrays containing r real and imaginary parts +c n : vectors length +c ierr : returned error flag: +c o : ok +c <>0 : b(ierr)=0 +c + double precision ar(*),ai(*),br(*),bi(*),rr(*),ri(*) +c wr, wi used because rr, ri may share same mem as ar,ai or br,bi + double precision wr,wi + integer ia,ib,ir,n + jr=1 + jb=1 + ja=1 + ierr=0 + if (ia.eq.0) then + do 10 k=1,n + call wwdiv(ar(ja),ai(ja),br(jb),bi(jb),wr,wi,ierr1) + rr(jr)=wr + ri(jr)=wi + if(ierr1.ne.0) then + ierr=k +c return + endif + jr=jr+ir + jb=jb+ib + 10 continue + elseif(ib.eq.0) then + if(abs(br(jb))+abs(bi(jb)).eq.0.0d0) then + ierr=1 +c return + endif + do 11 k=1,n + call wwdiv(ar(ja),ai(ja),br(jb),bi(jb),wr,wi,ierr1) + rr(jr)=wr + ri(jr)=wi + jr=jr+ir + ja=ja+ia + 11 continue + else + do 12 k=1,n + call wwdiv(ar(ja),ai(ja),br(jb),bi(jb),wr,wi,ierr1) + rr(jr)=wr + ri(jr)=wi + if(ierr1.ne.0) then + ierr=k +c return + endif + jr=jr+ir + jb=jb+ib + ja=ja+ia + 12 continue + endif + end diff --git a/modules/elementary_functions/src/fortran/wwrdiv.lo b/modules/elementary_functions/src/fortran/wwrdiv.lo new file mode 100755 index 000000000..2c1790780 --- /dev/null +++ b/modules/elementary_functions/src/fortran/wwrdiv.lo @@ -0,0 +1,12 @@ +# src/fortran/wwrdiv.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/wwrdiv.o' + +# Name of the non-PIC object +non_pic_object=none + |