QPMS
/
qpms
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Compare commits

base: QPMS:master
Branches Tags
QPMS:master
QPMS:cython3
QPMS:argproc_constant_tmatrix
QPMS:ewald_dbg
QPMS:versioning
QPMS:ci
QPMS:archive/ewald_dbg_202206
QPMS:ewald_dbg_rebased2
QPMS:catch_test
QPMS:article
QPMS:zbessel
QPMS:finite_lattice_speedup
QPMS:precise_polynomials
QPMS:latticegen3d
..
compare: QPMS:zbessel
Branches Tags
QPMS:cython3
QPMS:master
QPMS:argproc_constant_tmatrix
QPMS:ewald_dbg
QPMS:versioning
QPMS:ci
QPMS:archive/ewald_dbg_202206
QPMS:ewald_dbg_rebased2
QPMS:catch_test
QPMS:article
QPMS:zbessel
QPMS:finite_lattice_speedup
QPMS:precise_polynomials
QPMS:latticegen3d

1 Commits
master ... zbessel

Author SHA1 Message Date
Marek Nečada 9d8a0c1d45 Replace Amos with zbessel (shared version) 
zbessel as shared library can be found e.g. here:
https://github.com/texnokrates/zbessel

Former-commit-id: 3cc66da970731e37a242459f8af3d4b68f362c75
 2020-03-12 21:09:20 +02:00
207 changed files with 6095 additions and 23361 deletions
Show Stats Expand all files Collapse all files

83
.drone.yml
View File

@ -1,83 +0,0 @@
---
kind: pipeline
type: docker
name: buildqpms-alpine-preinstlibs
workspace:
path: /home/qpmsbuild/qpms
# don't run in master until the python/lapacke linking problem is resolved
trigger:
branch:
exclude:
- master
steps:
- name: chown
image: qpms/buildenv/alpine/pkgdnumlib
pull: never
commands:
- chown -R qpmsbuild.qpmsbuild .
- name: submodules
image: qpms/buildenv/alpine/pkgdnumlib
pull: never
user: qpmsbuild
commands:
- git submodule init
- git submodule update
- name: build
image: qpms/buildenv/alpine/pkgdnumlib
pull: never
user: qpmsbuild
commands:
- cmake -DCMAKE_INSTALL_PREFIX=$HOME/.local .
- make install
- export LIBRARY_PATH=$HOME/.local/lib
- python3 setup.py install --user
- cd examples/rectangular/modes
- pip3 install --user matplotlib #needed to run the example
- export LD_LIBRARY_PATH=$HOME/.local/lib
- ./01a_realfreq_svd.sh
---
kind: pipeline
type: docker
name: buildqpms-debian-preinstlibs
workspace:
path: /home/qpmsbuild/qpms
steps:
- name: chown
image: qpms/buildenv/debian/pkgdnumlib
pull: never
commands:
- chown -R qpmsbuild.qpmsbuild .
- name: submodules
image: qpms/buildenv/debian/pkgdnumlib
pull: never
user: qpmsbuild
commands:
- git submodule init
- git submodule update
- name: build
image: qpms/buildenv/debian/pkgdnumlib
pull: never
user: qpmsbuild
commands:
- cmake -DCMAKE_INSTALL_PREFIX=/home/qpmsbuild/.local .
- make install
- export LIBRARY_PATH=$HOME/.local/lib
- python3 setup.py install --user
- pip3 install --user matplotlib #needed to run the examples
- export LD_LIBRARY_PATH=$HOME/.local/lib
- cd examples/rectangular/modes
- ./01a_realfreq_svd.sh
- cd -
- cd examples/hexagonal/modes
#- ./01a_realfreq_svd.sh
#- ./01_compute_modes.sh
#- ./02b_compute_disp_0M.sh
#- ./02_compute_disp.sh
#- ./02x_compute_disp.sh

25
.gitignore vendored
View File

@ -5,29 +5,4 @@
*.pdf
*.o
docs/*
qpms/qpms_c.c
qpms/cy*.c
CMakeCache.txt
CMakeFiles/*
faddeeva/*
qpms/CMakeFiles/*
qpms/libqpms.so
qpms/cmake_install.cmake
qpms_version.c
qpms.egg_info/*
dist/*
build/*
Makefile
CTestTestfile.cmake
amos/CMakeFiles/*
amos/Makefile
amos/amos_mangling.h
cmake_install.cmake
cython_debug/*
qpms.egg-info/*
tests/CmakeFiles/*
tests/cmake_install.cmake
tests/CMakeFiles/*

4
.gitmodules vendored
View File

@ -1,4 +0,0 @@
[submodule "camos"]
path = camos
url = https://codeberg.org/QPMS/zbessel.git
branch = purec

43
CLIUTILS.md
View File

@ -1,43 +0,0 @@
Overview of QPMS command line utilities
=======================================
The utilities are located in the `misc` directory. Run the
utility with `-h` argument to get more info.
Rectangular and square 2D lattices
----------------------------------
These scripts deal with simple 2D rectangular lattices,
finite or infinite, one scatterer per unit cell.
\f$ D_{2h} \f$ or \f$ D_{4h} \f$ symmetric adapted bases
are used where applicable.
### Finite lattices
* `finiterectlat-modes.py`: Search for resonances using Beyn's algorithm.
* `finiterectlat-scatter.py`: Plane wave scattering.
* `finiterectlat-constant-driving.py`: Rectangular array response to
a driving where a subset of particles are excited by basis VSWFs with the
same phase.
### Infinite lattices
* `rectlat_simple_modes.py`: Search for lattice modes using Beyn's algorithm.
* `infiniterectlat-k0realfreqsvd.py`:
Evaluate the lattice mode problem singular values at the Γ point for a real frequency interval.
Useful as a starting point in lattice mode search before using Beyn's algorithm.
* `infiniterectlat-scatter.py`: Plane wave scattering.
General 2D lattices
-------------------
### Infinite lattices
These can contain several scatterers per unit cell. Symmetry adapted bases currently not implemented.
* `lat2d_modes.py`: Search for lattice modes using Beyn's algorithm.
* `lat2d_realfreqsvd.py`:
Evaluate the lattice mode problem singular values at the Γ point for a real frequency interval.
Useful as a starting point in lattice mode search before using Beyn's algorithm.

26
CMakeLists.txt
View File

@ -1,17 +1,10 @@
cmake_minimum_required(VERSION 3.0.2)
option(QPMS_USE_FORTRAN_AMOS "Use the original AMOS Fortran libraries instead of the C ones" OFF)
if (QPMS_USE_FORTRAN_AMOS)
include(CMakeAddFortranSubdirectory)
endif (QPMS_USE_FORTRAN_AMOS)
set (CMAKE_MODULE_PATH "${CMAKE_MODULE_PATH};${CMAKE_CURRENT_SOURCE_DIR}/cmake-scripts")
include(version.cmake)
include(GNUInstallDirs)
project (QPMS)
list(APPEND CMAKE_MODULE_PATH "${CMAKE_CURRENT_SOURCE_DIR}/cmake/")
macro(use_c99)
if (CMAKE_VERSION VERSION_LESS "3.1")
if (CMAKE_C_COMPILER_ID STREQUAL "GNU")
@ -29,23 +22,6 @@ set(CMAKE_POSITION_INDEPENDENT_CODE ON)
set (QPMS_VERSION_MAJOR 0)
#set (QPMS_VERSION_MINOR 3)
if (QPMS_USE_FORTRAN_AMOS)
cmake_add_fortran_subdirectory (amos
PROJECT amos
LIBRARIES amos
NO_EXTERNAL_INSTALL)
set(QPMS_AMOSLIB amos)
else (QPMS_USE_FORTRAN_AMOS)
set(CAMOS_BUILD_STATIC ON)
add_subdirectory (camos)
set(QPMS_AMOSLIB camos)
endif (QPMS_USE_FORTRAN_AMOS)
set(FADDEEVA_BUILD_STATIC ON)
add_subdirectory(faddeeva)
add_subdirectory (qpms)

675
COPYING.md
View File

@ -1,675 +0,0 @@
### GNU GENERAL PUBLIC LICENSE
Version 3, 29 June 2007
Copyright (C) 2007 Free Software Foundation, Inc.
<https://fsf.org/>
Everyone is permitted to copy and distribute verbatim copies of this
license document, but changing it is not allowed.
### Preamble
The GNU General Public License is a free, copyleft license for
software and other kinds of works.
The licenses for most software and other practical works are designed
to take away your freedom to share and change the works. By contrast,
the GNU General Public License is intended to guarantee your freedom
to share and change all versions of a program--to make sure it remains
free software for all its users. We, the Free Software Foundation, use
the GNU General Public License for most of our software; it applies
also to any other work released this way by its authors. You can apply
it to your programs, too.
When we speak of free software, we are referring to freedom, not
price. Our General Public Licenses are designed to make sure that you
have the freedom to distribute copies of free software (and charge for
them if you wish), that you receive source code or can get it if you
want it, that you can change the software or use pieces of it in new
free programs, and that you know you can do these things.
To protect your rights, we need to prevent others from denying you
these rights or asking you to surrender the rights. Therefore, you
have certain responsibilities if you distribute copies of the
software, or if you modify it: responsibilities to respect the freedom
of others.
For example, if you distribute copies of such a program, whether
gratis or for a fee, you must pass on to the recipients the same
freedoms that you received. You must make sure that they, too, receive
or can get the source code. And you must show them these terms so they
know their rights.
Developers that use the GNU GPL protect your rights with two steps:
(1) assert copyright on the software, and (2) offer you this License
giving you legal permission to copy, distribute and/or modify it.
For the developers' and authors' protection, the GPL clearly explains
that there is no warranty for this free software. For both users' and
authors' sake, the GPL requires that modified versions be marked as
changed, so that their problems will not be attributed erroneously to
authors of previous versions.
Some devices are designed to deny users access to install or run
modified versions of the software inside them, although the
manufacturer can do so. This is fundamentally incompatible with the
aim of protecting users' freedom to change the software. The
systematic pattern of such abuse occurs in the area of products for
individuals to use, which is precisely where it is most unacceptable.
Therefore, we have designed this version of the GPL to prohibit the
practice for those products. If such problems arise substantially in
other domains, we stand ready to extend this provision to those
domains in future versions of the GPL, as needed to protect the
freedom of users.
Finally, every program is threatened constantly by software patents.
States should not allow patents to restrict development and use of
software on general-purpose computers, but in those that do, we wish
to avoid the special danger that patents applied to a free program
could make it effectively proprietary. To prevent this, the GPL
assures that patents cannot be used to render the program non-free.
The precise terms and conditions for copying, distribution and
modification follow.
### TERMS AND CONDITIONS
#### 0. Definitions.
"This License" refers to version 3 of the GNU General Public License.
"Copyright" also means copyright-like laws that apply to other kinds
of works, such as semiconductor masks.
"The Program" refers to any copyrightable work licensed under this
License. Each licensee is addressed as "you". "Licensees" and
"recipients" may be individuals or organizations.
To "modify" a work means to copy from or adapt all or part of the work
in a fashion requiring copyright permission, other than the making of
an exact copy. The resulting work is called a "modified version" of
the earlier work or a work "based on" the earlier work.
A "covered work" means either the unmodified Program or a work based
on the Program.
To "propagate" a work means to do anything with it that, without
permission, would make you directly or secondarily liable for
infringement under applicable copyright law, except executing it on a
computer or modifying a private copy. Propagation includes copying,
distribution (with or without modification), making available to the
public, and in some countries other activities as well.
To "convey" a work means any kind of propagation that enables other
parties to make or receive copies. Mere interaction with a user
through a computer network, with no transfer of a copy, is not
conveying.
An interactive user interface displays "Appropriate Legal Notices" to
the extent that it includes a convenient and prominently visible
feature that (1) displays an appropriate copyright notice, and (2)
tells the user that there is no warranty for the work (except to the
extent that warranties are provided), that licensees may convey the
work under this License, and how to view a copy of this License. If
the interface presents a list of user commands or options, such as a
menu, a prominent item in the list meets this criterion.
#### 1. Source Code.
The "source code" for a work means the preferred form of the work for
making modifications to it. "Object code" means any non-source form of
a work.
A "Standard Interface" means an interface that either is an official
standard defined by a recognized standards body, or, in the case of
interfaces specified for a particular programming language, one that
is widely used among developers working in that language.
The "System Libraries" of an executable work include anything, other
than the work as a whole, that (a) is included in the normal form of
packaging a Major Component, but which is not part of that Major
Component, and (b) serves only to enable use of the work with that
Major Component, or to implement a Standard Interface for which an
implementation is available to the public in source code form. A
"Major Component", in this context, means a major essential component
(kernel, window system, and so on) of the specific operating system
(if any) on which the executable work runs, or a compiler used to
produce the work, or an object code interpreter used to run it.
The "Corresponding Source" for a work in object code form means all
the source code needed to generate, install, and (for an executable
work) run the object code and to modify the work, including scripts to
control those activities. However, it does not include the work's
System Libraries, or general-purpose tools or generally available free
programs which are used unmodified in performing those activities but
which are not part of the work. For example, Corresponding Source
includes interface definition files associated with source files for
the work, and the source code for shared libraries and dynamically
linked subprograms that the work is specifically designed to require,
such as by intimate data communication or control flow between those
subprograms and other parts of the work.
The Corresponding Source need not include anything that users can
regenerate automatically from other parts of the Corresponding Source.
The Corresponding Source for a work in source code form is that same
work.
#### 2. Basic Permissions.
All rights granted under this License are granted for the term of
copyright on the Program, and are irrevocable provided the stated
conditions are met. This License explicitly affirms your unlimited
permission to run the unmodified Program. The output from running a
covered work is covered by this License only if the output, given its
content, constitutes a covered work. This License acknowledges your
rights of fair use or other equivalent, as provided by copyright law.
You may make, run and propagate covered works that you do not convey,
without conditions so long as your license otherwise remains in force.
You may convey covered works to others for the sole purpose of having
them make modifications exclusively for you, or provide you with
facilities for running those works, provided that you comply with the
terms of this License in conveying all material for which you do not
control copyright. Those thus making or running the covered works for
you must do so exclusively on your behalf, under your direction and
control, on terms that prohibit them from making any copies of your
copyrighted material outside their relationship with you.
Conveying under any other circumstances is permitted solely under the
conditions stated below. Sublicensing is not allowed; section 10 makes
it unnecessary.
#### 3. Protecting Users' Legal Rights From Anti-Circumvention Law.
No covered work shall be deemed part of an effective technological
measure under any applicable law fulfilling obligations under article
11 of the WIPO copyright treaty adopted on 20 December 1996, or
similar laws prohibiting or restricting circumvention of such
measures.
When you convey a covered work, you waive any legal power to forbid
circumvention of technological measures to the extent such
circumvention is effected by exercising rights under this License with
respect to the covered work, and you disclaim any intention to limit
operation or modification of the work as a means of enforcing, against
the work's users, your or third parties' legal rights to forbid
circumvention of technological measures.
#### 4. Conveying Verbatim Copies.
You may convey verbatim copies of the Program's source code as you
receive it, in any medium, provided that you conspicuously and
appropriately publish on each copy an appropriate copyright notice;
keep intact all notices stating that this License and any
non-permissive terms added in accord with section 7 apply to the code;
keep intact all notices of the absence of any warranty; and give all
recipients a copy of this License along with the Program.
You may charge any price or no price for each copy that you convey,
and you may offer support or warranty protection for a fee.
#### 5. Conveying Modified Source Versions.
You may convey a work based on the Program, or the modifications to
produce it from the Program, in the form of source code under the
terms of section 4, provided that you also meet all of these
conditions:
- a) The work must carry prominent notices stating that you modified
it, and giving a relevant date.
- b) The work must carry prominent notices stating that it is
released under this License and any conditions added under
section 7. This requirement modifies the requirement in section 4
to "keep intact all notices".
- c) You must license the entire work, as a whole, under this
License to anyone who comes into possession of a copy. This
License will therefore apply, along with any applicable section 7
additional terms, to the whole of the work, and all its parts,
regardless of how they are packaged. This License gives no
permission to license the work in any other way, but it does not
invalidate such permission if you have separately received it.
- d) If the work has interactive user interfaces, each must display
Appropriate Legal Notices; however, if the Program has interactive
interfaces that do not display Appropriate Legal Notices, your
work need not make them do so.
A compilation of a covered work with other separate and independent
works, which are not by their nature extensions of the covered work,
and which are not combined with it such as to form a larger program,
in or on a volume of a storage or distribution medium, is called an
"aggregate" if the compilation and its resulting copyright are not
used to limit the access or legal rights of the compilation's users
beyond what the individual works permit. Inclusion of a covered work
in an aggregate does not cause this License to apply to the other
parts of the aggregate.
#### 6. Conveying Non-Source Forms.
You may convey a covered work in object code form under the terms of
sections 4 and 5, provided that you also convey the machine-readable
Corresponding Source under the terms of this License, in one of these
ways:
- a) Convey the object code in, or embodied in, a physical product
(including a physical distribution medium), accompanied by the
Corresponding Source fixed on a durable physical medium
customarily used for software interchange.
- b) Convey the object code in, or embodied in, a physical product
(including a physical distribution medium), accompanied by a
written offer, valid for at least three years and valid for as
long as you offer spare parts or customer support for that product
model, to give anyone who possesses the object code either (1) a
copy of the Corresponding Source for all the software in the
product that is covered by this License, on a durable physical
medium customarily used for software interchange, for a price no
more than your reasonable cost of physically performing this
conveying of source, or (2) access to copy the Corresponding
Source from a network server at no charge.
- c) Convey individual copies of the object code with a copy of the
written offer to provide the Corresponding Source. This
alternative is allowed only occasionally and noncommercially, and
only if you received the object code with such an offer, in accord
with subsection 6b.
- d) Convey the object code by offering access from a designated
place (gratis or for a charge), and offer equivalent access to the
Corresponding Source in the same way through the same place at no
further charge. You need not require recipients to copy the
Corresponding Source along with the object code. If the place to
copy the object code is a network server, the Corresponding Source
may be on a different server (operated by you or a third party)
that supports equivalent copying facilities, provided you maintain
clear directions next to the object code saying where to find the
Corresponding Source. Regardless of what server hosts the
Corresponding Source, you remain obligated to ensure that it is
available for as long as needed to satisfy these requirements.
- e) Convey the object code using peer-to-peer transmission,
provided you inform other peers where the object code and
Corresponding Source of the work are being offered to the general
public at no charge under subsection 6d.
A separable portion of the object code, whose source code is excluded
from the Corresponding Source as a System Library, need not be
included in conveying the object code work.
A "User Product" is either (1) a "consumer product", which means any
tangible personal property which is normally used for personal,
family, or household purposes, or (2) anything designed or sold for
incorporation into a dwelling. In determining whether a product is a
consumer product, doubtful cases shall be resolved in favor of
coverage. For a particular product received by a particular user,
"normally used" refers to a typical or common use of that class of
product, regardless of the status of the particular user or of the way
in which the particular user actually uses, or expects or is expected
to use, the product. A product is a consumer product regardless of
whether the product has substantial commercial, industrial or
non-consumer uses, unless such uses represent the only significant
mode of use of the product.
"Installation Information" for a User Product means any methods,
procedures, authorization keys, or other information required to
install and execute modified versions of a covered work in that User
Product from a modified version of its Corresponding Source. The
information must suffice to ensure that the continued functioning of
the modified object code is in no case prevented or interfered with
solely because modification has been made.
If you convey an object code work under this section in, or with, or
specifically for use in, a User Product, and the conveying occurs as
part of a transaction in which the right of possession and use of the
User Product is transferred to the recipient in perpetuity or for a
fixed term (regardless of how the transaction is characterized), the
Corresponding Source conveyed under this section must be accompanied
by the Installation Information. But this requirement does not apply
if neither you nor any third party retains the ability to install
modified object code on the User Product (for example, the work has
been installed in ROM).
The requirement to provide Installation Information does not include a
requirement to continue to provide support service, warranty, or
updates for a work that has been modified or installed by the
recipient, or for the User Product in which it has been modified or
installed. Access to a network may be denied when the modification
itself materially and adversely affects the operation of the network
or violates the rules and protocols for communication across the
network.
Corresponding Source conveyed, and Installation Information provided,
in accord with this section must be in a format that is publicly
documented (and with an implementation available to the public in
source code form), and must require no special password or key for
unpacking, reading or copying.
#### 7. Additional Terms.
"Additional permissions" are terms that supplement the terms of this
License by making exceptions from one or more of its conditions.
Additional permissions that are applicable to the entire Program shall
be treated as though they were included in this License, to the extent
that they are valid under applicable law. If additional permissions
apply only to part of the Program, that part may be used separately
under those permissions, but the entire Program remains governed by
this License without regard to the additional permissions.
When you convey a copy of a covered work, you may at your option
remove any additional permissions from that copy, or from any part of
it. (Additional permissions may be written to require their own
removal in certain cases when you modify the work.) You may place
additional permissions on material, added by you to a covered work,
for which you have or can give appropriate copyright permission.
Notwithstanding any other provision of this License, for material you
add to a covered work, you may (if authorized by the copyright holders
of that material) supplement the terms of this License with terms:
- a) Disclaiming warranty or limiting liability differently from the
terms of sections 15 and 16 of this License; or
- b) Requiring preservation of specified reasonable legal notices or
author attributions in that material or in the Appropriate Legal
Notices displayed by works containing it; or
- c) Prohibiting misrepresentation of the origin of that material,
or requiring that modified versions of such material be marked in
reasonable ways as different from the original version; or
- d) Limiting the use for publicity purposes of names of licensors
or authors of the material; or
- e) Declining to grant rights under trademark law for use of some
trade names, trademarks, or service marks; or
- f) Requiring indemnification of licensors and authors of that
material by anyone who conveys the material (or modified versions
of it) with contractual assumptions of liability to the recipient,
for any liability that these contractual assumptions directly
impose on those licensors and authors.
All other non-permissive additional terms are considered "further
restrictions" within the meaning of section 10. If the Program as you
received it, or any part of it, contains a notice stating that it is
governed by this License along with a term that is a further
restriction, you may remove that term. If a license document contains
a further restriction but permits relicensing or conveying under this
License, you may add to a covered work material governed by the terms
of that license document, provided that the further restriction does
not survive such relicensing or conveying.
If you add terms to a covered work in accord with this section, you
must place, in the relevant source files, a statement of the
additional terms that apply to those files, or a notice indicating
where to find the applicable terms.
Additional terms, permissive or non-permissive, may be stated in the
form of a separately written license, or stated as exceptions; the
above requirements apply either way.
#### 8. Termination.
You may not propagate or modify a covered work except as expressly
provided under this License. Any attempt otherwise to propagate or
modify it is void, and will automatically terminate your rights under
this License (including any patent licenses granted under the third
paragraph of section 11).
However, if you cease all violation of this License, then your license
from a particular copyright holder is reinstated (a) provisionally,
unless and until the copyright holder explicitly and finally
terminates your license, and (b) permanently, if the copyright holder
fails to notify you of the violation by some reasonable means prior to
60 days after the cessation.
Moreover, your license from a particular copyright holder is
reinstated permanently if the copyright holder notifies you of the
violation by some reasonable means, this is the first time you have
received notice of violation of this License (for any work) from that
copyright holder, and you cure the violation prior to 30 days after
your receipt of the notice.
Termination of your rights under this section does not terminate the
licenses of parties who have received copies or rights from you under
this License. If your rights have been terminated and not permanently
reinstated, you do not qualify to receive new licenses for the same
material under section 10.
#### 9. Acceptance Not Required for Having Copies.
You are not required to accept this License in order to receive or run
a copy of the Program. Ancillary propagation of a covered work
occurring solely as a consequence of using peer-to-peer transmission
to receive a copy likewise does not require acceptance. However,
nothing other than this License grants you permission to propagate or
modify any covered work. These actions infringe copyright if you do
not accept this License. Therefore, by modifying or propagating a
covered work, you indicate your acceptance of this License to do so.
#### 10. Automatic Licensing of Downstream Recipients.
Each time you convey a covered work, the recipient automatically
receives a license from the original licensors, to run, modify and
propagate that work, subject to this License. You are not responsible
for enforcing compliance by third parties with this License.
An "entity transaction" is a transaction transferring control of an
organization, or substantially all assets of one, or subdividing an
organization, or merging organizations. If propagation of a covered
work results from an entity transaction, each party to that
transaction who receives a copy of the work also receives whatever
licenses to the work the party's predecessor in interest had or could
give under the previous paragraph, plus a right to possession of the
Corresponding Source of the work from the predecessor in interest, if
the predecessor has it or can get it with reasonable efforts.
You may not impose any further restrictions on the exercise of the
rights granted or affirmed under this License. For example, you may
not impose a license fee, royalty, or other charge for exercise of
rights granted under this License, and you may not initiate litigation
(including a cross-claim or counterclaim in a lawsuit) alleging that
any patent claim is infringed by making, using, selling, offering for
sale, or importing the Program or any portion of it.
#### 11. Patents.
A "contributor" is a copyright holder who authorizes use under this
License of the Program or a work on which the Program is based. The
work thus licensed is called the contributor's "contributor version".
A contributor's "essential patent claims" are all patent claims owned
or controlled by the contributor, whether already acquired or
hereafter acquired, that would be infringed by some manner, permitted
by this License, of making, using, or selling its contributor version,
but do not include claims that would be infringed only as a
consequence of further modification of the contributor version. For
purposes of this definition, "control" includes the right to grant
patent sublicenses in a manner consistent with the requirements of
this License.
Each contributor grants you a non-exclusive, worldwide, royalty-free
patent license under the contributor's essential patent claims, to
make, use, sell, offer for sale, import and otherwise run, modify and
propagate the contents of its contributor version.
In the following three paragraphs, a "patent license" is any express
agreement or commitment, however denominated, not to enforce a patent
(such as an express permission to practice a patent or covenant not to
sue for patent infringement). To "grant" such a patent license to a
party means to make such an agreement or commitment not to enforce a
patent against the party.
If you convey a covered work, knowingly relying on a patent license,
and the Corresponding Source of the work is not available for anyone
to copy, free of charge and under the terms of this License, through a
publicly available network server or other readily accessible means,
then you must either (1) cause the Corresponding Source to be so
available, or (2) arrange to deprive yourself of the benefit of the
patent license for this particular work, or (3) arrange, in a manner
consistent with the requirements of this License, to extend the patent
license to downstream recipients. "Knowingly relying" means you have
actual knowledge that, but for the patent license, your conveying the
covered work in a country, or your recipient's use of the covered work
in a country, would infringe one or more identifiable patents in that
country that you have reason to believe are valid.
If, pursuant to or in connection with a single transaction or
arrangement, you convey, or propagate by procuring conveyance of, a
covered work, and grant a patent license to some of the parties
receiving the covered work authorizing them to use, propagate, modify
or convey a specific copy of the covered work, then the patent license
you grant is automatically extended to all recipients of the covered
work and works based on it.
A patent license is "discriminatory" if it does not include within the
scope of its coverage, prohibits the exercise of, or is conditioned on
the non-exercise of one or more of the rights that are specifically
granted under this License. You may not convey a covered work if you
are a party to an arrangement with a third party that is in the
business of distributing software, under which you make payment to the
third party based on the extent of your activity of conveying the
work, and under which the third party grants, to any of the parties
who would receive the covered work from you, a discriminatory patent
license (a) in connection with copies of the covered work conveyed by
you (or copies made from those copies), or (b) primarily for and in
connection with specific products or compilations that contain the
covered work, unless you entered into that arrangement, or that patent
license was granted, prior to 28 March 2007.
Nothing in this License shall be construed as excluding or limiting
any implied license or other defenses to infringement that may
otherwise be available to you under applicable patent law.
#### 12. No Surrender of Others' Freedom.
If conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License. If you cannot convey a
covered work so as to satisfy simultaneously your obligations under
this License and any other pertinent obligations, then as a
consequence you may not convey it at all. For example, if you agree to
terms that obligate you to collect a royalty for further conveying
from those to whom you convey the Program, the only way you could
satisfy both those terms and this License would be to refrain entirely
from conveying the Program.
#### 13. Use with the GNU Affero General Public License.
Notwithstanding any other provision of this License, you have
permission to link or combine any covered work with a work licensed
under version 3 of the GNU Affero General Public License into a single
combined work, and to convey the resulting work. The terms of this
License will continue to apply to the part which is the covered work,
but the special requirements of the GNU Affero General Public License,
section 13, concerning interaction through a network will apply to the
combination as such.
#### 14. Revised Versions of this License.
The Free Software Foundation may publish revised and/or new versions
of the GNU General Public License from time to time. Such new versions
will be similar in spirit to the present version, but may differ in
detail to address new problems or concerns.
Each version is given a distinguishing version number. If the Program
specifies that a certain numbered version of the GNU General Public
License "or any later version" applies to it, you have the option of
following the terms and conditions either of that numbered version or
of any later version published by the Free Software Foundation. If the
Program does not specify a version number of the GNU General Public
License, you may choose any version ever published by the Free
Software Foundation.
If the Program specifies that a proxy can decide which future versions
of the GNU General Public License can be used, that proxy's public
statement of acceptance of a version permanently authorizes you to
choose that version for the Program.
Later license versions may give you additional or different
permissions. However, no additional obligations are imposed on any
author or copyright holder as a result of your choosing to follow a
later version.
#### 15. Disclaimer of Warranty.
THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT
WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND
PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE
DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR
CORRECTION.
#### 16. Limitation of Liability.
IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR
CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES
ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT
NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR
LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM
TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER
PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
#### 17. Interpretation of Sections 15 and 16.
If the disclaimer of warranty and limitation of liability provided
above cannot be given local legal effect according to their terms,
reviewing courts shall apply local law that most closely approximates
an absolute waiver of all civil liability in connection with the
Program, unless a warranty or assumption of liability accompanies a
copy of the Program in return for a fee.
END OF TERMS AND CONDITIONS
### How to Apply These Terms to Your New Programs
If you develop a new program, and you want it to be of the greatest
possible use to the public, the best way to achieve this is to make it
free software which everyone can redistribute and change under these
terms.
To do so, attach the following notices to the program. It is safest to
attach them to the start of each source file to most effectively state
the exclusion of warranty; and each file should have at least the
"copyright" line and a pointer to where the full notice is found.
<one line to give the program's name and a brief idea of what it does.>
Copyright (C) <year> <name of author>
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <https://www.gnu.org/licenses/>.
Also add information on how to contact you by electronic and paper
mail.
If the program does terminal interaction, make it output a short
notice like this when it starts in an interactive mode:
<program> Copyright (C) <year> <name of author>
This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
This is free software, and you are welcome to redistribute it
under certain conditions; type `show c' for details.
The hypothetical commands \`show w' and \`show c' should show the
appropriate parts of the General Public License. Of course, your
program's commands might be different; for a GUI interface, you would
use an "about box".
You should also get your employer (if you work as a programmer) or
school, if any, to sign a "copyright disclaimer" for the program, if
necessary. For more information on this, and how to apply and follow
the GNU GPL, see <https://www.gnu.org/licenses/>.
The GNU General Public License does not permit incorporating your
program into proprietary programs. If your program is a subroutine
library, you may consider it more useful to permit linking proprietary
applications with the library. If this is what you want to do, use the
GNU Lesser General Public License instead of this License. But first,
please read <https://www.gnu.org/licenses/why-not-lgpl.html>.

8
Doxyfile
View File

@ -51,7 +51,7 @@ PROJECT_BRIEF = "Electromagnetic multiple scattering library and toolki
# and the maximum width should not exceed 200 pixels. Doxygen will copy the logo
# to the output directory.
PROJECT_LOGO = farfield.png
PROJECT_LOGO =
# The OUTPUT_DIRECTORY tag is used to specify the (relative or absolute) path
# into which the generated documentation will be written. If a relative path is
@ -753,7 +753,7 @@ WARN_LOGFILE =
# spaces.
# Note: If this tag is empty the current directory is searched.
INPUT = qpms notes misc finite_systems.md MIRRORS.md CLIUTILS.md README.md README.Triton.md finite_systems.md lattices.md TODO.md
INPUT = qpms notes finite_systems.md README.md README.Triton.md finite_systems.md lattices.md TODO.md
# This tag can be used to specify the character encoding of the source files
# that doxygen parses. Internally doxygen uses the UTF-8 encoding. Doxygen uses
@ -773,7 +773,7 @@ INPUT_ENCODING = UTF-8
# *.md, *.mm, *.dox, *.py, *.f90, *.f, *.for, *.tcl, *.vhd, *.vhdl, *.ucf,
# *.qsf, *.as and *.js.
FILE_PATTERNS =
FILE_PATTERNS =
# The RECURSIVE tag can be used to specify whether or not subdirectories should
# be searched for input files as well.
@ -1462,7 +1462,7 @@ MATHJAX_FORMAT = HTML-CSS
# The default value is: http://cdn.mathjax.org/mathjax/latest.
# This tag requires that the tag USE_MATHJAX is set to YES.
MATHJAX_RELPATH = https://uslugi.necada.org/js/mathjax
MATHJAX_RELPATH = http://cdn.mathjax.org/mathjax/latest
# The MATHJAX_EXTENSIONS tag can be used to specify one or more MathJax
# extension names that should be enabled during MathJax rendering. For example

14
MIRRORS.md
View File

@ -1,14 +0,0 @@
QPMS source code mirrors
========================
QPMS source code is available at several locations; in all of the following,
upstream `master` branch is kept up-to-date. Various development branches
are not necessarily pushed everywhere (and they should be considered
unstable in the sense that rebases and forced pushes are possible).
mirror | note | provider | backend
----------------------------------------------- | ----------------------- | ------------------------------------------------- | ------
<https://repo.or.cz/qpms.git> | primary public upstream | [repo.or.cz](https://repo.or.cz/) | girocco
<https://codeberg.org/QPMS/qpms> | | [Codeberg](https://codeberg.org) | gitea
<https://git.piraattipuolue.fi/QPMS/qpms.git> | | [Pirate Party Finland](https://piraattipuolue.fi) | gitea
<https://version.aalto.fi/gitlab/qpms/qpms.git> | | [Aalto University](https://aalto.fi) | gitlab

127
README.md
View File

@ -1,14 +1,10 @@
[![Build Status](https://drone.perkele.eu/api/badges/QPMS/qpms/status.svg)](https://drone.perkele.eu/QPMS/qpms)
QPMS README
===========
[QPMS][homepage] (standing for QPMS Photonic Multiple Scattering)
is a toolkit for frequency-domain simulations of photonic systems
QPMS is a toolkit for frequency-domain simulations of photonic systems
consisting of compact objects (particles) inside a homogeneous medium. Scattering
properties of the individual particles are described by their T-matrices
(which can be obtained using one of the built-in generators or
e.g. with the `scuff-tmatrix` tool from
(which can be obtained e.g. with the `scuff-tmatrix` tool from
the [SCUFF-EM] suite).
QPMS handles the multiple scattering of electromagnetic radiation between
@ -16,39 +12,26 @@ the particles. The system can consist either of a finite number of particles
or an infinite number of periodically arranged lattices (with finite number
of particles in a single unit cell).
Features
========
Finite systems
--------------
* Computing multipole excitations and fields scattered from nanoparticle
* Computing multipole excitations *and fields (TODO)* scattered from nanoparticle
clusters illuminated by plane, spherical or *cylindrical (TODO)* waves.
* Finding eigenmodes (optical resonances).
* Calculating cross sections.
* Finding eigenmodes.
* *Calculating cross sections (TODO).*
* Reducing numerical complexity of the computations by exploiting
symmetries of the cluster (decomposition to irreducible representations).
Infinite systems (lattices)
---------------------------
* 2D-periodic systems with arbitrary unit cell geometry supported. (TODO 1D and 3D.)
* Computing multipole excitations and fields scattered from nanoparticle
* 2D-periodic systems supported. (TODO 1D and 3D.)
* *Calculation of transmission and reflection properties (TODO).*
* Finding eigenmodes and calculating dispersion relations.
* Calculation of the scattered fields.
* *Calculation of total transmission and reflection properties (TODO).*
* *Reducing numerical complexity of the computations by exploiting
symmetries of the lattice (decomposition to irreducible representations) (in development).*
Getting the code
================
The codebase is available at the main upstream public repository
<https://repo.or.cz/qpms.git> or any of the [maintained mirrors][MIRRORS].
Just clone the repository with `git` and proceed to the installation instructions
below.
* *Calculation of far-field radiation patterns of an excited array (TODO).*
* Reducing numerical complexity of the computations by exploiting
symmetries of the lattice (decomposition to irreducible representations).
Installation
@ -64,16 +47,7 @@ you can [get the source and compile it yourself][GSL].
You also need a fresh enough version of [cmake][].
QPMS uses a C version of the Amos library for calculating Bessel function
from a submodule. Before proceeding with running `cmake`, the submodules
need to be downloaded first (in the QPMS source root directory):
```{.sh}
git submodule init
git submodule update
```
After GSL is installed and submodules updated, you can install qpms to your local python library using
After GSL is installed, you can install qpms to your local python library using
```{.sh}
cmake -DCMAKE_INSTALL_PREFIX=${YOUR_PREFIX} .
@ -92,21 +66,13 @@ Special care might need to be taken when installing QPMS in cluster environments
Specific installation instructions for Aalto University's Triton cluster
can be found in a [separate document][TRITON-README].
Instructions for installation on Android-based devices are
in [another document][INSTALL-ANDROID].
Documentation
=============
[QPMS documentation][homepage] is a work in progress. Most of the newer code
is documented using [doxygen][] comments. Documentation generated for the
upstream version is hosted on the QPMS homepage <https://qpms.necada.org>.
To build the documentation yourself,
just run
Documentation of QPMS is a work in progress. Most of the newer code
is documented using [doxygen][] comments. To build the documentation, just run
`doxygen`
in the QPMS source root directory; the documentation will then be found in
in the root directory; the documentation will then be found in
`docs/html/index.html`.
Of course, the prerequisite of this is having doxygen installed.
@ -118,77 +84,14 @@ under root.
Tutorials
---------
* [Infinite system (lattice) tutorial][tutorial-infinite]
* [Finite system tutorial][tutorial-finite]
See also the examples directory in the source repository.
Command line utilities
----------------------
* [Overview of the Python command line utilities][cliutils]
Acknowledgments
================
This software has been developed in the [Quantum Dynamics research group][QD],
Aalto University, Finland. If you use the code in your work, please cite
**M. Nečada and P. Törmä, Multiple-scattering T-matrix simulations for nanophotonics: symmetries and periodic lattices, [arXiv: 2006.12968][lepaper] (2020)**
in your publications, presentations, and similar.
Please also have a look at other publications by the group
(google scholar Päivi Törmä), they may be useful for your work as well.
Bug reports
===========
If you believe that some parts of QPMS behave incorrectly, please mail
a bug report to [marek@necada.org][authormail]. To ensure that your message is not
considered spam, please start the subject line with `QPMS`.
If you were able to fix a bug yourself, please include the patch as well,
see below.
Contributions
=============
Contributions to QPMS are welcome, be it bug fixes, improvements to the
documentation, code quality, or new features.
You can send patches prepared using the
[`git format-patch`](https://git-scm.com/docs/git-format-patch) tool
to [marek@necada.org][authormail].
If you plan to contribute with major changes to the codebase, it is
recommended to discuss that first (see the contact information below).
Contact & discussion
====================
You can contact the main author e.g. via [e-mail][authormail]
or [Telegram](https://t.me/necadam).
You are also warmly welcome to the [QPMS user chat][telegramchat]
in Telegram!
[homepage]: https://qpms.necada.org
[SCUFF-EM]: https://homerreid.github.io/scuff-em-documentation/
[OpenBLAS]: https://www.openblas.net/
[GSL]: https://www.gnu.org/software/gsl/
[cmake]: https://cmake.org
[TRITON-README]: README.Triton.md
[INSTALL-ANDROID]: notes/INSTALL_ANDROID.md
[tutorial-finite]: finite_systems.md
[tutorial-infinite]: lattices.md
[doxygen]: http://doxygen.nl/
[QD]: https://www.aalto.fi/en/department-of-applied-physics/quantum-dynamics-qd
[lepaper]: https://arxiv.org/abs/2006.12968
[telegramchat]: https://t.me/QPMScattering
[authormail]: mailto:marek@necada.org
[cliutils]: CLIUTILS.md
[MIRRORS]: MIRRORS.md

29
TODO.md
View File

@ -1,12 +1,11 @@
TODO list before 1.0 release
============================
TODO list before public release
===============================
- Tests!
- Docs!
- Cross section calculations. (Done in some Python scripts.)
- Field calculations. (Partly done, needs more testing.)
* Also test periodic vs. nonperiodic consistence (big finite lattice + absorbing medium vs. infinite lattice + absorbing medium).
- Complex frequencies, n's, k's. (Mostly done.)
- Cross section calculations.
- Field calculations.
- Complex frequencies, n's, k's.
- Transforming point (meta)generators.
- Check whether moble's quaternions and my
quaternions give the same results in tmatrices.py
@ -25,12 +24,11 @@ TODO list before 1.0 release
* As a description of a T-matrix / particle metadata.
- Nice CLI for all general enough utilities.
- Remove legacy code.
- Split `qpms_c.pyx`.
- Split qpms_c.pyx.
- Reduce compiler warnings.
- Serialisation (saving, loading) of `ScatteringSystem` and other structures.
- Python exceptions instead of hard crashes in the C library where possible.
- Scatsystem init sometimes fail due to rounding errors and hardcoded absolute tolerance
in the `qpms_tmatrix_isclose()` call.
in the qpms_tmatrix_isclose() call.
- Prefix all identifiers. Maybe think about a different prefix than qpms?
- Consistent indentation and style overall.
- Rewrite the parallelized translation matrix, mode problem matrix generators
@ -41,16 +39,3 @@ Nice but less important features
- Static, thread-safe caches of constant coefficients + API without the current "calculators".
Optimisations
-------------
- Leaving out the irrelevant elements if a "rectangular" block of the translations matrix is needed.
- Ewald sums with "non-parallel" shifts (are about 20 times slower than the purely parallel ones).
- Reusing intermediate results (profiling needed)
* Bessel, Legendre functions (see also branch `finite_lattice_speedup`)
* Lattice points (sorting and scaling)
* Γ/Δ functions (for periodic lattices)
- More parallelisation.
- Possibly pre-calculation of the (precise) coefficients in Bessel and Legendre functions (using gmp)
- Asymptotic approximations of the Bessel functions for far fields.

18
amos/CMakeLists.txt
View File

@ -1,18 +0,0 @@
enable_language (Fortran)
include(FortranCInterface)
FortranCInterface_HEADER(amos_mangling.h
MACRO_NAMESPACE "AMOS_"
SYMBOL_NAMESPACE "amos_"
SYMBOLS zbesj zbesy zbesh zbesi zbesk zsqrt
)
add_library(amos
dgamln.f zabs.f zasyi.f zbinu.f zdiv.f zmlri.f zshch.f zunhj.f zunk1.f
d1mach.f zacai.f zbesh.f zbknu.f zexp.f zmlt.f zsqrt.f zunik.f zunk2.f
i1mach.f zacon.f zbesj.f zbuni.f zkscl.f zrati.f zs1s2.f zuni1.f zuoik.f
xerror.f zairy.f zbesy.f zbunk.f zlog.f zseri.f zuchk.f zuni2.f zwrsk.f
)
target_include_directories (amos PUBLIC ${CMAKE_CURRENT_SOURCE_DIR})

31
amos/README.md
View File

@ -1,31 +0,0 @@
# AMOS
A Portable Package for Bessel Functions of a Complex Argument
and Nonnegative Order
This algorithm is a package of subroutines for computing Bessel
functions and Airy functions. The routines are updated
versions of those routines found in TOMS algorithm 644.
## Disclaimer
```
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* ISSUED BY SANDIA LABORATORIES,
* A PRIME CONTRACTOR TO THE
* UNITED STATES DEPARTMENT OF ENERGY
* * * * * * * * * * * * * * NOTICE * * * * * * * * * * * * * * *
* THIS REPORT WAS PREPARED AS AN ACCOUNT OF WORK SPONSORED BY THE
* UNITED STATES GOVERNMENT. NEITHER THE UNITED STATES NOR THE
* UNITED STATES DEPARTMENT OF ENERGY, NOR ANY OF THEIR
* EMPLOYEES, NOR ANY OF THEIR CONTRACTORS, SUBCONTRACTORS, OR THEIR
* EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR ASSUMES ANY
* LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, COMPLETENESS
* OR USEFULNESS OF ANY INFORMATION, APPARATUS, PRODUCT OR PROCESS
* DISCLOSED, OR REPRESENTS THAT ITS USE WOULD NOT INFRINGE
* PRIVATELY OWNED RIGHTS.
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* THIS CODE HAS BEEN APPROVED FOR UNLIMITED RELEASE.
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
```

42
amos/amos.h
View File

@ -1,42 +0,0 @@
#ifndef AMOS_H
#define AMOS_H
#include "amos_mangling.h"
#define INTEGER_t int
#define DOUBLE_PRECISION_t double
void amos_zbesj(const DOUBLE_PRECISION_t *zr,
const DOUBLE_PRECISION_t *zi,
const DOUBLE_PRECISION_t *fnu,
const INTEGER_t *kode,
const INTEGER_t *n,
DOUBLE_PRECISION_t *cyr,
DOUBLE_PRECISION_t *cyi,
INTEGER_t *nz,
INTEGER_t *ierr);
void amos_zbesy(const DOUBLE_PRECISION_t *zr,
const DOUBLE_PRECISION_t *zi,
const DOUBLE_PRECISION_t *fnu,
const INTEGER_t *kode,
const INTEGER_t *n,
DOUBLE_PRECISION_t *cyr,
DOUBLE_PRECISION_t *cyi,
INTEGER_t *nz,
DOUBLE_PRECISION_t *cwrkr,
DOUBLE_PRECISION_t *cwrki,
INTEGER_t *ierr);
void amos_zbesh(const DOUBLE_PRECISION_t *zr,
const DOUBLE_PRECISION_t *zi,
const DOUBLE_PRECISION_t *fnu,
const INTEGER_t *kode,
const INTEGER_t *m,
const INTEGER_t *n,
DOUBLE_PRECISION_t *cyr,
DOUBLE_PRECISION_t *cyi,
INTEGER_t *nz,
INTEGER_t *ierr);
#endif

30
amos/camos.h
View File

@ -1,30 +0,0 @@
#ifndef CAMOS_H_
#define CAMOS_H_
#include "amos.h"
// TODO what about all the INTEGER_t and DOUBLE_PRECISION_t?
static inline int camos_zbesh(double zr, double zi, double fnu, int kode, int m,
int n, double *cyr, double *cyi, int *nz) {
int ierr;
amos_zbesh(&zr, &zi, &fnu, &kode, &m, &n, cyr, cyi, nz, &ierr);
return ierr;
}
static inline int camos_zbesj(double zr, double zi, double fnu, int kode, int n, double *cyr,
double *cyi, int *nz) {
int ierr;
double cwrkr[n], cwrki[n];
amos_zbesj(&zr, &zi, &fnu, &kode, &n, cyr, cyi, nz, &ierr);
return ierr;
}
static inline int camos_zbesy(double zr, double zi, double fnu, int kode, int n, double *cyr,
double *cyi, int *nz, double *cwrkr, double *cwrki) {
int ierr;
amos_zbesy(&zr, &zi, &fnu, &kode, &n, cyr, cyi, nz, cwrkr, cwrki, &ierr);
return ierr;
}
#endif // CAMOS_H_

209
amos/d1mach.f
View File

@ -1,209 +0,0 @@
DOUBLE PRECISION FUNCTION D1MACH(I)
INTEGER I
C
C DOUBLE-PRECISION MACHINE CONSTANTS
C D1MACH( 1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE.
C D1MACH( 2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE.
C D1MACH( 3) = B**(-T), THE SMALLEST RELATIVE SPACING.
C D1MACH( 4) = B**(1-T), THE LARGEST RELATIVE SPACING.
C D1MACH( 5) = LOG10(B)
C
INTEGER SMALL(2)
INTEGER LARGE(2)
INTEGER RIGHT(2)
INTEGER DIVER(2)
INTEGER LOG10(2)
INTEGER SC, CRAY1(38), J
COMMON /D9MACH/ CRAY1
SAVE SMALL, LARGE, RIGHT, DIVER, LOG10, SC
DOUBLE PRECISION DMACH(5)
EQUIVALENCE (DMACH(1),SMALL(1))
EQUIVALENCE (DMACH(2),LARGE(1))
EQUIVALENCE (DMACH(3),RIGHT(1))
EQUIVALENCE (DMACH(4),DIVER(1))
EQUIVALENCE (DMACH(5),LOG10(1))
C THIS VERSION ADAPTS AUTOMATICALLY TO MOST CURRENT MACHINES.
C R1MACH CAN HANDLE AUTO-DOUBLE COMPILING, BUT THIS VERSION OF
C D1MACH DOES NOT, BECAUSE WE DO NOT HAVE QUAD CONSTANTS FOR
C MANY MACHINES YET.
C TO COMPILE ON OLDER MACHINES, ADD A C IN COLUMN 1
C ON THE NEXT LINE
DATA SC/0/
C AND REMOVE THE C FROM COLUMN 1 IN ONE OF THE SECTIONS BELOW.
C CONSTANTS FOR EVEN OLDER MACHINES CAN BE OBTAINED BY
C mail netlib@research.bell-labs.com
C send old1mach from blas
C PLEASE SEND CORRECTIONS TO dmg OR ehg@bell-labs.com.
C
C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES.
C DATA SMALL(1),SMALL(2) / O402400000000, O000000000000 /
C DATA LARGE(1),LARGE(2) / O376777777777, O777777777777 /
C DATA RIGHT(1),RIGHT(2) / O604400000000, O000000000000 /
C DATA DIVER(1),DIVER(2) / O606400000000, O000000000000 /
C DATA LOG10(1),LOG10(2) / O776464202324, O117571775714 /, SC/987/
C
C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING
C 32-BIT INTEGERS.
C DATA SMALL(1),SMALL(2) / 8388608, 0 /
C DATA LARGE(1),LARGE(2) / 2147483647, -1 /
C DATA RIGHT(1),RIGHT(2) / 612368384, 0 /
C DATA DIVER(1),DIVER(2) / 620756992, 0 /
C DATA LOG10(1),LOG10(2) / 1067065498, -2063872008 /, SC/987/
C
C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
C DATA SMALL(1),SMALL(2) / O000040000000, O000000000000 /
C DATA LARGE(1),LARGE(2) / O377777777777, O777777777777 /
C DATA RIGHT(1),RIGHT(2) / O170540000000, O000000000000 /
C DATA DIVER(1),DIVER(2) / O170640000000, O000000000000 /
C DATA LOG10(1),LOG10(2) / O177746420232, O411757177572 /, SC/987/
C
C ON FIRST CALL, IF NO DATA UNCOMMENTED, TEST MACHINE TYPES.
IF (SC .NE. 987) THEN
DMACH(1) = 1.D13
IF ( SMALL(1) .EQ. 1117925532
* .AND. SMALL(2) .EQ. -448790528) THEN
* *** IEEE BIG ENDIAN ***
SMALL(1) = 1048576
SMALL(2) = 0
LARGE(1) = 2146435071
LARGE(2) = -1
RIGHT(1) = 1017118720
RIGHT(2) = 0
DIVER(1) = 1018167296
DIVER(2) = 0
LOG10(1) = 1070810131
LOG10(2) = 1352628735
ELSE IF ( SMALL(2) .EQ. 1117925532
* .AND. SMALL(1) .EQ. -448790528) THEN
* *** IEEE LITTLE ENDIAN ***
SMALL(2) = 1048576
SMALL(1) = 0
LARGE(2) = 2146435071
LARGE(1) = -1
RIGHT(2) = 1017118720
RIGHT(1) = 0
DIVER(2) = 1018167296
DIVER(1) = 0
LOG10(2) = 1070810131
LOG10(1) = 1352628735
ELSE IF ( SMALL(1) .EQ. -2065213935
* .AND. SMALL(2) .EQ. 10752) THEN
* *** VAX WITH D_FLOATING ***
SMALL(1) = 128
SMALL(2) = 0
LARGE(1) = -32769
LARGE(2) = -1
RIGHT(1) = 9344
RIGHT(2) = 0
DIVER(1) = 9472
DIVER(2) = 0
LOG10(1) = 546979738
LOG10(2) = -805796613
ELSE IF ( SMALL(1) .EQ. 1267827943
* .AND. SMALL(2) .EQ. 704643072) THEN
* *** IBM MAINFRAME ***
SMALL(1) = 1048576
SMALL(2) = 0
LARGE(1) = 2147483647
LARGE(2) = -1
RIGHT(1) = 856686592
RIGHT(2) = 0
DIVER(1) = 873463808
DIVER(2) = 0
LOG10(1) = 1091781651
LOG10(2) = 1352628735
ELSE IF ( SMALL(1) .EQ. 1120022684
* .AND. SMALL(2) .EQ. -448790528) THEN
* *** CONVEX C-1 ***
SMALL(1) = 1048576
SMALL(2) = 0
LARGE(1) = 2147483647
LARGE(2) = -1
RIGHT(1) = 1019215872
RIGHT(2) = 0
DIVER(1) = 1020264448
DIVER(2) = 0
LOG10(1) = 1072907283
LOG10(2) = 1352628735
ELSE IF ( SMALL(1) .EQ. 815547074
* .AND. SMALL(2) .EQ. 58688) THEN
* *** VAX G-FLOATING ***
SMALL(1) = 16
SMALL(2) = 0
LARGE(1) = -32769
LARGE(2) = -1
RIGHT(1) = 15552
RIGHT(2) = 0
DIVER(1) = 15568
DIVER(2) = 0
LOG10(1) = 1142112243
LOG10(2) = 2046775455
ELSE
DMACH(2) = 1.D27 + 1
DMACH(3) = 1.D27
LARGE(2) = LARGE(2) - RIGHT(2)
IF (LARGE(2) .EQ. 64 .AND. SMALL(2) .EQ. 0) THEN
CRAY1(1) = 67291416
DO 10 J = 1, 20
CRAY1(J+1) = CRAY1(J) + CRAY1(J)
10 CONTINUE
CRAY1(22) = CRAY1(21) + 321322
DO 20 J = 22, 37
CRAY1(J+1) = CRAY1(J) + CRAY1(J)
20 CONTINUE
IF (CRAY1(38) .EQ. SMALL(1)) THEN
* *** CRAY ***
CALL I1MCRY(SMALL(1), J, 8285, 8388608, 0)
SMALL(2) = 0
CALL I1MCRY(LARGE(1), J, 24574, 16777215, 16777215)
CALL I1MCRY(LARGE(2), J, 0, 16777215, 16777214)
CALL I1MCRY(RIGHT(1), J, 16291, 8388608, 0)
RIGHT(2) = 0
CALL I1MCRY(DIVER(1), J, 16292, 8388608, 0)
DIVER(2) = 0
CALL I1MCRY(LOG10(1), J, 16383, 10100890, 8715215)
CALL I1MCRY(LOG10(2), J, 0, 16226447, 9001388)
ELSE
WRITE(*,9000)
STOP 779
END IF
ELSE
WRITE(*,9000)
STOP 779
END IF
END IF
SC = 987
END IF
* SANITY CHECK
IF (DMACH(4) .GE. 1.0D0) STOP 778
IF (I .LT. 1 .OR. I .GT. 5) THEN
WRITE(*,*) 'D1MACH(I): I =',I,' is out of bounds.'
STOP
END IF
D1MACH = DMACH(I)
RETURN
9000 FORMAT(/' Adjust D1MACH by uncommenting data statements'/
*' appropriate for your machine.')
* /* Standard C source for D1MACH -- remove the * in column 1 */
*#include <stdio.h>
*#include <float.h>
*#include <math.h>
*double d1mach_(long *i)
*{
* switch(*i){
* case 1: return DBL_MIN;
* case 2: return DBL_MAX;
* case 3: return DBL_EPSILON/FLT_RADIX;
* case 4: return DBL_EPSILON;
* case 5: return log10(FLT_RADIX);
* }
* fprintf(stderr, "invalid argument: d1mach(%ld)\n", *i);
* exit(1); return 0; /* some compilers demand return values */
*}
END
SUBROUTINE I1MCRY(A, A1, B, C, D)
**** SPECIAL COMPUTATION FOR OLD CRAY MACHINES ****
INTEGER A, A1, B, C, D
A1 = 16777216*B + C
A = 16777216*A1 + D
END

189
amos/dgamln.f
View File

@ -1,189 +0,0 @@
DOUBLE PRECISION FUNCTION DGAMLN(Z,IERR)
C***BEGIN PROLOGUE DGAMLN
C***DATE WRITTEN 830501 (YYMMDD)
C***REVISION DATE 830501 (YYMMDD)
C***CATEGORY NO. B5F
C***KEYWORDS GAMMA FUNCTION,LOGARITHM OF GAMMA FUNCTION
C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
C***PURPOSE TO COMPUTE THE LOGARITHM OF THE GAMMA FUNCTION
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 COMPUTIMG ZMIN FROM THE NUMBER OF BASE
C 10 DIGITS IN A WORD, RLN=AMAX1(-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 I1MACH,D1MACH
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 = INT(SNGL(Z))
FZ = Z - FLOAT(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 = DMAX1(WDTOL,0.5D-18)
I1M = I1MACH(14)
RLN = D1MACH(5)*FLOAT(I1M)
FLN = DMIN1(RLN,20.0D0)
FLN = DMAX1(FLN,3.0D0)
FLN = FLN - 3.0D0
ZM = 1.8000D0 + 0.3875D0*FLN
MZ = INT(SNGL(ZM)) + 1
ZMIN = FLOAT(MZ)
ZDMY = Z
ZINC = 0.0D0
IF (Z.GE.ZMIN) GO TO 20
ZINC = ZMIN - FLOAT(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 (DABS(TRM).LT.TST) GO TO 40
S = S + TRM
30 CONTINUE
40 CONTINUE
IF (ZINC.NE.0.0D0) GO TO 50
TLG = DLOG(Z)
DGAMLN = Z*(TLG-1.0D0) + 0.5D0*(CON-TLG) + S
RETURN
50 CONTINUE
ZP = 1.0D0
NZ = INT(SNGL(ZINC))
DO 60 I=1,NZ
ZP = ZP*(Z+FLOAT(I-1))
60 CONTINUE
TLG = DLOG(ZDMY)
DGAMLN = ZDMY*(TLG-1.0D0) - DLOG(ZP) + 0.5D0*(CON-TLG) + S
RETURN
C
C
70 CONTINUE
IERR=1
RETURN
END

291
amos/i1mach.f
View File

@ -1,291 +0,0 @@
INTEGER FUNCTION I1MACH(I)
INTEGER I
C
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 I1MACH( 5) = THE NUMBER OF BITS PER INTEGER STORAGE UNIT.
C I1MACH( 6) = THE NUMBER OF CHARACTERS PER CHARACTER STORAGE UNIT.
C INTEGERS HAVE FORM SIGN ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) )
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 FLOATS HAVE FORM SIGN (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
C WHERE EMIN .LE. E .LE. EMAX.
C I1MACH(10) = B, THE BASE.
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 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
INTEGER IMACH(16), OUTPUT, SC, SMALL(2)
SAVE IMACH, SC
REAL RMACH
EQUIVALENCE (IMACH(4),OUTPUT), (RMACH,SMALL(1))
INTEGER I3, J, K, T3E(3)
DATA T3E(1) / 9777664 /
DATA T3E(2) / 5323660 /
DATA T3E(3) / 46980 /
C THIS VERSION ADAPTS AUTOMATICALLY TO MOST CURRENT MACHINES,
C INCLUDING AUTO-DOUBLE COMPILERS.
C TO COMPILE ON OLDER MACHINES, ADD A C IN COLUMN 1
C ON THE NEXT LINE
DATA SC/0/
C AND REMOVE THE C FROM COLUMN 1 IN ONE OF THE SECTIONS BELOW.
C CONSTANTS FOR EVEN OLDER MACHINES CAN BE OBTAINED BY
C mail netlib@research.bell-labs.com
C send old1mach from blas
C PLEASE SEND CORRECTIONS TO dmg OR ehg@bell-labs.com.
C
C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES.
C
C DATA IMACH( 1) / 5 /
C DATA IMACH( 2) / 6 /
C DATA IMACH( 3) / 43 /
C DATA IMACH( 4) / 6 /
C DATA IMACH( 5) / 36 /
C DATA IMACH( 6) / 4 /
C DATA IMACH( 7) / 2 /
C DATA IMACH( 8) / 35 /
C DATA IMACH( 9) / O377777777777 /
C DATA IMACH(10) / 2 /
C DATA IMACH(11) / 27 /
C DATA IMACH(12) / -127 /
C DATA IMACH(13) / 127 /
C DATA IMACH(14) / 63 /
C DATA IMACH(15) / -127 /
C DATA IMACH(16) / 127 /, SC/987/
C
C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING
C 32-BIT INTEGER ARITHMETIC.
C
C DATA IMACH( 1) / 5 /
C DATA IMACH( 2) / 6 /
C DATA IMACH( 3) / 7 /
C DATA IMACH( 4) / 6 /
C DATA IMACH( 5) / 32 /
C DATA IMACH( 6) / 4 /
C DATA IMACH( 7) / 2 /
C DATA IMACH( 8) / 31 /
C DATA IMACH( 9) / 2147483647 /
C DATA IMACH(10) / 2 /
C DATA IMACH(11) / 24 /
C DATA IMACH(12) / -127 /
C DATA IMACH(13) / 127 /
C DATA IMACH(14) / 56 /
C DATA IMACH(15) / -127 /
C DATA IMACH(16) / 127 /, SC/987/
C
C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
C
C NOTE THAT THE PUNCH UNIT, I1MACH(3), HAS BEEN SET TO 7
C WHICH IS APPROPRIATE FOR THE UNIVAC-FOR SYSTEM.
C IF YOU HAVE THE UNIVAC-FTN SYSTEM, SET IT TO 1.
C
C DATA IMACH( 1) / 5 /
C DATA IMACH( 2) / 6 /
C DATA IMACH( 3) / 7 /
C DATA IMACH( 4) / 6 /
C DATA IMACH( 5) / 36 /
C DATA IMACH( 6) / 6 /
C DATA IMACH( 7) / 2 /
C DATA IMACH( 8) / 35 /
C DATA IMACH( 9) / O377777777777 /
C DATA IMACH(10) / 2 /
C DATA IMACH(11) / 27 /
C DATA IMACH(12) / -128 /
C DATA IMACH(13) / 127 /
C DATA IMACH(14) / 60 /
C DATA IMACH(15) /-1024 /
C DATA IMACH(16) / 1023 /, SC/987/
C
IF (SC .NE. 987) THEN
* *** CHECK FOR AUTODOUBLE ***
SMALL(2) = 0
RMACH = 1E13
IF (SMALL(2) .NE. 0) THEN
* *** AUTODOUBLED ***
IF ( (SMALL(1) .EQ. 1117925532
* .AND. SMALL(2) .EQ. -448790528)
* .OR. (SMALL(2) .EQ. 1117925532
* .AND. SMALL(1) .EQ. -448790528)) THEN
* *** IEEE ***
IMACH(10) = 2
IMACH(14) = 53
IMACH(15) = -1021
IMACH(16) = 1024
ELSE IF ( SMALL(1) .EQ. -2065213935
* .AND. SMALL(2) .EQ. 10752) THEN
* *** VAX WITH D_FLOATING ***
IMACH(10) = 2
IMACH(14) = 56
IMACH(15) = -127
IMACH(16) = 127
ELSE IF ( SMALL(1) .EQ. 1267827943
* .AND. SMALL(2) .EQ. 704643072) THEN
* *** IBM MAINFRAME ***
IMACH(10) = 16
IMACH(14) = 14
IMACH(15) = -64
IMACH(16) = 63
ELSE
WRITE(*,9010)
STOP 777
END IF
IMACH(11) = IMACH(14)
IMACH(12) = IMACH(15)
IMACH(13) = IMACH(16)
ELSE
RMACH = 1234567.
IF (SMALL(1) .EQ. 1234613304) THEN
* *** IEEE ***
IMACH(10) = 2
IMACH(11) = 24
IMACH(12) = -125
IMACH(13) = 128
IMACH(14) = 53
IMACH(15) = -1021
IMACH(16) = 1024
SC = 987
ELSE IF (SMALL(1) .EQ. -1271379306) THEN
* *** VAX ***
IMACH(10) = 2
IMACH(11) = 24
IMACH(12) = -127
IMACH(13) = 127
IMACH(14) = 56
IMACH(15) = -127
IMACH(16) = 127
SC = 987
ELSE IF (SMALL(1) .EQ. 1175639687) THEN
* *** IBM MAINFRAME ***
IMACH(10) = 16
IMACH(11) = 6
IMACH(12) = -64
IMACH(13) = 63
IMACH(14) = 14
IMACH(15) = -64
IMACH(16) = 63
SC = 987
ELSE IF (SMALL(1) .EQ. 1251390520) THEN
* *** CONVEX C-1 ***
IMACH(10) = 2
IMACH(11) = 24
IMACH(12) = -128
IMACH(13) = 127
IMACH(14) = 53
IMACH(15) = -1024
IMACH(16) = 1023
ELSE
DO 10 I3 = 1, 3
J = SMALL(1) / 10000000
K = SMALL(1) - 10000000*J
IF (K .NE. T3E(I3)) GO TO 20
SMALL(1) = J
10 CONTINUE
* *** CRAY T3E ***
IMACH( 1) = 5
IMACH( 2) = 6
IMACH( 3) = 0
IMACH( 4) = 0
IMACH( 5) = 64
IMACH( 6) = 8
IMACH( 7) = 2
IMACH( 8) = 63
CALL I1MCR1(IMACH(9), K, 32767, 16777215, 16777215)
IMACH(10) = 2
IMACH(11) = 53
IMACH(12) = -1021
IMACH(13) = 1024
IMACH(14) = 53
IMACH(15) = -1021
IMACH(16) = 1024
GO TO 35
20 CALL I1MCR1(J, K, 16405, 9876536, 0)
IF (SMALL(1) .NE. J) THEN
WRITE(*,9020)
STOP 777
END IF
* *** CRAY 1, XMP, 2, AND 3 ***
IMACH(1) = 5
IMACH(2) = 6
IMACH(3) = 102
IMACH(4) = 6
IMACH(5) = 46
IMACH(6) = 8
IMACH(7) = 2
IMACH(8) = 45
CALL I1MCR1(IMACH(9), K, 0, 4194303, 16777215)
IMACH(10) = 2
IMACH(11) = 47
IMACH(12) = -8188
IMACH(13) = 8189
IMACH(14) = 94
IMACH(15) = -8141
IMACH(16) = 8189
GO TO 35
END IF
END IF
IMACH( 1) = 5
IMACH( 2) = 6
IMACH( 3) = 7
IMACH( 4) = 6
IMACH( 5) = 32
IMACH( 6) = 4
IMACH( 7) = 2
IMACH( 8) = 31
IMACH( 9) = 2147483647
35 SC = 987
END IF
9010 FORMAT(/' Adjust autodoubled I1MACH by uncommenting data'/
* ' statements appropriate for your machine and setting'/
* ' IMACH(I) = IMACH(I+3) for I = 11, 12, and 13.')
9020 FORMAT(/' Adjust I1MACH by uncommenting data statements'/
* ' appropriate for your machine.')
IF (I .LT. 1 .OR. I .GT. 16) GO TO 40
I1MACH = IMACH(I)
RETURN
40 WRITE(*,*) 'I1MACH(I): I =',I,' is out of bounds.'
STOP
* /* C source for I1MACH -- remove the * in column 1 */
* /* Note that some values may need changing. */
*#include <stdio.h>
*#include <float.h>
*#include <limits.h>
*#include <math.h>
*
*long i1mach_(long *i)
*{
* switch(*i){
* case 1: return 5; /* standard input */
* case 2: return 6; /* standard output */
* case 3: return 7; /* standard punch */
* case 4: return 0; /* standard error */
* case 5: return 32; /* bits per integer */
* case 6: return sizeof(int);
* case 7: return 2; /* base for integers */
* case 8: return 31; /* digits of integer base */
* case 9: return LONG_MAX;
* case 10: return FLT_RADIX;
* case 11: return FLT_MANT_DIG;
* case 12: return FLT_MIN_EXP;
* case 13: return FLT_MAX_EXP;
* case 14: return DBL_MANT_DIG;
* case 15: return DBL_MIN_EXP;
* case 16: return DBL_MAX_EXP;
* }
* fprintf(stderr, "invalid argument: i1mach(%ld)\n", *i);
* exit(1);return 0; /* some compilers demand return values */
*}
END
SUBROUTINE I1MCR1(A, A1, B, C, D)
**** SPECIAL COMPUTATION FOR OLD CRAY MACHINES ****
INTEGER A, A1, B, C, D
A1 = 16777216*B + C
A = 16777216*A1 + D
END

22
amos/xerror.f
View File

@ -1,22 +0,0 @@
SUBROUTINE XERROR(MESS,NMESS,L1,L2)
C
C THIS IS A DUMMY XERROR ROUTINE TO PRINT ERROR MESSAGES WITH NMESS
C CHARACTERS. L1 AND L2 ARE DUMMY PARAMETERS TO MAKE THIS CALL
C COMPATIBLE WITH THE SLATEC XERROR ROUTINE. THIS IS A FORTRAN 77
C ROUTINE.
C
CHARACTER*(*) MESS
NN=NMESS/70
NR=NMESS-70*NN
IF(NR.NE.0) NN=NN+1
K=1
PRINT 900
900 FORMAT(/)
DO 10 I=1,NN
KMIN=MIN0(K+69,NMESS)
PRINT *, MESS(K:KMIN)
K=K+70
10 CONTINUE
PRINT 900
RETURN
END

29
amos/zabs.f
View File

@ -1,29 +0,0 @@
DOUBLE PRECISION FUNCTION AZABS(ZR, ZI)
C***BEGIN PROLOGUE AZABS
C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY
C
C AZABS COMPUTES THE ABSOLUTE VALUE OR MAGNITUDE OF A DOUBLE
C PRECISION COMPLEX VARIABLE CMPLX(ZR,ZI)
C
C***ROUTINES CALLED (NONE)
C***END PROLOGUE AZABS
DOUBLE PRECISION ZR, ZI, U, V, Q, S
U = DABS(ZR)
V = DABS(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
AZABS = V*DSQRT(1.D+0+Q*Q)
RETURN
10 Q = V/U
AZABS = U*DSQRT(1.D+0+Q*Q)
RETURN
20 AZABS = 0.0D+0
RETURN
END

99
amos/zacai.f
View File

@ -1,99 +0,0 @@
SUBROUTINE ZACAI(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, RL, TOL,
* ELIM, ALIM)
C***BEGIN PROLOGUE ZACAI
C***REFER TO ZAIRY
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***ROUTINES CALLED ZASYI,ZBKNU,ZMLRI,ZSERI,ZS1S2,D1MACH,AZABS
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, AZABS
INTEGER INU, IUF, KODE, MR, N, NN, NW, NZ
DIMENSION YR(N), YI(N), CYR(2), CYI(2)
DATA PI / 3.14159265358979324D0 /
NZ = 0
ZNR = -ZR
ZNI = -ZI
AZ = AZABS(ZR,ZI)
NN = N
DFNU = FNU + DBLE(FLOAT(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 = DBLE(FLOAT(MR))
SGN = -DSIGN(PI,FMR)
CSGNR = 0.0D0
CSGNI = SGN
IF (KODE.EQ.1) GO TO 50
YY = -ZNI
CSGNR = -CSGNI*DSIN(YY)
CSGNI = CSGNI*DCOS(YY)
50 CONTINUE
C-----------------------------------------------------------------------
C CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE
C WHEN FNU IS LARGE
C-----------------------------------------------------------------------
INU = INT(SNGL(FNU))
ARG = (FNU-DBLE(FLOAT(INU)))*SGN
CSPNR = DCOS(ARG)
CSPNI = DSIN(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

203
amos/zacon.f
View File

@ -1,203 +0,0 @@
SUBROUTINE ZACON(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, RL, FNUL,
* TOL, ELIM, ALIM)
C***BEGIN PROLOGUE ZACON
C***REFER TO ZBESK,ZBESH
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***ROUTINES CALLED ZBINU,ZBKNU,ZS1S2,D1MACH,AZABS,ZMLT
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, AZABS
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)
DATA PI / 3.14159265358979324D0 /
DATA ZEROR,CONER / 0.0D0,1.0D0 /
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 = MIN0(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 = DBLE(FLOAT(MR))
SGN = -DSIGN(PI,FMR)
CSGNR = ZEROR
CSGNI = SGN
IF (KODE.EQ.1) GO TO 10
YY = -ZNI
CPN = DCOS(YY)
SPN = DSIN(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 = INT(SNGL(FNU))
ARG = (FNU-DBLE(FLOAT(INU)))*SGN
CPN = DCOS(ARG)
SPN = DSIN(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 = AZABS(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 = AZABS(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 = DABS(C1R)
PTI = DABS(C1I)
C1M = DMAX1(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

393
amos/zairy.f
View File

@ -1,393 +0,0 @@
SUBROUTINE ZAIRY(ZR, ZI, ID, KODE, AIR, AII, NZ, IERR)
C***BEGIN PROLOGUE ZAIRY
C***DATE WRITTEN 830501 (YYMMDD)
C***REVISION DATE 890801 (YYMMDD)
C***CATEGORY NO. B5K
C***KEYWORDS AIRY FUNCTION,BESSEL FUNCTIONS OF ORDER ONE THIRD
C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
C***PURPOSE TO COMPUTE AIRY FUNCTIONS AI(Z) AND DAI(Z) FOR COMPLEX Z
C***DESCRIPTION
C
C ***A DOUBLE PRECISION ROUTINE***
C ON KODE=1, ZAIRY COMPUTES THE COMPLEX AIRY FUNCTION AI(Z) OR
C ITS DERIVATIVE DAI(Z)/DZ ON ID=0 OR ID=1 RESPECTIVELY. ON
C KODE=2, A SCALING OPTION CEXP(ZTA)*AI(Z) OR CEXP(ZTA)*
C DAI(Z)/DZ IS PROVIDED TO REMOVE THE EXPONENTIAL DECAY IN
C -PI/3.LT.ARG(Z).LT.PI/3 AND THE EXPONENTIAL GROWTH IN
C PI/3.LT.ABS(ARG(Z)).LT.PI WHERE ZTA=(2/3)*Z*CSQRT(Z).
C
C WHILE THE AIRY FUNCTIONS AI(Z) AND DAI(Z)/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 DEFINITIONS AND NOTATION ARE FOUND IN THE NBS HANDBOOK OF
C MATHEMATICAL FUNCTIONS (REF. 1).
C
C INPUT ZR,ZI ARE DOUBLE PRECISION
C ZR,ZI - Z=CMPLX(ZR,ZI)
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 OR
C AI=DAI(Z)/DZ ON ID=1
C = 2 RETURNS
C AI=CEXP(ZTA)*AI(Z) ON ID=0 OR
C AI=CEXP(ZTA)*DAI(Z)/DZ ON ID=1 WHERE
C ZTA=(2/3)*Z*CSQRT(Z)
C
C OUTPUT AIR,AII ARE DOUBLE PRECISION
C AIR,AII- COMPLEX ANSWER DEPENDING ON THE CHOICES FOR ID AND
C KODE
C NZ - UNDERFLOW INDICATOR
C NZ= 0 , NORMAL RETURN
C NZ= 1 , AI=CMPLX(0.0D0,0.0D0) DUE TO UNDERFLOW IN
C -PI/3.LT.ARG(Z).LT.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, REAL(ZTA)
C TOO LARGE ON KODE=1
C IERR=3, CABS(Z) LARGE - COMPUTATION COMPLETED
C LOSSES OF SIGNIFCANCE BY ARGUMENT REDUCTION
C PRODUCE LESS THAN HALF OF MACHINE ACCURACY
C IERR=4, CABS(Z) TOO LARGE - NO COMPUTATION
C COMPLETE LOSS OF ACCURACY BY ARGUMENT
C REDUCTION
C IERR=5, ERROR - NO COMPUTATION,
C ALGORITHM TERMINATION CONDITION NOT MET
C
C***LONG DESCRIPTION
C
C AI AND DAI ARE COMPUTED FOR CABS(Z).GT.1.0 FROM THE K BESSEL
C FUNCTIONS BY
C
C AI(Z)=C*SQRT(Z)*K(1/3,ZTA) , DAI(Z)=-C*Z*K(2/3,ZTA)
C C=1.0/(PI*SQRT(3.0))
C ZTA=(2/3)*Z**(3/2)
C
C WITH THE POWER SERIES FOR CABS(Z).LE.1.0.
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**1.5 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=DMAX1(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 THE
C LARGEST INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF ZETA
C MUST BE RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2,
C AND U3 ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE
C PRECISION ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE
C PRECISION ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMIT-
C ING IN THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT THE MAG-
C NITUDE OF Z CANNOT EXCEED 3.1E+4 IN SINGLE AND 2.1E+6 IN
C DOUBLE PRECISION ARITHMETIC. 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 7 DIGITS IN DOUBLE
C PRECISION ARITHMETIC. SIMILAR CONSIDERATIONS HOLD FOR OTHER
C MACHINES.
C
C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX
C BESSEL FUNCTION CAN BE EXPRESSED BY 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(CABS(Z))),
C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
C ONE COMPONENT (IN ABSOLUTE VALUE) 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 HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
C COMMERCE, 1955.
C
C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983
C
C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
C 1018, MAY, 1985
C
C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
C MATH. SOFTWARE, 1986
C
C***ROUTINES CALLED ZACAI,ZBKNU,AZEXP,AZSQRT,I1MACH,D1MACH
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, AZABS, ALAZ, BB
INTEGER ID, IERR, IFLAG, K, KODE, K1, K2, MR, NN, NZ, I1MACH
DIMENSION CYR(1), CYI(1)
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 = AZABS(ZR,ZI)
TOL = DMAX1(D1MACH(4),1.0D-18)
FID = DBLE(FLOAT(ID))
IF (AZ.GT.1.0D0) GO TO 70
C-----------------------------------------------------------------------
C POWER SERIES FOR CABS(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 = DMIN1(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 = DMIN1(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 AZSQRT(ZR, ZI, STR, STI)
ZTAR = TTH*(ZR*STR-ZI*STI)
ZTAI = TTH*(ZR*STI+ZI*STR)
CALL AZEXP(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 AZSQRT(ZR, ZI, STR, STI)
ZTAR = TTH*(ZR*STR-ZI*STI)
ZTAI = TTH*(ZR*STI+ZI*STR)
CALL AZEXP(ZTAR, ZTAI, STR, STI)
PTR = STR*AIR - STI*AII
AII = STR*AII + STI*AIR
AIR = PTR
RETURN
C-----------------------------------------------------------------------
C CASE FOR CABS(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 = MIN0(IABS(K1),IABS(K2))
ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0)
K1 = I1MACH(14) - 1
AA = R1M5*DBLE(FLOAT(K1))
DIG = DMIN1(AA,18.0D0)
AA = AA*2.303D0
ALIM = ELIM + DMAX1(-AA,-41.45D0)
RL = 1.2D0*DIG + 3.0D0
ALAZ = DLOG(AZ)
C--------------------------------------------------------------------------
C TEST FOR PROPER RANGE
C-----------------------------------------------------------------------
AA=0.5D0/TOL
BB=DBLE(FLOAT(I1MACH(9)))*0.5D0
AA=DMIN1(AA,BB)
AA=AA**TTH
IF (AZ.GT.AA) GO TO 260
AA=DSQRT(AA)
IF (AZ.GT.AA) IERR=3
CALL AZSQRT(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 = -DABS(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 = DSQRT(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

165
amos/zasyi.f
View File

@ -1,165 +0,0 @@
SUBROUTINE ZASYI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, RL, TOL, ELIM,
* ALIM)
C***BEGIN PROLOGUE ZASYI
C***REFER TO ZBESI,ZBESK
C
C ZASYI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY
C MEANS OF THE ASYMPTOTIC EXPANSION FOR LARGE CABS(Z) IN THE
C REGION CABS(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***ROUTINES CALLED D1MACH,AZABS,ZDIV,AZEXP,ZMLT,AZSQRT
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, AZABS
INTEGER I, IB, IL, INU, J, JL, K, KODE, KODED, M, N, NN, NZ
DIMENSION YR(N), YI(N)
DATA PI, RTPI /3.14159265358979324D0 , 0.159154943091895336D0 /
DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 /
C
NZ = 0
AZ = AZABS(ZR,ZI)
ARM = 1.0D+3*D1MACH(1)
RTR1 = DSQRT(ARM)
IL = MIN0(2,N)
DFNU = FNU + DBLE(FLOAT(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 AZSQRT(AK1R, AK1I, AK1R, AK1I)
CZR = ZR
CZI = ZI
IF (KODE.NE.2) GO TO 10
CZR = ZEROR
CZI = ZI
10 CONTINUE
IF (DABS(CZR).GT.ELIM) GO TO 100
DNU2 = DFNU + DFNU
KODED = 1
IF ((DABS(CZR).GT.ALIM) .AND. (N.GT.2)) GO TO 20
KODED = 0
CALL AZEXP(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 = INT(SNGL(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 = INT(SNGL(FNU))
ARG = (FNU-DBLE(FLOAT(INU)))*PI
INU = INU + N - IL
AK = -DSIN(ARG)
BK = DCOS(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*DABS(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*DABS(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 AZEXP(-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 = DBLE(FLOAT(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 AZEXP(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

348
amos/zbesh.f
View File

@ -1,348 +0,0 @@
SUBROUTINE ZBESH(ZR, ZI, FNU, KODE, M, N, CYR, CYI, NZ, IERR)
C***BEGIN PROLOGUE ZBESH
C***DATE WRITTEN 830501 (YYMMDD)
C***REVISION DATE 890801 (YYMMDD)
C***CATEGORY NO. B5K
C***KEYWORDS H-BESSEL FUNCTIONS,BESSEL FUNCTIONS OF COMPLEX ARGUMENT,
C BESSEL FUNCTIONS OF THIRD KIND,HANKEL FUNCTIONS
C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
C***PURPOSE TO COMPUTE THE H-BESSEL FUNCTIONS OF A COMPLEX ARGUMENT
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(J)=H(M,FNU+J-1,Z) FOR KINDS M=1
C OR 2, REAL, NONNEGATIVE ORDERS FNU+J-1, J=1,...,N, AND COMPLEX
C Z.NE.CMPLX(0.0,0.0) IN THE CUT PLANE -PI.LT.ARG(Z).LE.PI.
C ON KODE=2, ZBESH RETURNS THE SCALED HANKEL FUNCTIONS
C
C CY(I)=EXP(-MM*Z*I)*H(M,FNU+J-1,Z) MM=3-2*M, I**2=-1.
C
C WHICH REMOVES THE EXPONENTIAL BEHAVIOR IN BOTH THE UPPER AND
C LOWER HALF PLANES. DEFINITIONS AND NOTATION ARE FOUND IN THE
C NBS HANDBOOK OF MATHEMATICAL FUNCTIONS (REF. 1).
C
C INPUT ZR,ZI,FNU ARE DOUBLE PRECISION
C ZR,ZI - Z=CMPLX(ZR,ZI), Z.NE.CMPLX(0.0D0,0.0D0),
C -PT.LT.ARG(Z).LE.PI
C FNU - ORDER OF INITIAL H FUNCTION, FNU.GE.0.0D0
C KODE - A PARAMETER TO INDICATE THE SCALING OPTION
C KODE= 1 RETURNS
C CY(J)=H(M,FNU+J-1,Z), J=1,...,N
C = 2 RETURNS
C CY(J)=H(M,FNU+J-1,Z)*EXP(-I*Z*(3-2M))
C J=1,...,N , I**2=-1
C M - KIND OF HANKEL FUNCTION, M=1 OR 2
C N - NUMBER OF MEMBERS IN THE SEQUENCE, N.GE.1
C
C OUTPUT CYR,CYI ARE DOUBLE PRECISION
C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS
C CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE
C CY(J)=H(M,FNU+J-1,Z) OR
C CY(J)=H(M,FNU+J-1,Z)*EXP(-I*Z*(3-2M)) J=1,...,N
C DEPENDING ON KODE, I**2=-1.
C NZ - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW,
C NZ= 0 , NORMAL RETURN
C NZ.GT.0 , FIRST NZ COMPONENTS OF CY SET TO ZERO DUE
C TO UNDERFLOW, CY(J)=CMPLX(0.0D0,0.0D0)
C J=1,...,NZ WHEN Y.GT.0.0 AND M=1 OR
C Y.LT.0.0 AND M=2. FOR THE COMPLMENTARY
C HALF PLANES, NZ STATES ONLY THE NUMBER
C OF UNDERFLOWS.
C IERR - ERROR FLAG
C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
C IERR=1, INPUT ERROR - NO COMPUTATION
C IERR=2, OVERFLOW - NO COMPUTATION, FNU TOO
C LARGE OR CABS(Z) TOO SMALL OR BOTH
C IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE
C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT
C REDUCTION PRODUCE LESS THAN HALF OF MACHINE
C ACCURACY
C IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA-
C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI-
C CANCE BY ARGUMENT REDUCTION
C IERR=5, ERROR - NO COMPUTATION,
C ALGORITHM TERMINATION CONDITION NOT MET
C
C***LONG DESCRIPTION
C
C THE COMPUTATION IS CARRIED OUT BY THE RELATION
C
C H(M,FNU,Z)=(1/MP)*EXP(-MP*FNU)*K(FNU,Z*EXP(-MP))
C MP=MM*HPI*I, MM=3-2*M, HPI=PI/2, I**2=-1
C
C FOR M=1 OR 2 WHERE THE K BESSEL FUNCTION IS COMPUTED FOR THE
C RIGHT HALF PLANE RE(Z).GE.0.0. THE K FUNCTION IS CONTINUED
C TO THE LEFT HALF PLANE BY THE RELATION
C
C K(FNU,Z*EXP(MP)) = EXP(-MP*FNU)*K(FNU,Z)-MP*I(FNU,Z)
C MP=MR*PI*I, MR=+1 OR -1, RE(Z).GT.0, I**2=-1
C
C WHERE I(FNU,Z) IS THE I BESSEL FUNCTION.
C
C EXPONENTIAL DECAY OF H(M,FNU,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(-MM*Z*I) REMOVES THE EXPONENTIAL BEHAVIOR IN THE
C WHOLE Z PLANE FOR Z TO INFINITY.
C
C FOR NEGATIVE ORDERS,THE FORMULAE
C
C H(1,-FNU,Z) = H(1,FNU,Z)*CEXP( PI*FNU*I)
C H(2,-FNU,Z) = H(2,FNU,Z)*CEXP(-PI*FNU*I)
C I**2=-1
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=DMAX1(D1MACH(4),1.0D-18) IS
C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION.
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 IS
C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3
C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION
C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION
C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN
C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT
C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS
C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC.
C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES.
C
C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX
C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT
C ROUNDOFF,1.0D-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(CABS(Z))),
C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
C ONE COMPONENT (IN ABSOLUTE VALUE) 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 HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
C COMMERCE, 1955.
C
C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
C BY D. E. AMOS, SAND83-0083, MAY, 1983.
C
C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983
C
C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
C 1018, MAY, 1985
C
C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
C MATH. SOFTWARE, 1986
C
C***ROUTINES CALLED ZACON,ZBKNU,ZBUNK,ZUOIK,AZABS,I1MACH,D1MACH
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, AZABS, 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)
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 = DMAX1(D1MACH(4),1.0D-18)
K1 = I1MACH(15)
K2 = I1MACH(16)
R1M5 = D1MACH(5)
K = MIN0(IABS(K1),IABS(K2))
ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0)
K1 = I1MACH(14) - 1
AA = R1M5*DBLE(FLOAT(K1))
DIG = DMIN1(AA,18.0D0)
AA = AA*2.303D0
ALIM = ELIM + DMAX1(-AA,-41.45D0)
FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0)
RL = 1.2D0*DIG + 3.0D0
FN = FNU + DBLE(FLOAT(NN-1))
MM = 3 - M - M
FMM = DBLE(FLOAT(MM))
ZNR = FMM*ZI
ZNI = -FMM*ZR
C-----------------------------------------------------------------------
C TEST FOR PROPER RANGE
C-----------------------------------------------------------------------
AZ = AZABS(ZR,ZI)
AA = 0.5D0/TOL
BB=DBLE(FLOAT(I1MACH(9)))*0.5D0
AA = DMIN1(AA,BB)
IF (AZ.GT.AA) GO TO 260
IF (FN.GT.AA) GO TO 260
AA = DSQRT(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*DLOG(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 = INT(SNGL(FNU))
INUH = INU/2
IR = INU - 2*INUH
ARG = (FNU-DBLE(FLOAT(INU-IR)))*SGN
RHPI = 1.0D0/SGN
C ZNI = RHPI*DCOS(ARG)
C ZNR = -RHPI*DSIN(ARG)
CSGNI = RHPI*DCOS(ARG)
CSGNR = -RHPI*DSIN(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 (DMAX1(DABS(AA),DABS(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

269
amos/zbesi.f
View File

@ -1,269 +0,0 @@
SUBROUTINE ZBESI(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR)
C***BEGIN PROLOGUE ZBESI
C***DATE WRITTEN 830501 (YYMMDD)
C***REVISION DATE 890801 (YYMMDD)
C***CATEGORY NO. B5K
C***KEYWORDS I-BESSEL FUNCTION,COMPLEX BESSEL FUNCTION,
C MODIFIED BESSEL FUNCTION OF THE FIRST KIND
C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
C***PURPOSE TO COMPUTE I-BESSEL FUNCTIONS OF COMPLEX ARGUMENT
C***DESCRIPTION
C
C ***A DOUBLE PRECISION ROUTINE***
C ON KODE=1, ZBESI COMPUTES AN N MEMBER SEQUENCE OF COMPLEX
C BESSEL FUNCTIONS CY(J)=I(FNU+J-1,Z) FOR REAL, NONNEGATIVE
C ORDERS FNU+J-1, J=1,...,N AND COMPLEX Z IN THE CUT PLANE
C -PI.LT.ARG(Z).LE.PI. ON KODE=2, ZBESI RETURNS THE SCALED
C FUNCTIONS
C
C CY(J)=EXP(-ABS(X))*I(FNU+J-1,Z) J = 1,...,N , X=REAL(Z)
C
C WITH THE EXPONENTIAL GROWTH REMOVED IN BOTH THE LEFT AND
C RIGHT HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND NOTATION
C ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS
C (REF. 1).
C
C INPUT ZR,ZI,FNU ARE DOUBLE PRECISION
C ZR,ZI - Z=CMPLX(ZR,ZI), -PI.LT.ARG(Z).LE.PI
C FNU - ORDER OF INITIAL I FUNCTION, FNU.GE.0.0D0
C KODE - A PARAMETER TO INDICATE THE SCALING OPTION
C KODE= 1 RETURNS
C CY(J)=I(FNU+J-1,Z), J=1,...,N
C = 2 RETURNS
C CY(J)=I(FNU+J-1,Z)*EXP(-ABS(X)), J=1,...,N
C N - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1
C
C OUTPUT CYR,CYI ARE DOUBLE PRECISION
C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS
C CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE
C CY(J)=I(FNU+J-1,Z) OR
C CY(J)=I(FNU+J-1,Z)*EXP(-ABS(X)) J=1,...,N
C DEPENDING ON KODE, X=REAL(Z)
C NZ - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW,
C NZ= 0 , NORMAL RETURN
C NZ.GT.0 , LAST NZ COMPONENTS OF CY SET TO ZERO
C TO UNDERFLOW, CY(J)=CMPLX(0.0D0,0.0D0)
C J = 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, REAL(Z) TOO
C LARGE ON KODE=1
C IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE
C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT
C REDUCTION PRODUCE LESS THAN HALF OF MACHINE
C ACCURACY
C IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA-
C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI-
C CANCE BY ARGUMENT REDUCTION
C IERR=5, ERROR - NO COMPUTATION,
C ALGORITHM TERMINATION CONDITION NOT MET
C
C***LONG DESCRIPTION
C
C THE COMPUTATION IS CARRIED OUT BY THE POWER SERIES FOR
C SMALL CABS(Z), THE ASYMPTOTIC EXPANSION FOR LARGE CABS(Z),
C THE MILLER ALGORITHM NORMALIZED BY THE WRONSKIAN AND A
C NEUMANN SERIES FOR IMTERMEDIATE MAGNITUDES, AND THE
C UNIFORM ASYMPTOTIC EXPANSIONS FOR I(FNU,Z) AND J(FNU,Z)
C FOR LARGE ORDERS. 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(FNU,Z*EXP(M*PI)) = EXP(M*PI*FNU)*I(FNU,Z) REAL(Z).GT.0.0
C M = +I OR -I, I**2=-1
C
C FOR NEGATIVE ORDERS,THE FORMULA
C
C I(-FNU,Z) = I(FNU,Z) + (2/PI)*SIN(PI*FNU)*K(FNU,Z)
C
C CAN BE USED. HOWEVER,FOR LARGE ORDERS CLOSE TO INTEGERS, THE
C THE FUNCTION CHANGES RADICALLY. WHEN FNU IS A LARGE POSITIVE
C INTEGER,THE MAGNITUDE OF I(-FNU,Z)=I(FNU,Z) IS A LARGE
C NEGATIVE POWER OF TEN. BUT WHEN FNU IS NOT AN INTEGER,
C K(FNU,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 FNU. HERE,
C LARGE MEANS FNU.GT.CABS(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=DMAX1(D1MACH(4),1.0D-18) IS
C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION.
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 IS
C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3
C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION
C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION
C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN
C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT
C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS
C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC.
C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES.
C
C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX
C BESSEL FUNCTION CAN BE EXPRESSED BY 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(CABS(Z))),
C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
C ONE COMPONENT (IN ABSOLUTE VALUE) 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 HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
C COMMERCE, 1955.
C
C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
C BY D. E. AMOS, SAND83-0083, MAY, 1983.
C
C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983
C
C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
C 1018, MAY, 1985
C
C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
C MATH. SOFTWARE, 1986
C
C***ROUTINES CALLED ZBINU,I1MACH,D1MACH
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, AZABS, ASCLE, RTOL, ATOL, STI
INTEGER I, IERR, INU, K, KODE, K1,K2,N,NZ,NN, I1MACH
DIMENSION CYR(N), CYI(N)
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 = DMAX1(D1MACH(4),1.0D-18)
K1 = I1MACH(15)
K2 = I1MACH(16)
R1M5 = D1MACH(5)
K = MIN0(IABS(K1),IABS(K2))
ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0)
K1 = I1MACH(14) - 1
AA = R1M5*DBLE(FLOAT(K1))
DIG = DMIN1(AA,18.0D0)
AA = AA*2.303D0
ALIM = ELIM + DMAX1(-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 = AZABS(ZR,ZI)
FN = FNU+DBLE(FLOAT(N-1))
AA = 0.5D0/TOL
BB=DBLE(FLOAT(I1MACH(9)))*0.5D0
AA = DMIN1(AA,BB)
IF (AZ.GT.AA) GO TO 260
IF (FN.GT.AA) GO TO 260
AA = DSQRT(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 = INT(SNGL(FNU))
ARG = (FNU-DBLE(FLOAT(INU)))*PI
IF (ZI.LT.0.0D0) ARG = -ARG
CSGNR = DCOS(ARG)
CSGNI = DSIN(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 (DMAX1(DABS(AA),DABS(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

266
amos/zbesj.f
View File

@ -1,266 +0,0 @@
SUBROUTINE ZBESJ(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR)
C***BEGIN PROLOGUE ZBESJ
C***DATE WRITTEN 830501 (YYMMDD)
C***REVISION DATE 890801 (YYMMDD)
C***CATEGORY NO. B5K
C***KEYWORDS J-BESSEL FUNCTION,BESSEL FUNCTION OF COMPLEX ARGUMENT,
C BESSEL FUNCTION OF FIRST KIND
C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
C***PURPOSE TO COMPUTE THE J-BESSEL FUNCTION OF A COMPLEX ARGUMENT
C***DESCRIPTION
C
C ***A DOUBLE PRECISION ROUTINE***
C ON KODE=1, CBESJ COMPUTES AN N MEMBER SEQUENCE OF COMPLEX
C BESSEL FUNCTIONS CY(I)=J(FNU+I-1,Z) FOR REAL, NONNEGATIVE
C ORDERS FNU+I-1, I=1,...,N AND COMPLEX Z IN THE CUT PLANE
C -PI.LT.ARG(Z).LE.PI. ON KODE=2, CBESJ RETURNS THE SCALED
C FUNCTIONS
C
C CY(I)=EXP(-ABS(Y))*J(FNU+I-1,Z) I = 1,...,N , Y=AIMAG(Z)
C
C WHICH REMOVE THE EXPONENTIAL GROWTH IN BOTH THE UPPER AND
C LOWER HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND NOTATION
C ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS
C (REF. 1).
C
C INPUT ZR,ZI,FNU ARE DOUBLE PRECISION
C ZR,ZI - Z=CMPLX(ZR,ZI), -PI.LT.ARG(Z).LE.PI
C FNU - ORDER OF INITIAL J FUNCTION, FNU.GE.0.0D0
C KODE - A PARAMETER TO INDICATE THE SCALING OPTION
C KODE= 1 RETURNS
C CY(I)=J(FNU+I-1,Z), I=1,...,N
C = 2 RETURNS
C CY(I)=J(FNU+I-1,Z)EXP(-ABS(Y)), I=1,...,N
C N - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1
C
C OUTPUT CYR,CYI ARE DOUBLE PRECISION
C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS
C CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE
C CY(I)=J(FNU+I-1,Z) OR
C CY(I)=J(FNU+I-1,Z)EXP(-ABS(Y)) I=1,...,N
C DEPENDING ON KODE, Y=AIMAG(Z).
C NZ - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW,
C NZ= 0 , NORMAL RETURN
C NZ.GT.0 , LAST NZ COMPONENTS OF CY SET ZERO DUE
C TO UNDERFLOW, CY(I)=CMPLX(0.0D0,0.0D0),
C I = 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, AIMAG(Z)
C TOO LARGE ON KODE=1
C IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE
C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT
C REDUCTION PRODUCE LESS THAN HALF OF MACHINE
C ACCURACY
C IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA-
C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI-
C CANCE BY ARGUMENT REDUCTION
C IERR=5, ERROR - NO COMPUTATION,
C ALGORITHM TERMINATION CONDITION NOT MET
C
C***LONG DESCRIPTION
C
C THE COMPUTATION IS CARRIED OUT BY THE FORMULA
C
C J(FNU,Z)=EXP( FNU*PI*I/2)*I(FNU,-I*Z) AIMAG(Z).GE.0.0
C
C J(FNU,Z)=EXP(-FNU*PI*I/2)*I(FNU, I*Z) AIMAG(Z).LT.0.0
C
C WHERE I**2 = -1 AND I(FNU,Z) IS THE I BESSEL FUNCTION.
C
C FOR NEGATIVE ORDERS,THE FORMULA
C
C J(-FNU,Z) = J(FNU,Z)*COS(PI*FNU) - Y(FNU,Z)*SIN(PI*FNU)
C
C CAN BE USED. HOWEVER,FOR LARGE ORDERS CLOSE TO INTEGERS, THE
C THE FUNCTION CHANGES RADICALLY. WHEN FNU IS A LARGE POSITIVE
C INTEGER,THE MAGNITUDE OF J(-FNU,Z)=J(FNU,Z)*COS(PI*FNU) IS A
C LARGE NEGATIVE POWER OF TEN. BUT WHEN FNU IS NOT AN INTEGER,
C Y(FNU,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 FNU. HERE,
C LARGE MEANS FNU.GT.CABS(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=DMAX1(D1MACH(4),1.0D-18) IS
C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION.
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 IS
C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3
C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION
C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION
C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN
C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT
C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS
C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC.
C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES.
C
C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX
C BESSEL FUNCTION CAN BE EXPRESSED BY 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(CABS(Z))),
C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
C ONE COMPONENT (IN ABSOLUTE VALUE) 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 HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
C COMMERCE, 1955.
C
C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
C BY D. E. AMOS, SAND83-0083, MAY, 1983.
C
C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983
C
C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
C 1018, MAY, 1985
C
C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
C MATH. SOFTWARE, 1986
C
C***ROUTINES CALLED ZBINU,I1MACH,D1MACH
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, AZABS, ASCLE, RTOL, ATOL, STI
INTEGER I, IERR, INU, INUH, IR, K, KODE, K1, K2, N, NL, NZ, I1MACH
DIMENSION CYR(N), CYI(N)
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 = DMAX1(D1MACH(4),1.0D-18)
K1 = I1MACH(15)
K2 = I1MACH(16)
R1M5 = D1MACH(5)
K = MIN0(IABS(K1),IABS(K2))
ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0)
K1 = I1MACH(14) - 1
AA = R1M5*DBLE(FLOAT(K1))
DIG = DMIN1(AA,18.0D0)
AA = AA*2.303D0
ALIM = ELIM + DMAX1(-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 = AZABS(ZR,ZI)
FN = FNU+DBLE(FLOAT(N-1))
AA = 0.5D0/TOL
BB=DBLE(FLOAT(I1MACH(9)))*0.5D0
AA = DMIN1(AA,BB)
IF (AZ.GT.AA) GO TO 260
IF (FN.GT.AA) GO TO 260
AA = DSQRT(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 = INT(SNGL(FNU))
INUH = INU/2
IR = INU - 2*INUH
ARG = (FNU-DBLE(FLOAT(INU-IR)))*HPI
CSGNR = DCOS(ARG)
CSGNI = DSIN(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 (DMAX1(DABS(AA),DABS(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

281
amos/zbesk.f
View File

@ -1,281 +0,0 @@
SUBROUTINE ZBESK(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR)
C***BEGIN PROLOGUE ZBESK
C***DATE WRITTEN 830501 (YYMMDD)
C***REVISION DATE 890801 (YYMMDD)
C***CATEGORY NO. B5K
C***KEYWORDS K-BESSEL FUNCTION,COMPLEX BESSEL FUNCTION,
C MODIFIED BESSEL FUNCTION OF THE SECOND KIND,
C BESSEL FUNCTION OF THE THIRD KIND
C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
C***PURPOSE TO COMPUTE K-BESSEL FUNCTIONS OF COMPLEX ARGUMENT
C***DESCRIPTION
C
C ***A DOUBLE PRECISION ROUTINE***
C
C ON KODE=1, CBESK COMPUTES AN N MEMBER SEQUENCE OF COMPLEX
C BESSEL FUNCTIONS CY(J)=K(FNU+J-1,Z) FOR REAL, NONNEGATIVE
C ORDERS FNU+J-1, J=1,...,N AND COMPLEX Z.NE.CMPLX(0.0,0.0)
C IN THE CUT PLANE -PI.LT.ARG(Z).LE.PI. ON KODE=2, CBESK
C RETURNS THE SCALED K FUNCTIONS,
C
C CY(J)=EXP(Z)*K(FNU+J-1,Z) , J=1,...,N,
C
C WHICH REMOVE THE EXPONENTIAL BEHAVIOR IN BOTH THE LEFT AND
C RIGHT HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND
C NOTATION ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL
C FUNCTIONS (REF. 1).
C
C INPUT ZR,ZI,FNU ARE DOUBLE PRECISION
C ZR,ZI - Z=CMPLX(ZR,ZI), Z.NE.CMPLX(0.0D0,0.0D0),
C -PI.LT.ARG(Z).LE.PI
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 CY(I)=K(FNU+I-1,Z), I=1,...,N
C = 2 RETURNS
C CY(I)=K(FNU+I-1,Z)*EXP(Z), I=1,...,N
C
C OUTPUT CYR,CYI ARE DOUBLE PRECISION
C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS
C CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE
C CY(I)=K(FNU+I-1,Z), I=1,...,N OR
C CY(I)=K(FNU+I-1,Z)*EXP(Z), I=1,...,N
C DEPENDING ON KODE
C NZ - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW.
C NZ= 0 , NORMAL RETURN
C NZ.GT.0 , FIRST NZ COMPONENTS OF CY SET TO ZERO DUE
C TO UNDERFLOW, CY(I)=CMPLX(0.0D0,0.0D0),
C I=1,...,N WHEN X.GE.0.0. WHEN X.LT.0.0
C NZ STATES ONLY THE NUMBER OF UNDERFLOWS
C IN THE SEQUENCE.
C
C IERR - ERROR FLAG
C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
C IERR=1, INPUT ERROR - NO COMPUTATION
C IERR=2, OVERFLOW - NO COMPUTATION, FNU IS
C TOO LARGE OR CABS(Z) IS TOO SMALL OR BOTH
C IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE
C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT
C REDUCTION PRODUCE LESS THAN HALF OF MACHINE
C ACCURACY
C IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA-
C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI-
C CANCE BY ARGUMENT REDUCTION
C IERR=5, ERROR - NO COMPUTATION,
C ALGORITHM TERMINATION CONDITION NOT MET
C
C***LONG DESCRIPTION
C
C EQUATIONS OF THE REFERENCE ARE IMPLEMENTED FOR SMALL ORDERS
C DNU AND DNU+1.0 IN THE RIGHT HALF PLANE X.GE.0.0. FORWARD
C RECURRENCE GENERATES HIGHER ORDERS. K IS CONTINUED TO THE LEFT
C HALF PLANE BY THE RELATION
C
C K(FNU,Z*EXP(MP)) = EXP(-MP*FNU)*K(FNU,Z)-MP*I(FNU,Z)
C MP=MR*PI*I, MR=+1 OR -1, RE(Z).GT.0, I**2=-1
C
C WHERE I(FNU,Z) IS THE I BESSEL FUNCTION.
C
C FOR LARGE ORDERS, FNU.GT.FNUL, THE K FUNCTION IS COMPUTED
C BY MEANS OF ITS UNIFORM ASYMPTOTIC EXPANSIONS.
C
C FOR NEGATIVE ORDERS, THE FORMULA
C
C K(-FNU,Z) = K(FNU,Z)
C
C CAN BE USED.
C
C CBESK ASSUMES THAT A SIGNIFICANT DIGIT SINH(X) 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=DMAX1(D1MACH(4),1.0D-18) IS
C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION.
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 IS
C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3
C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION
C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION
C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN
C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT
C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS
C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC.
C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES.
C
C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX
C BESSEL FUNCTION CAN BE EXPRESSED BY 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(CABS(Z))),
C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
C ONE COMPONENT (IN ABSOLUTE VALUE) 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 HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
C COMMERCE, 1955.
C
C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
C BY D. E. AMOS, SAND83-0083, MAY, 1983.
C
C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983.
C
C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
C 1018, MAY, 1985
C
C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
C MATH. SOFTWARE, 1986
C
C***ROUTINES CALLED ZACON,ZBKNU,ZBUNK,ZUOIK,AZABS,I1MACH,D1MACH
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, AZABS, BB
INTEGER IERR, K, KODE, K1, K2, MR, N, NN, NUF, NW, NZ, I1MACH
DIMENSION CYR(N), CYI(N)
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 = DMAX1(D1MACH(4),1.0D-18)
K1 = I1MACH(15)
K2 = I1MACH(16)
R1M5 = D1MACH(5)
K = MIN0(IABS(K1),IABS(K2))
ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0)
K1 = I1MACH(14) - 1
AA = R1M5*DBLE(FLOAT(K1))
DIG = DMIN1(AA,18.0D0)
AA = AA*2.303D0
ALIM = ELIM + DMAX1(-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 = AZABS(ZR,ZI)
FN = FNU + DBLE(FLOAT(NN-1))
AA = 0.5D0/TOL
BB=DBLE(FLOAT(I1MACH(9)))*0.5D0
AA = DMIN1(AA,BB)
IF (AZ.GT.AA) GO TO 260
IF (FN.GT.AA) GO TO 260
AA = DSQRT(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 = DEXP(-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*DLOG(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

244
amos/zbesy.f
View File

@ -1,244 +0,0 @@
SUBROUTINE ZBESY(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, CWRKR, CWRKI,
* IERR)
C***BEGIN PROLOGUE ZBESY
C***DATE WRITTEN 830501 (YYMMDD)
C***REVISION DATE 890801 (YYMMDD)
C***CATEGORY NO. B5K
C***KEYWORDS Y-BESSEL FUNCTION,BESSEL FUNCTION OF COMPLEX ARGUMENT,
C BESSEL FUNCTION OF SECOND KIND
C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
C***PURPOSE TO COMPUTE THE Y-BESSEL FUNCTION OF A COMPLEX ARGUMENT
C***DESCRIPTION
C
C ***A DOUBLE PRECISION ROUTINE***
C
C ON KODE=1, CBESY COMPUTES AN N MEMBER SEQUENCE OF COMPLEX
C BESSEL FUNCTIONS CY(I)=Y(FNU+I-1,Z) FOR REAL, NONNEGATIVE
C ORDERS FNU+I-1, I=1,...,N AND COMPLEX Z IN THE CUT PLANE
C -PI.LT.ARG(Z).LE.PI. ON KODE=2, CBESY RETURNS THE SCALED
C FUNCTIONS
C
C CY(I)=EXP(-ABS(Y))*Y(FNU+I-1,Z) I = 1,...,N , Y=AIMAG(Z)
C
C WHICH REMOVE THE EXPONENTIAL GROWTH IN BOTH THE UPPER AND
C LOWER HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND NOTATION
C ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS
C (REF. 1).
C
C INPUT ZR,ZI,FNU ARE DOUBLE PRECISION
C ZR,ZI - Z=CMPLX(ZR,ZI), Z.NE.CMPLX(0.0D0,0.0D0),
C -PI.LT.ARG(Z).LE.PI
C FNU - ORDER OF INITIAL Y FUNCTION, FNU.GE.0.0D0
C KODE - A PARAMETER TO INDICATE THE SCALING OPTION
C KODE= 1 RETURNS
C CY(I)=Y(FNU+I-1,Z), I=1,...,N
C = 2 RETURNS
C CY(I)=Y(FNU+I-1,Z)*EXP(-ABS(Y)), I=1,...,N
C WHERE Y=AIMAG(Z)
C N - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1
C CWRKR, - DOUBLE PRECISION WORK VECTORS OF DIMENSION AT
C CWRKI AT LEAST N
C
C OUTPUT CYR,CYI ARE DOUBLE PRECISION
C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS
C CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE
C CY(I)=Y(FNU+I-1,Z) OR
C CY(I)=Y(FNU+I-1,Z)*EXP(-ABS(Y)) I=1,...,N
C DEPENDING ON KODE.
C NZ - NZ=0 , A NORMAL RETURN
C NZ.GT.0 , NZ COMPONENTS OF CY SET TO ZERO DUE TO
C UNDERFLOW (GENERALLY ON KODE=2)
C IERR - ERROR FLAG
C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
C IERR=1, INPUT ERROR - NO COMPUTATION
C IERR=2, OVERFLOW - NO COMPUTATION, FNU IS
C TOO LARGE OR CABS(Z) IS TOO SMALL OR BOTH
C IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE
C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT
C REDUCTION PRODUCE LESS THAN HALF OF MACHINE
C ACCURACY
C IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA-
C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI-
C CANCE BY ARGUMENT REDUCTION
C IERR=5, ERROR - NO COMPUTATION,
C ALGORITHM TERMINATION CONDITION NOT MET
C
C***LONG DESCRIPTION
C
C THE COMPUTATION IS CARRIED OUT BY THE FORMULA
C
C Y(FNU,Z)=0.5*(H(1,FNU,Z)-H(2,FNU,Z))/I
C
C WHERE I**2 = -1 AND THE HANKEL BESSEL FUNCTIONS H(1,FNU,Z)
C AND H(2,FNU,Z) ARE CALCULATED IN CBESH.
C
C FOR NEGATIVE ORDERS,THE FORMULA
C
C Y(-FNU,Z) = Y(FNU,Z)*COS(PI*FNU) + J(FNU,Z)*SIN(PI*FNU)
C
C CAN BE USED. HOWEVER,FOR LARGE ORDERS CLOSE TO HALF ODD
C INTEGERS THE FUNCTION CHANGES RADICALLY. WHEN FNU IS A LARGE
C POSITIVE HALF ODD INTEGER,THE MAGNITUDE OF Y(-FNU,Z)=J(FNU,Z)*
C SIN(PI*FNU) IS A LARGE NEGATIVE POWER OF TEN. BUT WHEN FNU IS
C NOT A HALF ODD INTEGER, Y(FNU,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. THUS,
C WIDE CHANGES CAN OCCUR WITHIN UNIT ROUNDOFF OF A LARGE HALF
C ODD INTEGER. HERE, LARGE MEANS FNU.GT.CABS(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=DMAX1(D1MACH(4),1.0D-18) IS
C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION.
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 IS
C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3
C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION
C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION
C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN
C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT
C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS
C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC.
C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES.
C
C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX
C BESSEL FUNCTION CAN BE EXPRESSED BY 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(CABS(Z))),
C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
C ONE COMPONENT (IN ABSOLUTE VALUE) 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 HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
C COMMERCE, 1955.
C
C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
C BY D. E. AMOS, SAND83-0083, MAY, 1983.
C
C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983
C
C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
C 1018, MAY, 1985
C
C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
C MATH. SOFTWARE, 1986
C
C***ROUTINES CALLED ZBESH,I1MACH,D1MACH
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, DEXP,
* D1MACH, ASCLE, RTOL, ATOL, AA, BB, TOL
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 = MIN0(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 = DMAX1(D1MACH(4),1.0D-18)
K1 = I1MACH(15)
K2 = I1MACH(16)
K = MIN0(IABS(K1),IABS(K2))
R1M5 = D1MACH(5)
C-----------------------------------------------------------------------
C ELIM IS THE APPROXIMATE EXPONENTIAL UNDER- AND OVERFLOW LIMIT
C-----------------------------------------------------------------------
ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0)
EXR = DCOS(ZR)
EXI = DSIN(ZR)
EY = 0.0D0
TAY = DABS(ZI+ZI)
IF (TAY.LT.ELIM) EY = DEXP(-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 (DMAX1(DABS(AA),DABS(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 (DMAX1(DABS(AA),DABS(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

110
amos/zbinu.f
View File

@ -1,110 +0,0 @@
SUBROUTINE ZBINU(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL,
* TOL, ELIM, ALIM)
C***BEGIN PROLOGUE ZBINU
C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZAIRY,ZBIRY
C
C ZBINU COMPUTES THE I FUNCTION IN THE RIGHT HALF Z PLANE
C
C***ROUTINES CALLED AZABS,ZASYI,ZBUNI,ZMLRI,ZSERI,ZUOIK,ZWRSK
C***END PROLOGUE ZBINU
DOUBLE PRECISION ALIM, AZ, CWI, CWR, CYI, CYR, DFNU, ELIM, FNU,
* FNUL, RL, TOL, ZEROI, ZEROR, ZI, ZR, AZABS
INTEGER I, INW, KODE, N, NLAST, NN, NUI, NW, NZ
DIMENSION CYR(N), CYI(N), CWR(2), CWI(2)
DATA ZEROR,ZEROI / 0.0D0, 0.0D0 /
C
NZ = 0
AZ = AZABS(ZR,ZI)
NN = N
DFNU = FNU + DBLE(FLOAT(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 = IABS(NW)
NZ = NZ + INW
NN = NN - INW
IF (NN.EQ.0) RETURN
IF (NW.GE.0) GO TO 120
DFNU = FNU + DBLE(FLOAT(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+DBLE(FLOAT(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 = INT(SNGL(FNUL-DFNU)) + 1
NUI = MAX0(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

364
amos/zbiry.f
View File

@ -1,364 +0,0 @@
SUBROUTINE ZBIRY(ZR, ZI, ID, KODE, BIR, BII, IERR)
C***BEGIN PROLOGUE ZBIRY
C***DATE WRITTEN 830501 (YYMMDD)
C***REVISION DATE 890801 (YYMMDD)
C***CATEGORY NO. B5K
C***KEYWORDS AIRY FUNCTION,BESSEL FUNCTIONS OF ORDER ONE THIRD
C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
C***PURPOSE TO COMPUTE AIRY FUNCTIONS BI(Z) AND DBI(Z) FOR COMPLEX Z
C***DESCRIPTION
C
C ***A DOUBLE PRECISION ROUTINE***
C ON KODE=1, CBIRY COMPUTES THE COMPLEX AIRY FUNCTION BI(Z) OR
C ITS DERIVATIVE DBI(Z)/DZ ON ID=0 OR ID=1 RESPECTIVELY. ON
C KODE=2, A SCALING OPTION CEXP(-AXZTA)*BI(Z) OR CEXP(-AXZTA)*
C DBI(Z)/DZ IS PROVIDED TO REMOVE THE EXPONENTIAL BEHAVIOR IN
C BOTH THE LEFT AND RIGHT HALF PLANES WHERE
C ZTA=(2/3)*Z*CSQRT(Z)=CMPLX(XZTA,YZTA) AND AXZTA=ABS(XZTA).
C DEFINITIONS AND NOTATION ARE FOUND IN THE NBS HANDBOOK OF
C MATHEMATICAL FUNCTIONS (REF. 1).
C
C INPUT ZR,ZI ARE DOUBLE PRECISION
C ZR,ZI - Z=CMPLX(ZR,ZI)
C ID - ORDER OF DERIVATIVE, ID=0 OR ID=1
C KODE - A PARAMETER TO INDICATE THE SCALING OPTION
C KODE= 1 RETURNS
C BI=BI(Z) ON ID=0 OR
C BI=DBI(Z)/DZ ON ID=1
C = 2 RETURNS
C BI=CEXP(-AXZTA)*BI(Z) ON ID=0 OR
C BI=CEXP(-AXZTA)*DBI(Z)/DZ ON ID=1 WHERE
C ZTA=(2/3)*Z*CSQRT(Z)=CMPLX(XZTA,YZTA)
C AND AXZTA=ABS(XZTA)
C
C OUTPUT BIR,BII ARE DOUBLE PRECISION
C BIR,BII- COMPLEX ANSWER DEPENDING ON THE CHOICES FOR ID AND
C KODE
C IERR - ERROR FLAG
C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
C IERR=1, INPUT ERROR - NO COMPUTATION
C IERR=2, OVERFLOW - NO COMPUTATION, REAL(Z)
C TOO LARGE ON KODE=1
C IERR=3, CABS(Z) LARGE - COMPUTATION COMPLETED
C LOSSES OF SIGNIFCANCE BY ARGUMENT REDUCTION
C PRODUCE LESS THAN HALF OF MACHINE ACCURACY
C IERR=4, CABS(Z) TOO LARGE - NO COMPUTATION
C COMPLETE LOSS OF ACCURACY BY ARGUMENT
C REDUCTION
C IERR=5, ERROR - NO COMPUTATION,
C ALGORITHM TERMINATION CONDITION NOT MET
C
C***LONG DESCRIPTION
C
C BI AND DBI ARE COMPUTED FOR CABS(Z).GT.1.0 FROM THE I BESSEL
C FUNCTIONS BY
C
C BI(Z)=C*SQRT(Z)*( I(-1/3,ZTA) + I(1/3,ZTA) )
C DBI(Z)=C * Z * ( I(-2/3,ZTA) + I(2/3,ZTA) )
C C=1.0/SQRT(3.0)
C ZTA=(2/3)*Z**(3/2)
C
C WITH THE POWER SERIES FOR CABS(Z).LE.1.0.
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**1.5 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=DMAX1(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 THE
C LARGEST INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF ZETA
C MUST BE RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2,
C AND U3 ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE
C PRECISION ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE
C PRECISION ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMIT-
C ING IN THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT THE MAG-
C NITUDE OF Z CANNOT EXCEED 3.1E+4 IN SINGLE AND 2.1E+6 IN
C DOUBLE PRECISION ARITHMETIC. 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 7 DIGITS IN DOUBLE
C PRECISION ARITHMETIC. SIMILAR CONSIDERATIONS HOLD FOR OTHER
C MACHINES.
C
C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX
C BESSEL FUNCTION CAN BE EXPRESSED BY 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(CABS(Z))),
C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
C ONE COMPONENT (IN ABSOLUTE VALUE) 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 HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
C COMMERCE, 1955.
C
C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983
C
C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
C 1018, MAY, 1985
C
C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
C MATH. SOFTWARE, 1986
C
C***ROUTINES CALLED ZBINU,AZABS,ZDIV,AZSQRT,D1MACH,I1MACH
C***END PROLOGUE ZBIRY
C COMPLEX BI,CONE,CSQ,CY,S1,S2,TRM1,TRM2,Z,ZTA,Z3
DOUBLE PRECISION AA, AD, AK, ALIM, ATRM, AZ, AZ3, BB, BII, BIR,
* BK, CC, CK, COEF, CONEI, CONER, CSQI, CSQR, CYI, CYR, C1, C2,
* DIG, DK, D1, D2, EAA, ELIM, FID, FMR, FNU, FNUL, PI, RL, R1M5,
* SFAC, STI, STR, S1I, S1R, S2I, S2R, TOL, TRM1I, TRM1R, TRM2I,
* TRM2R, TTH, ZI, ZR, ZTAI, ZTAR, Z3I, Z3R, D1MACH, AZABS
INTEGER ID, IERR, K, KODE, K1, K2, NZ, I1MACH
DIMENSION CYR(2), CYI(2)
DATA TTH, C1, C2, COEF, PI /6.66666666666666667D-01,
* 6.14926627446000736D-01,4.48288357353826359D-01,
* 5.77350269189625765D-01,3.14159265358979324D+00/
DATA CONER, CONEI /1.0D0,0.0D0/
C***FIRST EXECUTABLE STATEMENT ZBIRY
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 = AZABS(ZR,ZI)
TOL = DMAX1(D1MACH(4),1.0D-18)
FID = DBLE(FLOAT(ID))
IF (AZ.GT.1.0E0) GO TO 70
C-----------------------------------------------------------------------
C POWER SERIES FOR CABS(Z).LE.1.
C-----------------------------------------------------------------------
S1R = CONER
S1I = CONEI
S2R = CONER
S2I = CONEI
IF (AZ.LT.TOL) GO TO 130
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 = DMIN1(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 = DMIN1(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
BIR = C1*S1R + C2*(ZR*S2R-ZI*S2I)
BII = C1*S1I + C2*(ZR*S2I+ZI*S2R)
IF (KODE.EQ.1) RETURN
CALL AZSQRT(ZR, ZI, STR, STI)
ZTAR = TTH*(ZR*STR-ZI*STI)
ZTAI = TTH*(ZR*STI+ZI*STR)
AA = ZTAR
AA = -DABS(AA)
EAA = DEXP(AA)
BIR = BIR*EAA
BII = BII*EAA
RETURN
50 CONTINUE
BIR = S2R*C2
BII = S2I*C2
IF (AZ.LE.TOL) GO TO 60
CC = C1/(1.0D0+FID)
STR = S1R*ZR - S1I*ZI
STI = S1R*ZI + S1I*ZR
BIR = BIR + CC*(STR*ZR-STI*ZI)
BII = BII + CC*(STR*ZI+STI*ZR)
60 CONTINUE
IF (KODE.EQ.1) RETURN
CALL AZSQRT(ZR, ZI, STR, STI)
ZTAR = TTH*(ZR*STR-ZI*STI)
ZTAI = TTH*(ZR*STI+ZI*STR)
AA = ZTAR
AA = -DABS(AA)
EAA = DEXP(AA)
BIR = BIR*EAA
BII = BII*EAA
RETURN
C-----------------------------------------------------------------------
C CASE FOR CABS(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.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-----------------------------------------------------------------------
K1 = I1MACH(15)
K2 = I1MACH(16)
R1M5 = D1MACH(5)
K = MIN0(IABS(K1),IABS(K2))
ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0)
K1 = I1MACH(14) - 1
AA = R1M5*DBLE(FLOAT(K1))
DIG = DMIN1(AA,18.0D0)
AA = AA*2.303D0
ALIM = ELIM + DMAX1(-AA,-41.45D0)
RL = 1.2D0*DIG + 3.0D0
FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0)
C-----------------------------------------------------------------------
C TEST FOR RANGE
C-----------------------------------------------------------------------
AA=0.5D0/TOL
BB=DBLE(FLOAT(I1MACH(9)))*0.5D0
AA=DMIN1(AA,BB)
AA=AA**TTH
IF (AZ.GT.AA) GO TO 260
AA=DSQRT(AA)
IF (AZ.GT.AA) IERR=3
CALL AZSQRT(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-----------------------------------------------------------------------
SFAC = 1.0D0
AK = ZTAI
IF (ZR.GE.0.0D0) GO TO 80
BK = ZTAR
CK = -DABS(BK)
ZTAR = CK
ZTAI = AK
80 CONTINUE
IF (ZI.NE.0.0D0 .OR. ZR.GT.0.0D0) GO TO 90
ZTAR = 0.0D0
ZTAI = AK
90 CONTINUE
AA = ZTAR
IF (KODE.EQ.2) GO TO 100
C-----------------------------------------------------------------------
C OVERFLOW TEST
C-----------------------------------------------------------------------
BB = DABS(AA)
IF (BB.LT.ALIM) GO TO 100
BB = BB + 0.25D0*DLOG(AZ)
SFAC = TOL
IF (BB.GT.ELIM) GO TO 190
100 CONTINUE
FMR = 0.0D0
IF (AA.GE.0.0D0 .AND. ZR.GT.0.0D0) GO TO 110
FMR = PI
IF (ZI.LT.0.0D0) FMR = -PI
ZTAR = -ZTAR
ZTAI = -ZTAI
110 CONTINUE
C-----------------------------------------------------------------------
C AA=FACTOR FOR ANALYTIC CONTINUATION OF I(FNU,ZTA)
C KODE=2 RETURNS EXP(-ABS(XZTA))*I(FNU,ZTA) FROM CBESI
C-----------------------------------------------------------------------
CALL ZBINU(ZTAR, ZTAI, FNU, KODE, 1, CYR, CYI, NZ, RL, FNUL, TOL,
* ELIM, ALIM)
IF (NZ.LT.0) GO TO 200
AA = FMR*FNU
Z3R = SFAC
STR = DCOS(AA)
STI = DSIN(AA)
S1R = (STR*CYR(1)-STI*CYI(1))*Z3R
S1I = (STR*CYI(1)+STI*CYR(1))*Z3R
FNU = (2.0D0-FID)/3.0D0
CALL ZBINU(ZTAR, ZTAI, FNU, KODE, 2, CYR, CYI, NZ, RL, FNUL, TOL,
* ELIM, ALIM)
CYR(1) = CYR(1)*Z3R
CYI(1) = CYI(1)*Z3R
CYR(2) = CYR(2)*Z3R
CYI(2) = CYI(2)*Z3R
C-----------------------------------------------------------------------
C BACKWARD RECUR ONE STEP FOR ORDERS -1/3 OR -2/3
C-----------------------------------------------------------------------
CALL ZDIV(CYR(1), CYI(1), ZTAR, ZTAI, STR, STI)
S2R = (FNU+FNU)*STR + CYR(2)
S2I = (FNU+FNU)*STI + CYI(2)
AA = FMR*(FNU-1.0D0)
STR = DCOS(AA)
STI = DSIN(AA)
S1R = COEF*(S1R+S2R*STR-S2I*STI)
S1I = COEF*(S1I+S2R*STI+S2I*STR)
IF (ID.EQ.1) GO TO 120
STR = CSQR*S1R - CSQI*S1I
S1I = CSQR*S1I + CSQI*S1R
S1R = STR
BIR = S1R/SFAC
BII = S1I/SFAC
RETURN
120 CONTINUE
STR = ZR*S1R - ZI*S1I
S1I = ZR*S1I + ZI*S1R
S1R = STR
BIR = S1R/SFAC
BII = S1I/SFAC
RETURN
130 CONTINUE
AA = C1*(1.0D0-FID) + FID*C2
BIR = AA
BII = 0.0D0
RETURN
190 CONTINUE
IERR=2
NZ=0
RETURN
200 CONTINUE
IF(NZ.EQ.(-1)) GO TO 190
NZ=0
IERR=5
RETURN
260 CONTINUE
IERR=4
NZ=0
RETURN
END

568
amos/zbknu.f
View File

@ -1,568 +0,0 @@
SUBROUTINE ZBKNU(ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL, ELIM,
* ALIM)
C***BEGIN PROLOGUE ZBKNU
C***REFER TO ZBESI,ZBESK,ZAIRY,ZBESH
C
C ZBKNU COMPUTES THE K BESSEL FUNCTION IN THE RIGHT HALF Z PLANE.
C
C***ROUTINES CALLED DGAMLN,I1MACH,D1MACH,ZKSCL,ZSHCH,ZUCHK,AZABS,ZDIV,
C AZEXP,AZLOG,ZMLT,AZSQRT
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, AZABS, 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)
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
CAZ = AZABS(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 = INT(SNGL(FNU+0.5D0))
DNU = FNU - DBLE(FLOAT(INU))
IF (DABS(DNU).EQ.0.5D0) GO TO 110
DNU2 = 0.0D0
IF (DABS(DNU).GT.TOL) DNU2 = DNU*DNU
IF (CAZ.GT.R1) GO TO 110
C-----------------------------------------------------------------------
C SERIES FOR CABS(Z).LE.R1
C-----------------------------------------------------------------------
FC = 1.0D0
CALL AZLOG(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/DSIN(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 = DEXP(-DGAMLN(A2,IDUM))
T1 = 1.0D0/(T2*FC)
IF (DABS(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 (DABS(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 AZEXP(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 AZEXP(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*DABS(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 AZEXP(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 AZSQRT(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 = DEXP(-ZR)*CSSR(KFLAG)
STI = -STR*DSIN(ZI)
STR = STR*DCOS(ZI)
CALL ZMLT(COEFR, COEFI, STR, STI, COEFR, COEFI)
120 CONTINUE
IF (DABS(DNU).EQ.0.5D0) GO TO 300
C-----------------------------------------------------------------------
C MILLER ALGORITHM FOR CABS(Z).GT.R1
C-----------------------------------------------------------------------
AK = DCOS(DPI*DNU)
AK = DABS(AK)
IF (AK.EQ.CZEROR) GO TO 300
FHS = DABS(0.25D0-DNU2)
IF (FHS.EQ.CZEROR) GO TO 300
C-----------------------------------------------------------------------
C COMPUTE R2=F(E). IF CABS(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 = DBLE(FLOAT(I1MACH(14)-1))
T1 = T1*D1MACH(5)*3.321928094D0
T1 = DMAX1(T1,12.0D0)
T1 = DMIN1(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 = DABS(T1)
140 CONTINUE
IF (T2.GT.CAZ) GO TO 170
C-----------------------------------------------------------------------
C FORWARD RECURRENCE LOOP WHEN CABS(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 = DABS(P2R)*FK
IF (ETEST.LT.STR) GO TO 160
150 CONTINUE
GO TO 310
160 CONTINUE
FK = FK + SPI*T1*DSQRT(T2/CAZ)
FHS = DABS(0.25D0-DNU2)
GO TO 180
170 CONTINUE
C-----------------------------------------------------------------------
C COMPUTE BACKWARD INDEX K FOR CABS(Z).LT.R2
C-----------------------------------------------------------------------
A2 = DSQRT(CAZ)
AK = FPI*AK/(TOL*DSQRT(A2))
AA = 3.0D0*T1/(1.0D0+CAZ)
BB = 14.7D0*T1/(28.0D0+CAZ)
AK = (DLOG(AK)+CAZ*DCOS(AA)/(1.0D0+0.008D0*CAZ))/DCOS(BB)
FK = 0.12125D0*AK*AK/CAZ + 1.5D0
180 CONTINUE
C-----------------------------------------------------------------------
C BACKWARD RECURRENCE LOOP FOR MILLER ALGORITHM
C-----------------------------------------------------------------------
K = INT(SNGL(FK))
FK = DBLE(FLOAT(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/CABS(CS))*(CONJG(CS)/CABS(CS)) FOR BETTER
C SCALING
C-----------------------------------------------------------------------
TM = AZABS(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/CABS(P2)*CONJG(P2)/CABS(P2) FOR SCALING
C-----------------------------------------------------------------------
TM = AZABS(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 = DABS(P2R)
STI = DABS(P2I)
P2M = DMAX1(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 = DABS(P2R)
STI = DABS(P2I)
P2M = DMAX1(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 = DEXP(-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 = AZABS(S2R,S2I)
ALAS = DLOG(AS)
P2R = -ZDR+ALAS
IF(P2R.LT.(-ELIM)) GO TO 263
CALL AZLOG(S2R,S2I,STR,STI,IDUM)
P2R = -ZDR+STR
P2I = -ZDI+STI
P2M = DEXP(P2R)/TOL
P1R = P2M*DCOS(P2I)
P1I = P2M*DSIN(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 + DBLE(FLOAT(KK-1))
CKR = T2*RZR
CKI = T2*RZI
KFLAG = 1
GO TO 250
290 CONTINUE
C-----------------------------------------------------------------------
C SCALE BY DEXP(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

174
amos/zbuni.f
View File

@ -1,174 +0,0 @@
SUBROUTINE ZBUNI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, NUI, NLAST,
* FNUL, TOL, ELIM, ALIM)
C***BEGIN PROLOGUE ZBUNI
C***REFER TO ZBESI,ZBESK
C
C ZBUNI COMPUTES THE I BESSEL FUNCTION FOR LARGE CABS(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***ROUTINES CALLED ZUNI1,ZUNI2,AZABS,D1MACH
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, AZABS, 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)
NZ = 0
AX = DABS(ZR)*1.7321D0
AY = DABS(ZI)
IFORM = 1
IF (AY.GT.AX) IFORM = 2
IF (NUI.EQ.0) GO TO 60
FNUI = DBLE(FLOAT(NUI))
DFNU = FNU + DBLE(FLOAT(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 = AZABS(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/AZABS(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 = DABS(STR)
C1I = DABS(STI)
C1M = DMAX1(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 = DBLE(FLOAT(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 = DABS(STR)
C1I = DABS(STI)
C1M = DMAX1(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

35
amos/zbunk.f
View File

@ -1,35 +0,0 @@
SUBROUTINE ZBUNK(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM,
* ALIM)
C***BEGIN PROLOGUE ZBUNK
C***REFER TO ZBESK,ZBESH
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***ROUTINES CALLED ZUNK1,ZUNK2
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)
NZ = 0
AX = DABS(ZR)*1.7321D0
AY = DABS(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

19
amos/zdiv.f
View File

@ -1,19 +0,0 @@
SUBROUTINE ZDIV(AR, AI, BR, BI, CR, CI)
C***BEGIN PROLOGUE ZDIV
C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY
C
C DOUBLE PRECISION COMPLEX DIVIDE C=A/B.
C
C***ROUTINES CALLED AZABS
C***END PROLOGUE ZDIV
DOUBLE PRECISION AR, AI, BR, BI, CR, CI, BM, CA, CB, CC, CD
DOUBLE PRECISION AZABS
BM = 1.0D0/AZABS(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

16
amos/zexp.f
View File

@ -1,16 +0,0 @@
SUBROUTINE AZEXP(AR, AI, BR, BI)
C***BEGIN PROLOGUE AZEXP
C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY
C
C DOUBLE PRECISION COMPLEX EXPONENTIAL FUNCTION B=EXP(A)
C
C***ROUTINES CALLED (NONE)
C***END PROLOGUE AZEXP
DOUBLE PRECISION AR, AI, BR, BI, ZM, CA, CB
ZM = DEXP(AR)
CA = ZM*DCOS(AI)
CB = ZM*DSIN(AI)
BR = CA
BI = CB
RETURN
END

121
amos/zkscl.f
View File

@ -1,121 +0,0 @@
SUBROUTINE ZKSCL(ZRR,ZRI,FNU,N,YR,YI,NZ,RZR,RZI,ASCLE,TOL,ELIM)
C***BEGIN PROLOGUE ZKSCL
C***REFER TO ZBESK
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***ROUTINES CALLED ZUCHK,AZABS,AZLOG
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, AZABS,
* ZDR, ZDI, CELMR, ELM, HELIM, ALAS
INTEGER I, IC, IDUM, KK, N, NN, NW, NZ
DIMENSION YR(N), YI(N), CYR(2), CYI(2)
DATA ZEROR,ZEROI / 0.0D0 , 0.0D0 /
C
NZ = 0
IC = 0
NN = MIN0(2,N)
DO 10 I=1,NN
S1R = YR(I)
S1I = YI(I)
CYR(I) = S1R
CYI(I) = S1I
AS = AZABS(S1R,S1I)
ACS = -ZRR + DLOG(AS)
NZ = NZ + 1
YR(I) = ZEROR
YI(I) = ZEROI
IF (ACS.LT.(-ELIM)) GO TO 10
CALL AZLOG(S1R, S1I, CSR, CSI, IDUM)
CSR = CSR - ZRR
CSI = CSI - ZRI
STR = DEXP(CSR)/TOL
CSR = STR*DCOS(CSI)
CSI = STR*DSIN(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 = DEXP(-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 = AZABS(S2R,S2I)
ALAS = DLOG(AS)
ACS = -ZDR + ALAS
NZ = NZ + 1
YR(I) = ZEROR
YI(I) = ZEROI
IF (ACS.LT.(-ELIM)) GO TO 25
CALL AZLOG(S2R, S2I, CSR, CSI, IDUM)
CSR = CSR - ZDR
CSI = CSI - ZDI
STR = DEXP(CSR)/TOL
CSR = STR*DCOS(CSI)
CSI = STR*DSIN(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

41
amos/zlog.f
View File

@ -1,41 +0,0 @@
SUBROUTINE AZLOG(AR, AI, BR, BI, IERR)
C***BEGIN PROLOGUE AZLOG
C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY
C
C DOUBLE PRECISION COMPLEX LOGARITHM B=CLOG(A)
C IERR=0,NORMAL RETURN IERR=1, Z=CMPLX(0.0,0.0)
C***ROUTINES CALLED AZABS
C***END PROLOGUE AZLOG
DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DHPI
DOUBLE PRECISION AZABS
DATA DPI , DHPI / 3.141592653589793238462643383D+0,
1 1.570796326794896619231321696D+0/
C
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 = DLOG(DABS(AI))
IF (AI.LT.0.0D+0) BI = -BI
RETURN
20 IF (AR.GT.0.0D+0) GO TO 30
BR = DLOG(DABS(AR))
BI = DPI
RETURN
30 BR = DLOG(AR)
BI = 0.0D+0
RETURN
40 IF (AR.LT.0.0D+0) DTHETA = DTHETA + DPI
50 ZM = AZABS(AR,AI)
BR = DLOG(ZM)
BI = DTHETA
RETURN
60 CONTINUE
IERR=1
RETURN
END

204
amos/zmlri.f
View File

@ -1,204 +0,0 @@
SUBROUTINE ZMLRI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL)
C***BEGIN PROLOGUE ZMLRI
C***REFER TO ZBESI,ZBESK
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***ROUTINES CALLED DGAMLN,D1MACH,AZABS,AZEXP,AZLOG,ZMLT
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, AZABS
INTEGER I, IAZ, IDUM, IFNU, INU, ITIME, K, KK, KM, KODE, M, N, NZ
DIMENSION YR(N), YI(N)
DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 /
SCLE = D1MACH(1)/TOL
NZ=0
AZ = AZABS(ZR,ZI)
IAZ = INT(SNGL(AZ))
IFNU = INT(SNGL(FNU))
INU = IFNU + N - 1
AT = DBLE(FLOAT(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 + DSQRT(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 = AZABS(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 = DBLE(FLOAT(INU)) + 1.0D0
STR = ZR*RAZ
STI = -ZI*RAZ
CKR = STR*AT*RAZ
CKI = STI*AT*RAZ
ACK = AT*RAZ
TST = DSQRT(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 = AZABS(P2R,P2I)
IF (AP.LT.TST) GO TO 30
IF (ITIME.EQ.2) GO TO 40
ACK = AZABS(CKR,CKI)
FLAM = ACK + DSQRT(ACK*ACK-1.0D0)
FKAP = AP/AZABS(P1R,P1I)
RHO = DMIN1(FLAM,FKAP)
TST = TST*DSQRT(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 = MAX0(I+IAZ,K+INU)
FKK = DBLE(FLOAT(KK))
P1R = ZEROR
P1I = ZEROI
C-----------------------------------------------------------------------
C SCALE P2 AND SUM BY SCLE
C-----------------------------------------------------------------------
P2R = SCLE
P2I = ZEROI
FNF = FNU - DBLE(FLOAT(IFNU))
TFNF = FNF + FNF
BK = DGAMLN(FKK+TFNF+1.0D0,IDUM) - DGAMLN(FKK+1.0D0,IDUM) -
* DGAMLN(TFNF+1.0D0,IDUM)
BK = DEXP(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 AZLOG(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 = AZABS(P2R,P2I)
P1R = 1.0D0/AP
CALL AZEXP(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

15
amos/zmlt.f
View File

@ -1,15 +0,0 @@
SUBROUTINE ZMLT(AR, AI, BR, BI, CR, CI)
C***BEGIN PROLOGUE ZMLT
C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY
C
C DOUBLE PRECISION COMPLEX MULTIPLY, C=A*B.
C
C***ROUTINES CALLED (NONE)
C***END PROLOGUE ZMLT
DOUBLE PRECISION AR, AI, BR, BI, CR, CI, CA, CB
CA = AR*BR - AI*BI
CB = AR*BI + AI*BR
CR = CA
CI = CB
RETURN
END

132
amos/zrati.f
View File

@ -1,132 +0,0 @@
SUBROUTINE ZRATI(ZR, ZI, FNU, N, CYR, CYI, TOL)
C***BEGIN PROLOGUE ZRATI
C***REFER TO ZBESI,ZBESK,ZBESH
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***ROUTINES CALLED AZABS,ZDIV
C***END PROLOGUE ZRATI
C COMPLEX Z,CY(1),CONE,CZERO,P1,P2,T1,RZ,PT,CDFNU
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, AZABS
INTEGER I, ID, IDNU, INU, ITIME, K, KK, MAGZ, N
DIMENSION CYR(N), CYI(N)
DATA CZEROR,CZEROI,CONER,CONEI,RT2/
1 0.0D0, 0.0D0, 1.0D0, 0.0D0, 1.41421356237309505D0 /
AZ = AZABS(ZR,ZI)
INU = INT(SNGL(FNU))
IDNU = INU + N - 1
MAGZ = INT(SNGL(AZ))
AMAGZ = DBLE(FLOAT(MAGZ+1))
FDNU = DBLE(FLOAT(IDNU))
FNUP = DMAX1(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 = AZABS(P2R,P2I)
AP1 = AZABS(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 = DSQRT(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 = AZABS(P2R,P2I)
IF (AP1.LE.TEST) GO TO 10
IF (ITIME.EQ.2) GO TO 20
AK = AZABS(T1R,T1I)*0.5D0
FLAM = AK + DSQRT(AK*AK-1.0D0)
RHO = DMIN1(AP2/AP1,FLAM)
TEST = TEST1*DSQRT(RHO/(RHO*RHO-1.0D0))
ITIME = 2
GO TO 10
20 CONTINUE
KK = K + 1 - ID
AK = DBLE(FLOAT(KK))
T1R = AK
T1I = CZEROI
DFNU = FNU + DBLE(FLOAT(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 = DBLE(FLOAT(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 = AZABS(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

49
amos/zs1s2.f
View File

@ -1,49 +0,0 @@
SUBROUTINE ZS1S2(ZRR, ZRI, S1R, S1I, S2R, S2I, NZ, ASCLE, ALIM,
* IUF)
C***BEGIN PROLOGUE ZS1S2
C***REFER TO ZBESK,ZAIRY
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***ROUTINES CALLED AZABS,AZEXP,AZLOG
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, AZABS
INTEGER IUF, IDUM, NZ
DATA ZEROR,ZEROI / 0.0D0 , 0.0D0 /
NZ = 0
AS1 = AZABS(S1R,S1I)
AS2 = AZABS(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 + DLOG(AS1)
S1DR = S1R
S1DI = S1I
S1R = ZEROR
S1I = ZEROI
AS1 = ZEROR
IF (ALN.LT.(-ALIM)) GO TO 10
CALL AZLOG(S1DR, S1DI, C1R, C1I, IDUM)
C1R = C1R - ZRR - ZRR
C1I = C1I - ZRI - ZRI
CALL AZEXP(C1R, C1I, S1R, S1I)
AS1 = AZABS(S1R,S1I)
IUF = IUF + 1
10 CONTINUE
AA = DMAX1(AS1,AS2)
IF (AA.GT.ASCLE) RETURN
S1R = ZEROR
S1I = ZEROI
S2R = ZEROR
S2I = ZEROI
NZ = 1
IUF = 0
RETURN
END

190
amos/zseri.f
View File

@ -1,190 +0,0 @@
SUBROUTINE ZSERI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL, ELIM,
* ALIM)
C***BEGIN PROLOGUE ZSERI
C***REFER TO ZBESI,ZBESK
C
C ZSERI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY
C MEANS OF THE POWER SERIES FOR LARGE CABS(Z) IN THE
C REGION CABS(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 CABS(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***ROUTINES CALLED DGAMLN,D1MACH,ZUCHK,AZABS,ZDIV,AZLOG,ZMLT
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, AZABS
INTEGER I, IB, IDUM, IFLAG, IL, K, KODE, L, M, N, NN, NZ, NW
DIMENSION YR(N), YI(N), WR(2), WI(2)
DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 /
C
NZ = 0
AZ = AZABS(ZR,ZI)
IF (AZ.EQ.0.0D0) GO TO 160
ARM = 1.0D+3*D1MACH(1)
RTR1 = DSQRT(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 = AZABS(CZR,CZI)
NN = N
CALL AZLOG(HZR, HZI, CKR, CKI, IDUM)
20 CONTINUE
DFNU = FNU + DBLE(FLOAT(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 = DEXP(AK1R)
IF (IFLAG.EQ.1) AA = AA*SS
COEFR = AA*DCOS(AK1I)
COEFI = AA*DSIN(AK1I)
ATOL = TOL*ACZ/FNUP
IL = MIN0(2,NN)
DO 90 I=1,IL
DFNU = FNU + DBLE(FLOAT(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 = DBLE(FLOAT(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 (AZABS(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 CABS(Z*Z/4).GT.FNU+N-NZ-1 COMPLETE
C THE CALCULATION IN CBINU WITH N=N-IABS(NZ)
C-----------------------------------------------------------------------
190 CONTINUE
NZ = -NZ
RETURN
END

22
amos/zshch.f
View File

@ -1,22 +0,0 @@
SUBROUTINE ZSHCH(ZR, ZI, CSHR, CSHI, CCHR, CCHI)
C***BEGIN PROLOGUE ZSHCH
C***REFER TO ZBESK,ZBESH
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***ROUTINES CALLED (NONE)
C***END PROLOGUE ZSHCH
C
DOUBLE PRECISION CCHI, CCHR, CH, CN, CSHI, CSHR, SH, SN, ZI, ZR,
* DCOSH, DSINH
SH = DSINH(ZR)
CH = DCOSH(ZR)
SN = DSIN(ZI)
CN = DCOS(ZI)
CSHR = SH*CN
CSHI = CH*SN
CCHR = CH*CN
CCHI = SH*SN
RETURN
END

44
amos/zsqrt.f
View File

@ -1,44 +0,0 @@
SUBROUTINE AZSQRT(AR, AI, BR, BI)
C***BEGIN PROLOGUE AZSQRT
C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY
C
C DOUBLE PRECISION COMPLEX SQUARE ROOT, B=CSQRT(A)
C
C***ROUTINES CALLED AZABS
C***END PROLOGUE AZSQRT
DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DRT
DOUBLE PRECISION AZABS
DATA DRT , DPI / 7.071067811865475244008443621D-1,
1 3.141592653589793238462643383D+0/
ZM = AZABS(AR,AI)
ZM = DSQRT(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 = DSQRT(DABS(AR))
RETURN
30 BR = DSQRT(AR)
BI = 0.0D+0
RETURN
40 IF (AR.LT.0.0D+0) DTHETA = DTHETA + DPI
50 DTHETA = DTHETA*0.5D+0
BR = ZM*DCOS(DTHETA)
BI = ZM*DSIN(DTHETA)
RETURN
60 BR = ZM*DRT
BI = ZM*DRT
RETURN
70 BR = ZM*DRT
BI = -ZM*DRT
RETURN
END

28
amos/zuchk.f
View File

@ -1,28 +0,0 @@
SUBROUTINE ZUCHK(YR, YI, NZ, ASCLE, TOL)
C***BEGIN PROLOGUE ZUCHK
C***REFER TO ZSERI,ZUOIK,ZUNK1,ZUNK2,ZUNI1,ZUNI2,ZKSCL
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***ROUTINES CALLED (NONE)
C***END PROLOGUE ZUCHK
C
C COMPLEX Y
DOUBLE PRECISION ASCLE, SS, ST, TOL, WR, WI, YR, YI
INTEGER NZ
NZ = 0
WR = DABS(YR)
WI = DABS(YI)
ST = DMIN1(WR,WI)
IF (ST.GT.ASCLE) RETURN
SS = DMAX1(WR,WI)
ST = ST/TOL
IF (SS.LT.ST) NZ = 1
RETURN
END

714
amos/zunhj.f
View File

@ -1,714 +0,0 @@
SUBROUTINE ZUNHJ(ZR, ZI, FNU, IPMTR, TOL, PHIR, PHII, ARGR, ARGI,
* ZETA1R, ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI)
C***BEGIN PROLOGUE ZUNHJ
C***REFER TO ZBESI,ZBESK
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***ROUTINES CALLED AZABS,ZDIV,AZLOG,AZSQRT,D1MACH
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, AZABS, 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)
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
RFNU = 1.0D0/FNU
C-----------------------------------------------------------------------
C OVERFLOW TEST (Z/FNU TOO SMALL)
C-----------------------------------------------------------------------
TEST = D1MACH(1)*1.0D+3
AC = FNU*TEST
IF (DABS(ZR).GT.AC .OR. DABS(ZI).GT.AC) GO TO 15
ZETA1R = 2.0D0*DABS(DLOG(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 = AZABS(W2R,W2I)
IF (AW2.GT.0.25D0) GO TO 130
C-----------------------------------------------------------------------
C POWER SERIES FOR CABS(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 AZSQRT(SUMAR, SUMAI, ZAR, ZAI)
CALL AZSQRT(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 AZSQRT(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*(DABS(BSUMR)+DABS(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 CABS(W2).GT.0.25D0
C-----------------------------------------------------------------------
130 CONTINUE
CALL AZSQRT(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 AZLOG(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 = AZABS(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*DCOS(ANG)
ZETAI = PP*DSIN(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 AZSQRT(TZAR, TZAI, STR, STI)
PHIR = STR*RFN13
PHII = STI*RFN13
IF (IPMTR.EQ.1) GO TO 120
RAW = 1.0D0/DSQRT(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*(DABS(BSUMR)+DABS(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 = DABS(SUMAR) + DABS(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 = DABS(SUMBR) + DABS(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

204
amos/zuni1.f
View File

@ -1,204 +0,0 @@
SUBROUTINE ZUNI1(ZR, ZI, FNU, KODE, N, YR, YI, NZ, NLAST, FNUL,
* TOL, ELIM, ALIM)
C***BEGIN PROLOGUE ZUNI1
C***REFER TO ZBESI,ZBESK
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***ROUTINES CALLED ZUCHK,ZUNIK,ZUOIK,D1MACH,AZABS
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, AZABS
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)
DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 /
C
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 = DMAX1(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/AZABS(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 (DABS(RS1).GT.ELIM) GO TO 130
30 CONTINUE
NN = MIN0(2,ND)
DO 80 I=1,NN
FN = FNU + DBLE(FLOAT(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/AZABS(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 (DABS(RS1).GT.ELIM) GO TO 110
IF (I.EQ.1) IFLAG = 2
IF (DABS(RS1).LT.ALIM) GO TO 60
C-----------------------------------------------------------------------
C REFINE TEST AND SCALE
C-----------------------------------------------------------------------
APHI = AZABS(PHIR,PHII)
RS1 = RS1 + DLOG(APHI)
IF (DABS(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 CABS(S1).LT.ASCLE
C-----------------------------------------------------------------------
S2R = PHIR*SUMR - PHII*SUMI
S2I = PHIR*SUMI + PHII*SUMR
STR = DEXP(S1R)*CSSR(IFLAG)
S1R = STR*DCOS(S1I)
S1I = STR*DSIN(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/AZABS(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 = DBLE(FLOAT(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 = DABS(C2R)
STI = DABS(C2I)
C2M = DMAX1(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 + DBLE(FLOAT(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

267
amos/zuni2.f
View File

@ -1,267 +0,0 @@
SUBROUTINE ZUNI2(ZR, ZI, FNU, KODE, N, YR, YI, NZ, NLAST, FNUL,
* TOL, ELIM, ALIM)
C***BEGIN PROLOGUE ZUNI2
C***REFER TO ZBESI,ZBESK
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***ROUTINES CALLED ZAIRY,ZUCHK,ZUNHJ,ZUOIK,D1MACH,AZABS
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, AZABS, 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)
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
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 = INT(SNGL(FNU))
ANG = HPI*(FNU-DBLE(FLOAT(INU)))
C2R = DCOS(ANG)
C2I = DSIN(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 = DMAX1(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/AZABS(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 (DABS(RS1).GT.ELIM) GO TO 150
40 CONTINUE
NN = MIN0(2,ND)
DO 90 I=1,NN
FN = FNU + DBLE(FLOAT(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/AZABS(STR,STI)
STR = STR*RAST*RAST
STI = -STI*RAST*RAST
S1R = -ZETA1R + STR
S1I = -ZETA1I + STI + DABS(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 (DABS(RS1).GT.ELIM) GO TO 120
IF (I.EQ.1) IFLAG = 2
IF (DABS(RS1).LT.ALIM) GO TO 70
C-----------------------------------------------------------------------
C REFINE TEST AND SCALE
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
APHI = AZABS(PHIR,PHII)
AARG = AZABS(ARGR,ARGI)
RS1 = RS1 + DLOG(APHI) - 0.25D0*DLOG(AARG) - AIC
IF (DABS(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 = DEXP(S1R)*CSSR(IFLAG)
S1R = STR*DCOS(S1I)
S1I = STR*DSIN(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/AZABS(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 = DBLE(FLOAT(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 = DABS(C2R)
STI = DABS(C2I)
C2M = DMAX1(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 + DBLE(FLOAT(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

211
amos/zunik.f
View File

@ -1,211 +0,0 @@
SUBROUTINE ZUNIK(ZRR, ZRI, FNU, IKFLG, IPMTR, TOL, INIT, PHIR,
* PHII, ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI)
C***BEGIN PROLOGUE ZUNIK
C***REFER TO ZBESI,ZBESK
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***ROUTINES CALLED ZDIV,AZLOG,AZSQRT,D1MACH
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)
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
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 (DABS(ZRR).GT.AC .OR. DABS(ZRI).GT.AC) GO TO 15
ZETA1R = 2.0D0*DABS(DLOG(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 AZSQRT(SR, SI, SRR, SRI)
STR = CONER + SRR
STI = CONEI + SRI
CALL ZDIV(STR, STI, TR, TI, ZNR, ZNI)
CALL AZLOG(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 AZSQRT(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 = DABS(CWRKR(K)) + DABS(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

426
amos/zunk1.f
View File

@ -1,426 +0,0 @@
SUBROUTINE ZUNK1(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM,
* ALIM)
C***BEGIN PROLOGUE ZUNK1
C***REFER TO ZBESK
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***ROUTINES CALLED ZKSCL,ZS1S2,ZUCHK,ZUNIK,D1MACH,AZABS
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, AZABS
INTEGER I, IB, IFLAG, IFN, IL, INIT, INU, IUF, K, KDFLG, KFLAG,
* KK, KODE, MR, N, NW, NZ, INITD, IC, IPARD, J
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)
DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 /
DATA PI / 3.14159265358979324D0 /
C
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 + DBLE(FLOAT(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/AZABS(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 (DABS(RS1).GT.ELIM) GO TO 60
IF (KDFLG.EQ.1) KFLAG = 2
IF (DABS(RS1).LT.ALIM) GO TO 40
C-----------------------------------------------------------------------
C REFINE TEST AND SCALE
C-----------------------------------------------------------------------
APHI = AZABS(PHIR(J),PHII(J))
RS1 = RS1 + DLOG(APHI)
IF (DABS(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 = DEXP(S1R)*CSSR(KFLAG)
S1R = STR*DCOS(S1I)
S1I = STR*DSIN(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/AZABS(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 + DBLE(FLOAT(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/AZABS(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 (DABS(RS1).GT.ELIM) GO TO 95
IF (DABS(RS1).LT.ALIM) GO TO 100
C----------------------------------------------------------------------------
C REFINE ESTIMATE AND TEST
C-------------------------------------------------------------------------
APHI = AZABS(PHIDR,PHIDI)
RS1 = RS1+DLOG(APHI)
IF (DABS(RS1).LT.ELIM) GO TO 100
95 CONTINUE
IF (DABS(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 = DABS(C2R)
STI = DABS(C2I)
C2M = DMAX1(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 = DBLE(FLOAT(MR))
SGN = -DSIGN(PI,FMR)
C-----------------------------------------------------------------------
C CSPN AND CSGN ARE COEFF OF K AND I FUNCTIONS RESP.
C-----------------------------------------------------------------------
CSGNI = SGN
INU = INT(SNGL(FNU))
FNF = FNU - DBLE(FLOAT(INU))
IFN = INU + N - 1
ANG = FNF*SGN
CSPNR = DCOS(ANG)
CSPNI = DSIN(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 + DBLE(FLOAT(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/AZABS(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 (DABS(RS1).GT.ELIM) GO TO 260
IF (KDFLG.EQ.1) IFLAG = 2
IF (DABS(RS1).LT.ALIM) GO TO 220
C-----------------------------------------------------------------------
C REFINE TEST AND SCALE
C-----------------------------------------------------------------------
APHI = AZABS(PHIDR,PHIDI)
RS1 = RS1 + DLOG(APHI)
IF (DABS(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 = DEXP(S1R)*CSSR(IFLAG)
S1R = STR*DCOS(S1I)
S1I = STR*DSIN(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 = DBLE(FLOAT(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 = DABS(CKR)
C2I = DABS(CKI)
C2M = DMAX1(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

505
amos/zunk2.f
View File

@ -1,505 +0,0 @@
SUBROUTINE ZUNK2(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM,
* ALIM)
C***BEGIN PROLOGUE ZUNK2
C***REFER TO ZBESK
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***ROUTINES CALLED ZAIRY,ZKSCL,ZS1S2,ZUCHK,ZUNHJ,D1MACH,AZABS
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, AZABS
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)
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
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 = INT(SNGL(FNU))
FNF = FNU - DBLE(FLOAT(INU))
ANG = -HPI*FNF
CAR = DCOS(ANG)
SAR = DSIN(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 + DBLE(FLOAT(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/AZABS(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 (DABS(RS1).GT.ELIM) GO TO 70
IF (KDFLG.EQ.1) KFLAG = 2
IF (DABS(RS1).LT.ALIM) GO TO 50
C-----------------------------------------------------------------------
C REFINE TEST AND SCALE
C-----------------------------------------------------------------------
APHI = AZABS(PHIR(J),PHII(J))
AARG = AZABS(ARGR(J),ARGI(J))
RS1 = RS1 + DLOG(APHI) - 0.25D0*DLOG(AARG) - AIC
IF (DABS(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 = DEXP(S1R)*CSSR(KFLAG)
S1R = STR*DCOS(S1I)
S1I = STR*DSIN(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/AZABS(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 + DBLE(FLOAT(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/AZABS(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 (DABS(RS1).GT.ELIM) GO TO 105
IF (DABS(RS1).LT.ALIM) GO TO 120
C----------------------------------------------------------------------------
C REFINE ESTIMATE AND TEST
C-------------------------------------------------------------------------
APHI = AZABS(PHIDR,PHIDI)
RS1 = RS1+DLOG(APHI)
IF (DABS(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 = DABS(C2R)
STI = DABS(C2I)
C2M = DMAX1(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 = DBLE(FLOAT(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 = DCOS(ANG)
CSPNI = DSIN(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 + DBLE(FLOAT(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/AZABS(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 (DABS(RS1).GT.ELIM) GO TO 280
IF (KDFLG.EQ.1) IFLAG = 2
IF (DABS(RS1).LT.ALIM) GO TO 240
C-----------------------------------------------------------------------
C REFINE TEST AND SCALE
C-----------------------------------------------------------------------
APHI = AZABS(PHIDR,PHIDI)
AARG = AZABS(ARGDR,ARGDI)
RS1 = RS1 + DLOG(APHI) - 0.25D0*DLOG(AARG) - AIC
IF (DABS(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 = DEXP(S1R)*CSSR(IFLAG)
S1R = STR*DCOS(S1I)
S1I = STR*DSIN(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 = DBLE(FLOAT(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 = DABS(CKR)
C2I = DABS(CKI)
C2M = DMAX1(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

194
amos/zuoik.f
View File

@ -1,194 +0,0 @@
SUBROUTINE ZUOIK(ZR, ZI, FNU, KODE, IKFLG, N, YR, YI, NUF, TOL,
* ELIM, ALIM)
C***BEGIN PROLOGUE ZUOIK
C***REFER TO ZBESI,ZBESK,ZBESH
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***ROUTINES CALLED ZUCHK,ZUNHJ,ZUNIK,D1MACH,AZABS,AZLOG
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, AZABS
INTEGER I, IDUM, IFORM, IKFLG, INIT, KODE, N, NN, NUF, NW
DIMENSION YR(N), YI(N), CWRKR(16), CWRKI(16)
DATA ZEROR,ZEROI / 0.0D0, 0.0D0 /
DATA AIC / 1.265512123484645396D+00 /
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 = DABS(ZR)*1.7321D0
AY = DABS(ZI)
IFORM = 1
IF (AY.GT.AX) IFORM = 2
GNU = DMAX1(FNU,1.0D0)
IF (IKFLG.EQ.1) GO TO 20
FNN = DBLE(FLOAT(NN))
GNN = FNU + FNN - 1.0D0
GNU = DMAX1(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 = AZABS(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 = AZABS(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 + DLOG(APHI)
IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*DLOG(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 + DLOG(APHI)
IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*DLOG(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 AZLOG(PHIR, PHII, STR, STI, IDUM)
CZR = CZR + STR
CZI = CZI + STI
IF (IFORM.EQ.1) GO TO 120
CALL AZLOG(ARGR, ARGI, STR, STI, IDUM)
CZR = CZR - 0.25D0*STR - AIC
CZI = CZI - 0.25D0*STI
120 CONTINUE
AX = DEXP(RCZ)/TOL
AY = CZI
CZR = AX*DCOS(AY)
CZI = AX*DSIN(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 + DBLE(FLOAT(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 = AZABS(ARGR,ARGI)
160 CONTINUE
IF (KODE.EQ.1) GO TO 170
CZR = CZR - ZBR
CZI = CZI - ZBI
170 CONTINUE
APHI = AZABS(PHIR,PHII)
RCZ = CZR
IF (RCZ.LT.(-ELIM)) GO TO 180
IF (RCZ.GT.(-ALIM)) RETURN
RCZ = RCZ + DLOG(APHI)
IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*DLOG(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 AZLOG(PHIR, PHII, STR, STI, IDUM)
CZR = CZR + STR
CZI = CZI + STI
IF (IFORM.EQ.1) GO TO 200
CALL AZLOG(ARGR, ARGI, STR, STI, IDUM)
CZR = CZR - 0.25D0*STR - AIC
CZI = CZI - 0.25D0*STI
200 CONTINUE
AX = DEXP(RCZ)/TOL
AY = CZI
CZR = AX*DCOS(AY)
CZI = AX*DSIN(AY)
CALL ZUCHK(CZR, CZI, NW, ASCLE, TOL)
IF (NW.NE.0) GO TO 180
RETURN
210 CONTINUE
NUF = -1
RETURN
END

94
amos/zwrsk.f
View File

@ -1,94 +0,0 @@
SUBROUTINE ZWRSK(ZRR, ZRI, FNU, KODE, N, YR, YI, NZ, CWR, CWI,
* TOL, ELIM, ALIM)
C***BEGIN PROLOGUE ZWRSK
C***REFER TO ZBESI,ZBESK
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***ROUTINES CALLED D1MACH,ZBKNU,ZRATI,AZABS
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, AZABS, D1MACH
INTEGER I, KODE, N, NW, NZ
DIMENSION YR(N), YI(N), CWR(2), CWI(2)
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-----------------------------------------------------------------------
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 = DCOS(ZRI)
CINUI = DSIN(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 = AZABS(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)/CABS(CT))*(1.0D0/CABS(CT) PREVENTS
C UNDER- OR OVERFLOW PREMATURELY BY SQUARING CABS(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 = AZABS(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

1
camos

@ -1 +0,0 @@
Subproject commit 19e7ae82e7e0b436bd273557a87d288f8f338221

7
ci/00_make_dockerfiles.sh
View File

@ -1,7 +0,0 @@
#!/bin/sh
DP=Dockerfile_parts
# "Build environment" Dockerfiles
cat >Dockerfile.benv.debian.bnl ${DP}/00_common.debian ${DP}/01_numlibs.built
cat >Dockerfile.benv.debian.pnl ${DP}/00_common.debian ${DP}/01_numlibs.debian.pkgd
cat >Dockerfile.benv.alpine.bnl ${DP}/00_common.alpine ${DP}/01_numlibs.built
cat >Dockerfile.benv.alpine.pnl ${DP}/00_common.alpine ${DP}/01_numlibs.alpine.pkgd

5
ci/01_make_buildenv_images.sh
View File

@ -1,5 +0,0 @@
#!/bin/sh
docker build -t qpms/buildenv/debian/builtnumlib -f Dockerfile.benv.debian.bnl .
docker build -t qpms/buildenv/debian/pkgdnumlib -f Dockerfile.benv.debian.pnl .
docker build -t qpms/buildenv/alpine/builtnumlib -f Dockerfile.benv.alpine.bnl .
docker build -t qpms/buildenv/alpine/pkgdnumlib -f Dockerfile.benv.alpine.pnl .

5
ci/Dockerfile_parts/00_common.alpine
View File

@ -1,5 +0,0 @@
FROM alpine:latest AS commondeps
RUN apk update \
&& apk add cmake python3-dev py3-pip gcc g++ wget git make libc-dev bc \
&& adduser -D qpmsbuild

6
ci/Dockerfile_parts/00_common.debian
View File

@ -1,6 +0,0 @@
FROM debian:stable AS commondeps
RUN apt-get update \
&& apt-get -y install --no-install-recommends build-essential cmake python3 python3-pip git wget python3-dev bc \
&& apt-get clean \
&& useradd -m qpmsbuild

3
ci/Dockerfile_parts/01_numlibs.alpine.pkgd
View File

@ -1,3 +0,0 @@
FROM commondeps AS numlibs
# openblas-dev adds gfortran :(
RUN apk add openblas-dev gsl-dev

16
ci/Dockerfile_parts/01_numlibs.built
View File

@ -1,16 +0,0 @@
FROM commondeps AS buildopenblas
USER qpmsbuild
RUN cd && git clone --depth 1 https://github.com/xianyi/OpenBLAS.git \
&& cd OpenBLAS && make \
&& make install PREFIX=$HOME/.local/ \
&& make clean \
&& cd .. && rm -rf OpenBLAS
FROM buildopenblas AS numlibs
USER qpmsbuild
RUN cd && wget https://ftp.gnu.org/gnu/gsl/gsl-latest.tar.gz \
&& tar xf gsl-latest.tar.gz \
&& cd $( tar tf gsl-latest.tar.gz | head -n 1 ) \
&& ./configure --prefix=$HOME/.local \
&& make && make install && make clean \
&& cd .. && rm -rf $OLDPWD gsl-latest.tar.gz

4
ci/Dockerfile_parts/01_numlibs.debian.pkgd
View File

@ -1,4 +0,0 @@
FROM commondeps AS numlibs
RUN apt-get -y install --no-install-recommends libopenblas-dev libgsl-dev liblapacke-dev \
&& apt-get clean

12
ci/Dockerfile_parts/02_buildqpms
View File

@ -1,12 +0,0 @@
FROM numlibs AS buildqpms
USER qpmsbuild
ENV LD_LIBRARY_PATH /home/qpmsbuild/.local/lib
ENV LIBRARY_PATH /home/qpmsbuild/.local/lib
ENV C_INCLUDE_PATH /home/qpmsbuild/.local/include
RUN cd && git clone --depth 1 https://repo.or.cz/qpms.git \
&& cd qpms && git submodule init && git submodule update
RUN cd ~/qpms && cmake -DCMAKE_INSTALL_PREFIX=$HOME/.local . \
&& make \
&& make install
RUN cd ~/qpms && python3 setup.py install --user

1
ci/drone.yml
View File

@ -1 +0,0 @@
../.drone.yml

17
cmake-scripts/FindZBESSEL.cmake Normal file
View File

@ -0,0 +1,17 @@
# Try to find the ZBESSEL librairies
# ZBESSEL_FOUND - system has ZBESSEL lib
# ZBESSEL_INCLUDE_DIR - the ZBESSEL include directory
# ZBESSEL_LIBRARIES - Libraries needed to use ZBESSEL
if (ZBESSEL_INCLUDE_DIR AND ZBESSEL_LIBRARIES)
# Already in cache, be silent
set(ZBESSEL_FIND_QUIETLY TRUE)
endif (ZBESSEL_INCLUDE_DIR AND ZBESSEL_LIBRARIES)
find_path(ZBESSEL_INCLUDE_DIR NAMES zbessel.h )
find_library(ZBESSEL_LIBRARIES NAMES zbessel libzbessel)
include(FindPackageHandleStandardArgs)
FIND_PACKAGE_HANDLE_STANDARD_ARGS(ZBESSEL DEFAULT_MSG ZBESSEL_INCLUDE_DIR ZBESSEL_LIBRARIES)
mark_as_advanced(ZBESSEL_INCLUDE_DIR ZBESSEL_LIBRARIES)

284
cmake/GetGitRevisionDescription.cmake
View File

@ -1,284 +0,0 @@
# - Returns a version string from Git
#
# These functions force a re-configure on each git commit so that you can
# trust the values of the variables in your build system.
#
# get_git_head_revision(<refspecvar> <hashvar> [ALLOW_LOOKING_ABOVE_CMAKE_SOURCE_DIR])
#
# Returns the refspec and sha hash of the current head revision
#
# git_describe(<var> [<additional arguments to git describe> ...])
#
# Returns the results of git describe on the source tree, and adjusting
# the output so that it tests false if an error occurs.
#
# git_describe_working_tree(<var> [<additional arguments to git describe> ...])
#
# Returns the results of git describe on the working tree (--dirty option),
# and adjusting the output so that it tests false if an error occurs.
#
# git_get_exact_tag(<var> [<additional arguments to git describe> ...])
#
# Returns the results of git describe --exact-match on the source tree,
# and adjusting the output so that it tests false if there was no exact
# matching tag.
#
# git_local_changes(<var>)
#
# Returns either "CLEAN" or "DIRTY" with respect to uncommitted changes.
# Uses the return code of "git diff-index --quiet HEAD --".
# Does not regard untracked files.
#
# Requires CMake 2.6 or newer (uses the 'function' command)
#
# Original Author:
# 2009-2020 Ryan Pavlik <ryan.pavlik@gmail.com> <abiryan@ryand.net>
# http://academic.cleardefinition.com
#
# Copyright 2009-2013, Iowa State University.
# Copyright 2013-2020, Ryan Pavlik
# Copyright 2013-2020, Contributors
# SPDX-License-Identifier: BSL-1.0
# Distributed under the Boost Software License, Version 1.0.
# (See accompanying file LICENSE_1_0.txt or copy at
# http://www.boost.org/LICENSE_1_0.txt)
if(__get_git_revision_description)
return()
endif()
set(__get_git_revision_description YES)
# We must run the following at "include" time, not at function call time,
# to find the path to this module rather than the path to a calling list file
get_filename_component(_gitdescmoddir ${CMAKE_CURRENT_LIST_FILE} PATH)
# Function _git_find_closest_git_dir finds the next closest .git directory
# that is part of any directory in the path defined by _start_dir.
# The result is returned in the parent scope variable whose name is passed
# as variable _git_dir_var. If no .git directory can be found, the
# function returns an empty string via _git_dir_var.
#
# Example: Given a path C:/bla/foo/bar and assuming C:/bla/.git exists and
# neither foo nor bar contain a file/directory .git. This wil return
# C:/bla/.git
#
function(_git_find_closest_git_dir _start_dir _git_dir_var)
set(cur_dir "${_start_dir}")
set(git_dir "${_start_dir}/.git")
while(NOT EXISTS "${git_dir}")
# .git dir not found, search parent directories
set(git_previous_parent "${cur_dir}")
get_filename_component(cur_dir "${cur_dir}" DIRECTORY)
if(cur_dir STREQUAL git_previous_parent)
# We have reached the root directory, we are not in git
set(${_git_dir_var}
""
PARENT_SCOPE)
return()
endif()
set(git_dir "${cur_dir}/.git")
endwhile()
set(${_git_dir_var}
"${git_dir}"
PARENT_SCOPE)
endfunction()
function(get_git_head_revision _refspecvar _hashvar)
_git_find_closest_git_dir("${CMAKE_CURRENT_SOURCE_DIR}" GIT_DIR)
if("${ARGN}" STREQUAL "ALLOW_LOOKING_ABOVE_CMAKE_SOURCE_DIR")
set(ALLOW_LOOKING_ABOVE_CMAKE_SOURCE_DIR TRUE)
else()
set(ALLOW_LOOKING_ABOVE_CMAKE_SOURCE_DIR FALSE)
endif()
if(NOT "${GIT_DIR}" STREQUAL "")
file(RELATIVE_PATH _relative_to_source_dir "${CMAKE_SOURCE_DIR}"
"${GIT_DIR}")
if("${_relative_to_source_dir}" MATCHES "[.][.]" AND NOT ALLOW_LOOKING_ABOVE_CMAKE_SOURCE_DIR)
# We've gone above the CMake root dir.
set(GIT_DIR "")
endif()
endif()
if("${GIT_DIR}" STREQUAL "")
set(${_refspecvar}
"GITDIR-NOTFOUND"
PARENT_SCOPE)
set(${_hashvar}
"GITDIR-NOTFOUND"
PARENT_SCOPE)
return()
endif()
# Check if the current source dir is a git submodule or a worktree.
# In both cases .git is a file instead of a directory.
#
if(NOT IS_DIRECTORY ${GIT_DIR})
# The following git command will return a non empty string that
# points to the super project working tree if the current
# source dir is inside a git submodule.
# Otherwise the command will return an empty string.
#
execute_process(
COMMAND "${GIT_EXECUTABLE}" rev-parse
--show-superproject-working-tree
WORKING_DIRECTORY "${CMAKE_CURRENT_SOURCE_DIR}"
OUTPUT_VARIABLE out
ERROR_QUIET OUTPUT_STRIP_TRAILING_WHITESPACE)
if(NOT "${out}" STREQUAL "")
# If out is empty, GIT_DIR/CMAKE_CURRENT_SOURCE_DIR is in a submodule
file(READ ${GIT_DIR} submodule)
string(REGEX REPLACE "gitdir: (.*)$" "\\1" GIT_DIR_RELATIVE
${submodule})
string(STRIP ${GIT_DIR_RELATIVE} GIT_DIR_RELATIVE)
get_filename_component(SUBMODULE_DIR ${GIT_DIR} PATH)
get_filename_component(GIT_DIR ${SUBMODULE_DIR}/${GIT_DIR_RELATIVE}
ABSOLUTE)
set(HEAD_SOURCE_FILE "${GIT_DIR}/HEAD")
else()
# GIT_DIR/CMAKE_CURRENT_SOURCE_DIR is in a worktree
file(READ ${GIT_DIR} worktree_ref)
# The .git directory contains a path to the worktree information directory
# inside the parent git repo of the worktree.
#
string(REGEX REPLACE "gitdir: (.*)$" "\\1" git_worktree_dir
${worktree_ref})
string(STRIP ${git_worktree_dir} git_worktree_dir)
_git_find_closest_git_dir("${git_worktree_dir}" GIT_DIR)
set(HEAD_SOURCE_FILE "${git_worktree_dir}/HEAD")
endif()
else()
set(HEAD_SOURCE_FILE "${GIT_DIR}/HEAD")
endif()
set(GIT_DATA "${CMAKE_CURRENT_BINARY_DIR}/CMakeFiles/git-data")
if(NOT EXISTS "${GIT_DATA}")
file(MAKE_DIRECTORY "${GIT_DATA}")
endif()
if(NOT EXISTS "${HEAD_SOURCE_FILE}")
return()
endif()
set(HEAD_FILE "${GIT_DATA}/HEAD")
configure_file("${HEAD_SOURCE_FILE}" "${HEAD_FILE}" COPYONLY)
configure_file("${_gitdescmoddir}/GetGitRevisionDescription.cmake.in"
"${GIT_DATA}/grabRef.cmake" @ONLY)
include("${GIT_DATA}/grabRef.cmake")
set(${_refspecvar}
"${HEAD_REF}"
PARENT_SCOPE)
set(${_hashvar}
"${HEAD_HASH}"
PARENT_SCOPE)
endfunction()
function(git_describe _var)
if(NOT GIT_FOUND)
find_package(Git QUIET)
endif()
get_git_head_revision(refspec hash)
if(NOT GIT_FOUND)
set(${_var}
"GIT-NOTFOUND"
PARENT_SCOPE)
return()
endif()
if(NOT hash)
set(${_var}
"HEAD-HASH-NOTFOUND"
PARENT_SCOPE)
return()
endif()
# TODO sanitize
#if((${ARGN}" MATCHES "&&") OR
# (ARGN MATCHES "||") OR
# (ARGN MATCHES "\\;"))
# message("Please report the following error to the project!")
# message(FATAL_ERROR "Looks like someone's doing something nefarious with git_describe! Passed arguments ${ARGN}")
#endif()
#message(STATUS "Arguments to execute_process: ${ARGN}")
execute_process(
COMMAND "${GIT_EXECUTABLE}" describe --tags --always ${hash} ${ARGN}
WORKING_DIRECTORY "${CMAKE_CURRENT_SOURCE_DIR}"
RESULT_VARIABLE res
OUTPUT_VARIABLE out
ERROR_QUIET OUTPUT_STRIP_TRAILING_WHITESPACE)
if(NOT res EQUAL 0)
set(out "${out}-${res}-NOTFOUND")
endif()
set(${_var}
"${out}"
PARENT_SCOPE)
endfunction()
function(git_describe_working_tree _var)
if(NOT GIT_FOUND)
find_package(Git QUIET)
endif()
if(NOT GIT_FOUND)
set(${_var}
"GIT-NOTFOUND"
PARENT_SCOPE)
return()
endif()
execute_process(
COMMAND "${GIT_EXECUTABLE}" describe --dirty ${ARGN}
WORKING_DIRECTORY "${CMAKE_CURRENT_SOURCE_DIR}"
RESULT_VARIABLE res
OUTPUT_VARIABLE out
ERROR_QUIET OUTPUT_STRIP_TRAILING_WHITESPACE)
if(NOT res EQUAL 0)
set(out "${out}-${res}-NOTFOUND")
endif()
set(${_var}
"${out}"
PARENT_SCOPE)
endfunction()
function(git_get_exact_tag _var)
git_describe(out --exact-match ${ARGN})
set(${_var}
"${out}"
PARENT_SCOPE)
endfunction()
function(git_local_changes _var)
if(NOT GIT_FOUND)
find_package(Git QUIET)
endif()
get_git_head_revision(refspec hash)
if(NOT GIT_FOUND)
set(${_var}
"GIT-NOTFOUND"
PARENT_SCOPE)
return()
endif()
if(NOT hash)
set(${_var}
"HEAD-HASH-NOTFOUND"
PARENT_SCOPE)
return()
endif()
execute_process(
COMMAND "${GIT_EXECUTABLE}" diff-index --quiet HEAD --
WORKING_DIRECTORY "${CMAKE_CURRENT_SOURCE_DIR}"
RESULT_VARIABLE res
OUTPUT_VARIABLE out
ERROR_QUIET OUTPUT_STRIP_TRAILING_WHITESPACE)
if(res EQUAL 0)
set(${_var}
"CLEAN"
PARENT_SCOPE)
else()
set(${_var}
"DIRTY"
PARENT_SCOPE)
endif()
endfunction()

43
cmake/GetGitRevisionDescription.cmake.in
View File

@ -1,43 +0,0 @@
#
# Internal file for GetGitRevisionDescription.cmake
#
# Requires CMake 2.6 or newer (uses the 'function' command)
#
# Original Author:
# 2009-2010 Ryan Pavlik <rpavlik@iastate.edu> <abiryan@ryand.net>
# http://academic.cleardefinition.com
# Iowa State University HCI Graduate Program/VRAC
#
# Copyright 2009-2012, Iowa State University
# Copyright 2011-2015, Contributors
# Distributed under the Boost Software License, Version 1.0.
# (See accompanying file LICENSE_1_0.txt or copy at
# http://www.boost.org/LICENSE_1_0.txt)
# SPDX-License-Identifier: BSL-1.0
set(HEAD_HASH)
file(READ "@HEAD_FILE@" HEAD_CONTENTS LIMIT 1024)
string(STRIP "${HEAD_CONTENTS}" HEAD_CONTENTS)
if(HEAD_CONTENTS MATCHES "ref")
# named branch
string(REPLACE "ref: " "" HEAD_REF "${HEAD_CONTENTS}")
if(EXISTS "@GIT_DIR@/${HEAD_REF}")
configure_file("@GIT_DIR@/${HEAD_REF}" "@GIT_DATA@/head-ref" COPYONLY)
else()
configure_file("@GIT_DIR@/packed-refs" "@GIT_DATA@/packed-refs" COPYONLY)
file(READ "@GIT_DATA@/packed-refs" PACKED_REFS)
if(${PACKED_REFS} MATCHES "([0-9a-z]*) ${HEAD_REF}")
set(HEAD_HASH "${CMAKE_MATCH_1}")
endif()
endif()
else()
# detached HEAD
configure_file("@GIT_DIR@/HEAD" "@GIT_DATA@/head-ref" COPYONLY)
endif()
if(NOT HEAD_HASH)
file(READ "@GIT_DATA@/head-ref" HEAD_HASH LIMIT 1024)
string(STRIP "${HEAD_HASH}" HEAD_HASH)
endif()

23
cmake/LICENSE_1_0.txt
View File

@ -1,23 +0,0 @@
Boost Software License - Version 1.0 - August 17th, 2003
Permission is hereby granted, free of charge, to any person or organization
obtaining a copy of the software and accompanying documentation covered by
this license (the "Software") to use, reproduce, display, distribute,
execute, and transmit the Software, and to prepare derivative works of the
Software, and to permit third-parties to whom the Software is furnished to
do so, all subject to the following:
The copyright notices in the Software and this entire statement, including
the above license grant, this restriction and the following disclaimer,
must be included in all copies of the Software, in whole or in part, and
all derivative works of the Software, unless such copies or derivative
works are solely in the form of machine-executable object code generated by
a source language processor.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE, TITLE AND NON-INFRINGEMENT. IN NO EVENT
SHALL THE COPYRIGHT HOLDERS OR ANYONE DISTRIBUTING THE SOFTWARE BE LIABLE
FOR ANY DAMAGES OR OTHER LIABILITY, WHETHER IN CONTRACT, TORT OR OTHERWISE,
ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
DEALINGS IN THE SOFTWARE.

36
examples/api/custom_tmatrix/custom_tmatrices_simple.py
View File

@ -1,36 +0,0 @@
#!/usr/bin/env python3
from qpms import TMatrixGenerator, BaseSpec, eV, hbar
import numpy as np
import sys
errors = 0
def tmg_diagonal_fun(tmatrix, omega):
'''
Example of a python function used as a custom T-matrix generator
It receives a CTMatrix argument with pre-filled BaseSpec
(in tmatrix.spec) and angular frequency.
It has to fill in the T-matrix elements tmatrix[...]
(a numpy array of shape (len(tmatrix.spec),len(tmatrix.spec)))
and return zero (on success) or other integral value on error.
Note that this in justa an example of using the API,
not supposed to be anything physical.
'''
l = tmatrix.spec.l()
tmatrix[...] = np.diag(1./l**2)
return 0
# Wrap the function as an actual TMatrixGenerator
tmg_diagonal = TMatrixGenerator(tmg_diagonal_fun)
bspec = BaseSpec(lMax=2)
tmatrix = tmg_diagonal(bspec, (2.0+.01j) * eV/hbar)
errors += np.sum(tmatrix[...] != np.diag(1./bspec.l()**2))
sys.exit(errors)

38
examples/hexagonal/modes/00_params.sh
View File

@ -1,38 +0,0 @@
#!/bin/bash
echo 'scale=20;pi=3.14159265358979323846;' > bc_env
export BC_ENV_ARGS="bc_env"
# We put those into bc, which does not understant exponential notation
SEPARATION_nm=576
# Particle positions within unit cell
export P1X_nm=0
export P1Y_nm=$(bc <<< ${SEPARATION_nm}/2)
export P2X_nm=0
export P2Y_nm=-$P1Y_nm
# Lattice vectors
export A1X_nm=$(bc <<< ${SEPARATION_nm}'*sqrt(3)')
export A1Y_nm=0
export A2X_nm=$(bc <<< ${SEPARATION_nm}'*sqrt(3)/2')
export A2Y_nm=$(bc <<< ${SEPARATION_nm}'*3/2')
# Reciprocal lattice vectors
export B1X_nmi=$(bc <<< '2*pi/sqrt(3)/'${SEPARATION_nm})
export B1Y_nmi=$(bc <<< '-2*pi/3/'${SEPARATION_nm})
export B2X_nmi=0
export B2Y_nmi=$(bc <<< '4*pi/3/'${SEPARATION_nm})
# a K-point coordinates
export KPOINTX_nmi=$(bc <<< '4*pi/3/sqrt(3)'/${SEPARATION_nm})
export KPOINTY_nmi=0.0 #$(bc <<< '4*pi/3/sqrt(3)'/${SEPARATION_nm})
# a M-point coordinates
export MPOINTX_nmi=0.0
export MPOINTY_nmi=$(bc <<< '2*pi/3'/${SEPARATION_nm})
export RADIUS_nm=50
export HEIGHT_nm=50
export METAL=Au
export BG_REFINDEX=1.52

18
examples/hexagonal/modes/01_compute_modes.sh
View File

@ -1,18 +0,0 @@
#!/bin/bash
SCRIPTDIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null 2>&1 && pwd )"
MISCDIR=../../../misc
source ${SCRIPTDIR}/00_params.sh
${MISCDIR}/lat2d_modes.py \
-n $BG_REFINDEX \
-b s${A1X_nm}e-9 s${A1Y_nm}e-9 \
-b s${A2X_nm}e-9 s${A2Y_nm}e-9 \
-p s${P1X_nm}e-9 s${P1Y_nm}e-9 \
-p s${P2X_nm}e-9 s${P2Y_nm}e-9 \
-L 3 -m $METAL -r ${RADIUS_nm}e-9 -H ${HEIGHT_nm}e-9 \
-k s${KPOINTX_nmi}e9 s${KPOINTY_nmi}e9 \
-d -3 \
-t 0.01 \
-c 250 \
-P

16
examples/hexagonal/modes/01a_realfreq_svd.sh
View File

@ -1,16 +0,0 @@
#!/bin/bash
SCRIPTDIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null 2>&1 && pwd )"
MISCDIR=../../../misc
source ${SCRIPTDIR}/00_params.sh
${MISCDIR}/lat2d_realfreqsvd.py \
-B $BG_REFINDEX \
-b s${A1X_nm}e-9 s${A1Y_nm}e-9 \
-b s${A2X_nm}e-9 s${A2Y_nm}e-9 \
-p s${P1X_nm}e-9 s${P1Y_nm}e-9 \
-p s${P2X_nm}e-9 s${P2Y_nm}e-9 \
-L 3 -m $METAL -r ${RADIUS_nm}e-9 -H ${HEIGHT_nm}e-9 \
-k s${KPOINTX_nmi}e9 s${KPOINTY_nmi}e9 \
-F 1.3 0.001 1.5 \
-P

22
examples/hexagonal/modes/02_compute_disp.sh
View File

@ -1,22 +0,0 @@
#!/bin/bash
SCRIPTDIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null 2>&1 && pwd )"
MISCDIR=../../../misc
source ${SCRIPTDIR}/00_params.sh
for bbb in 1 -2 -3 -4 ; do
for coeff in $(seq 0.80 0.01 1.50 | sed -e s/,/./g) ; do
${MISCDIR}/lat2d_modes.py \
-n $BG_REFINDEX \
-b s${A1X_nm}e-9 s${A1Y_nm}e-9 \
-b s${A2X_nm}e-9 s${A2Y_nm}e-9 \
-p s${P1X_nm}e-9 s${P1Y_nm}e-9 \
-p s${P2X_nm}e-9 s${P2Y_nm}e-9 \
-L 3 -m $METAL -r ${RADIUS_nm}e-9 -H ${HEIGHT_nm}e-9 \
-k s$(bc <<< ${KPOINTX_nmi}*${coeff})e9 s$(bc <<< ${KPOINTY_nmi}*${coeff})e9 \
-d $bbb \
-t 1e13 \
-T 0.2 \
-c 250
done
done

24
examples/hexagonal/modes/02b_compute_disp_0M.sh
View File

@ -1,24 +0,0 @@
#!/bin/bash
SCRIPTDIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null 2>&1 && pwd )"
MISCDIR=../../../misc
source ${SCRIPTDIR}/00_params.sh
for bbb in 1 -2 -3 -4 ; do
for coeff in $(seq 0.00 0.01 1.00 | sed -e s/,/./g) ; do
${MISCDIR}/lat2d_modes.py \
-n $BG_REFINDEX \
-b s${A1X_nm}e-9 s${A1Y_nm}e-9 \
-b s${A2X_nm}e-9 s${A2Y_nm}e-9 \
-p s${P1X_nm}e-9 s${P1Y_nm}e-9 \
-p s${P2X_nm}e-9 s${P2Y_nm}e-9 \
-L 3 -m $METAL -r ${RADIUS_nm}e-9 -H ${HEIGHT_nm}e-9 \
-k s$(bc <<< ${MPOINTX_nmi}*${coeff})e9 s$(bc <<< ${MPOINTY_nmi}*${coeff})e9 \
-d $bbb \
-t 1e12 \
-T 0.3 \
-c 250 \
-P
done
done

24
examples/hexagonal/modes/02x_compute_disp.sh
View File

@ -1,24 +0,0 @@
#!/bin/bash
SCRIPTDIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null 2>&1 && pwd )"
MISCDIR=../../../misc
source ${SCRIPTDIR}/00_params.sh
for bbb in 1 2 ; do
for coeff in $(seq 0.80 0.01 2.00 | sed -e s/,/./g) ; do
${MISCDIR}/lat2d_modes.py \
-n $BG_REFINDEX \
-b s${A1X_nm}e-9 s${A1Y_nm}e-9 \
-b s${A2X_nm}e-9 s${A2Y_nm}e-9 \
-p s${P1X_nm}e-9 s${P1Y_nm}e-9 \
-p s${P2X_nm}e-9 s${P2Y_nm}e-9 \
-L 3 -m $METAL -r ${RADIUS_nm}e-9 -H ${HEIGHT_nm}e-9 \
-k s$(bc <<< ${KPOINTX_nmi}*${coeff})e9 s$(bc <<< ${KPOINTY_nmi}*${coeff})e9 \
-d -$bbb \
-t 1e12 \
-T 0.2 \
-c 250 \
-P
done
done

1
examples/hexagonal/modes/bc_env
View File

@ -1 +0,0 @@
scale=20;pi=3.14159265358979323846;

37
examples/rectangular/modes/00_params.sh
View File

@ -1,37 +0,0 @@
#!/bin/bash
# Common parameters for a rectangular array
# N.B. We put those into bc, which does not understant exponential notation
export PX_nm=375
export PY_nm=375
export RADIUS_nm=30
export HEIGHT_nm=30
export METAL=Ag
export BG_REFINDEX=1.52
# Setup bc
echo 'scale=20;pi=3.14159265358979323846;' > bc_env
export BC_ENV_ARGS="bc_env"
# We have only one particle per unit cell here
export P1X_nm=0
export P1Y_nm=0
# Lattice vectors (for the general scripts)
export A1X_nm=${PX_nm}
export A1Y_nm=0
export A2X_nm=0
export A2Y_nm=${PY_nm}
# Reciprocal lattice vectors
export B1X_nmi=$(bc <<< '1/'${PX_nm})
export B1Y_nmi=0
export B2X_nmi=0
export B2Y_nmi=$(bc <<< '1/'${PY_nm})

18
examples/rectangular/modes/01_compute_modes.sh
View File

@ -1,18 +0,0 @@
#!/bin/bash
SCRIPTDIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null 2>&1 && pwd )"
MISCDIR=../../../misc
source ${SCRIPTDIR}/00_params.sh
${MISCDIR}/lat2d_modes.py \
-n $BG_REFINDEX \
-b s${A1X_nm}e-9 s${A1Y_nm}e-9 \
-b s${A2X_nm}e-9 s${A2Y_nm}e-9 \
-p s${P1X_nm}e-9 s${P1Y_nm}e-9 \
-p s${P2X_nm}e-9 s${P2Y_nm}e-9 \
-L 3 -m $METAL -r ${RADIUS_nm}e-9 -H ${HEIGHT_nm}e-9 \
-k s${KPOINTX_nmi}e9 s${KPOINTY_nmi}e9 \
-d -3 \
-t 0.01 \
-c 250 \
-P

17
examples/rectangular/modes/01a_realfreq_svd.sh
View File

@ -1,17 +0,0 @@
#!/bin/bash
SCRIPTDIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null 2>&1 && pwd )"
MISCDIR=../../../misc
source ${SCRIPTDIR}/00_params.sh
# try several lMaxes
${MISCDIR}/lat2d_realfreqsvd.py \
-B $BG_REFINDEX \
-b s${A1X_nm}e-9 s${A1Y_nm}e-9 \
-b s${A2X_nm}e-9 s${A2Y_nm}e-9 \
-p s${P1X_nm}e-9 s${P1Y_nm}e-9 \
-L 2 -m $METAL -r ${RADIUS_nm}e-9 -H ${HEIGHT_nm}e-9 \
-k 0 0 \
-F 2.001 0.001 2.250 \
-P

15
examples/rectangular/modes/01b_realfreq_svd_sym.sh
View File

@ -1,15 +0,0 @@
#!/bin/bash
SCRIPTDIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null 2>&1 && pwd )"
MISCDIR=../../../misc
source ${SCRIPTDIR}/00_params.sh
for LMAX in 1 2 3 ; do # try several cutoffs
${MISCDIR}/infiniterectlat-k0realfreqsvd.py \
-B $BG_REFINDEX \
-p ${PX_nm}e-9 ${PY_nm}e-9 \
-L $LMAX -m $METAL -r ${RADIUS_nm}e-9 -H ${HEIGHT_nm}e-9 \
-F 2.001 0.001 2.250 \
-P
done

22
examples/rectangular/modes/02_compute_disp.sh
View File

@ -1,22 +0,0 @@
#!/bin/bash
SCRIPTDIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null 2>&1 && pwd )"
MISCDIR=../../../misc
source ${SCRIPTDIR}/00_params.sh
for bbb in 1 -2 -3 -4 ; do
for coeff in $(seq 0.80 0.01 1.50 | sed -e s/,/./g) ; do
${MISCDIR}/lat2d_modes.py \
-n $BG_REFINDEX \
-b s${A1X_nm}e-9 s${A1Y_nm}e-9 \
-b s${A2X_nm}e-9 s${A2Y_nm}e-9 \
-p s${P1X_nm}e-9 s${P1Y_nm}e-9 \
-p s${P2X_nm}e-9 s${P2Y_nm}e-9 \
-L 3 -m $METAL -r ${RADIUS_nm}e-9 -H ${HEIGHT_nm}e-9 \
-k s$(bc <<< ${KPOINTX_nmi}*${coeff})e9 s$(bc <<< ${KPOINTY_nmi}*${coeff})e9 \
-d $bbb \
-t 1e13 \
-T 0.2 \
-c 250
done
done

24
examples/rectangular/modes/02b_compute_disp_0M.sh
View File

@ -1,24 +0,0 @@
#!/bin/bash
SCRIPTDIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null 2>&1 && pwd )"
MISCDIR=../../../misc
source ${SCRIPTDIR}/00_params.sh
for bbb in 1 -2 -3 -4 ; do
for coeff in $(seq 0.00 0.01 1.00 | sed -e s/,/./g) ; do
${MISCDIR}/lat2d_modes.py \
-n $BG_REFINDEX \
-b s${A1X_nm}e-9 s${A1Y_nm}e-9 \
-b s${A2X_nm}e-9 s${A2Y_nm}e-9 \
-p s${P1X_nm}e-9 s${P1Y_nm}e-9 \
-p s${P2X_nm}e-9 s${P2Y_nm}e-9 \
-L 3 -m $METAL -r ${RADIUS_nm}e-9 -H ${HEIGHT_nm}e-9 \
-k s$(bc <<< ${MPOINTX_nmi}*${coeff})e9 s$(bc <<< ${MPOINTY_nmi}*${coeff})e9 \
-d $bbb \
-t 1e12 \
-T 0.3 \
-c 250 \
-P
done
done

21
examples/rectangular/modes/02x_compute_disp.sh
View File

@ -1,21 +0,0 @@
#!/bin/bash
SCRIPTDIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null 2>&1 && pwd )"
MISCDIR=../../../misc
source ${SCRIPTDIR}/00_params.sh
for bbb in 1 -2 2 -3 ; do
for coeff in $(seq -0.200 0.010 0.200 | sed -e s/,/./g) ; do
${MISCDIR}/lat2d_modes.py \
-n $BG_REFINDEX \
-b s${A1X_nm}e-9 s${A1Y_nm}e-9 \
-b s${A2X_nm}e-9 s${A2Y_nm}e-9 \
-p s${P1X_nm}e-9 s${P1Y_nm}e-9 \
-L 3 -m $METAL -r ${RADIUS_nm}e-9 -H ${HEIGHT_nm}e-9 \
-k s$(bc <<< ${B1X_nmi}*${coeff})e9 s$(bc <<< ${B1Y_nmi}*${coeff})e9 \
-d $bbb \
-T 0.2 \
-c 250
done
done

1992
examples/rectangular/modes/04_collect_modes.ipynb
View File

File diff suppressed because one or more lines are too long

1
examples/rectangular/scattering/00_params.sh
View File

@ -1 +0,0 @@
../modes/00_params.sh

19
examples/rectangular/scattering/01_scattering_infinite.sh
View File

@ -1,19 +0,0 @@
#!/bin/bash
SCRIPTDIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null 2>&1 && pwd )"
MISCDIR=../../../misc
source ${SCRIPTDIR}/00_params.sh
for PSI in 0 1; do
${MISCDIR}/infiniterectlat-scatter.py \
-B $BG_REFINDEX \
-p ${PX_nm}e-9 ${PY_nm}e-9 \
-L 3 -m $METAL -r ${RADIUS_nm}e-9 -H ${HEIGHT_nm}e-9 \
--theta "s-0.015:0.015|201" \
--phi 0 \
--psi $PSI \
--chi 0 \
-f "s2.110:2.230|100" \
-P
done

19
examples/rectangular/scattering/02_scattering_finite_single.sh
View File

@ -1,19 +0,0 @@
#!/bin/bash
SCRIPTDIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null 2>&1 && pwd )"
MISCDIR=../../../misc
source ${SCRIPTDIR}/00_params.sh
for PSI in 1; do
${MISCDIR}/finiterectlat-scatter.py \
--size 5 5\
-B $BG_REFINDEX \
-p ${PX_nm}e-9 ${PY_nm}e-9 \
-L 2 -m $METAL -r ${RADIUS_nm}e-9 -H ${HEIGHT_nm}e-9 \
--theta "s-0.05:0.05|101" \
--phi 0 \
--psi $PSI \
--chi 0 \
-f 2.15
done

19
examples/rectangular/scattering/02b_scattering_infinite_single.sh
View File

@ -1,19 +0,0 @@
#!/bin/bash
SCRIPTDIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null 2>&1 && pwd )"
MISCDIR=../../../misc
source ${SCRIPTDIR}/00_params.sh
for PSI in 0 1; do
${MISCDIR}/infiniterectlat-scatter.py \
-B $BG_REFINDEX \
-p ${PX_nm}e-9 ${PY_nm}e-9 \
-L 2 -m $METAL -r ${RADIUS_nm}e-9 -H ${HEIGHT_nm}e-9 \
--theta "s-0.05:0.05|101" \
--phi 0 \
--psi $PSI \
--chi 0 \
-P \
-f 2.15
done

25
examples/rectangular/scattering/02c_scattering_finite_single_huge.sh
View File

@ -1,25 +0,0 @@
#!/bin/bash
##SBATCH --mem=50000
##SBATCH -c 12
##SBATCH -t 14:00:00
##SBATCH -p batch
SCRIPTDIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null 2>&1 && pwd )"
MISCDIR=../../../misc
source ${SCRIPTDIR}/00_params.sh
for PSI in 0 1; do
${MISCDIR}/finiterectlat-scatter.py \
--size 140 100 \
-B $BG_REFINDEX \
-p ${PX_nm}e-9 ${PY_nm}e-9 \
-L 2 -m $METAL -r ${RADIUS_nm}e-9 -H ${HEIGHT_nm}e-9 \
--theta "s-0.05:0.05|101" \
--phi 0 \
--psi $PSI \
--chi 0 \
-o 140x100.npz -O 140x100.pdf \
-P \
-f 2.15
done

25
examples/rectangular/scattering/02d_scattering_finite_single_big.sh
View File

@ -1,25 +0,0 @@
#!/bin/bash
##SBATCH --mem=30000
##SBATCH -c 12
##SBATCH -t 14:00:00
##SBATCH -p batch
SCRIPTDIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null 2>&1 && pwd )"
MISCDIR=../../../misc
source ${SCRIPTDIR}/00_params.sh
for PSI in 1; do
${MISCDIR}/finiterectlat-scatter.py \
--size 100 100 \
-B $BG_REFINDEX \
-p ${PX_nm}e-9 ${PY_nm}e-9 \
-L 2 -m $METAL -r ${RADIUS_nm}e-9 -H ${HEIGHT_nm}e-9 \
--theta "s-0.05:0.05|101" \
--phi 0 \
--psi $PSI \
--chi 0 \
-o 100x100.npz -O 100x100.pdf \
-P \
-f 2.15
done

25
examples/rectangular/scattering/02e_scattering_finite_single_huge.sh
View File

@ -1,25 +0,0 @@
#!/bin/bash
##SBATCH --mem=50000
##SBATCH -c 12
##SBATCH -t 14:00:00
##SBATCH -p batch
SCRIPTDIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null 2>&1 && pwd )"
MISCDIR=../../../misc
source ${SCRIPTDIR}/00_params.sh
for PSI in 0 1; do
${MISCDIR}/finiterectlat-scatter.py \
--size 140 140 \
-B $BG_REFINDEX \
-p ${PX_nm}e-9 ${PY_nm}e-9 \
-L 2 -m $METAL -r ${RADIUS_nm}e-9 -H ${HEIGHT_nm}e-9 \
--theta "s-0.05:0.05|101" \
--phi 0 \
--psi $PSI \
--chi 0 \
-o 140x140.npz -O 140x140.pdf \
-P \
-f 2.15
done

21
examples/rectangular/scattering/03_scattering_finite.sh
View File

@ -1,21 +0,0 @@
#!/bin/bash
SCRIPTDIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null 2>&1 && pwd )"
MISCDIR=../../../misc
source ${SCRIPTDIR}/00_params.sh
for PSI in 1; do
${MISCDIR}/finiterectlat-scatter.py \
--size 20 20 \
-B $BG_REFINDEX \
-p ${PX_nm}e-9 ${PY_nm}e-9 \
-L 3 -m $METAL -r ${RADIUS_nm}e-9 -H ${HEIGHT_nm}e-9 \
--theta "s-0.005:0.005|101" \
--phi 0 \
--psi $PSI \
--chi 0 \
-P \
-f "s2.150:2.180|100" \
done

200
examples/rectangular/scattering/04_scattering_cut_compare.ipynb
View File

File diff suppressed because one or more lines are too long

383
examples/size_vs_lMax/AuSphere/_mode_r_dep.ipynb
View File

File diff suppressed because one or more lines are too long

19
examples/size_vs_lMax/AuSphere/parallel_generate.sh
View File

@ -1,19 +0,0 @@
#!/bin/bash
#SBATCH --mem=200
#SBATCH -t 30:00
#SBATCH -c 4
#SBATCH -p short-ivb
#SBATCH --array=0-250
cat $0
contour_points=410
#radii_nm=(`seq 80 1 150`)
radii_nm=(`seq 50 1 300`)
radius_nm=${radii_nm[$SLURM_ARRAY_TASK_ID]}
for lMax in $(seq 1 5); do
srun rectlat_simple_modes.py -p 580e-9 -m '4+0.7j' -r ${radius_nm}e-9 -k 0 0 --kpi -n 1.52 -L lMax -t 1e11 -b -2 -f 0.1 -i 1. -T .3 -N ${contour_points}
done

13
examples/size_vs_lMax/AuSphere/serial.sh
View File

@ -1,13 +0,0 @@
#!/bin/bash
kx=0.0
contour_points=410
radii_nm=(`seq 50 1 300`)
radius_nm=${radii_nm[$SLURM_ARRAY_TASK_ID]}
for lMax in $(seq 1 5) ; do
for radius_nm in $(seq 50 1 300) ; do
rectlat_simple_modes.py -p 580e-9 -m 'Au' -r ${radius_nm}e-9 -k $kx 0 --kpi -n 1.52 -L $lMax -t 1e11 -b -2 -f 0.1 -i 1. -T .3 -N ${contour_points} --lMax-extend 10
done
done

11
examples/size_vs_lMax/AuSphere/serial1.sh
View File

@ -1,11 +0,0 @@
#!/bin/bash
kx=0.0
contour_points=410
radii_nm=(`seq 50 1 300`)
radius_nm=${radii_nm[$SLURM_ARRAY_TASK_ID]}
for radius_nm in $(seq 50 1 300) ; do
rectlat_simple_modes.py -p 580e-9 -m 'Au' -r ${radius_nm}e-9 -k $kx 0 --kpi -n 1.52 -L 1 -t 1e11 -b -2 -f 0.1 -i 1. -T .3 -N ${contour_points}
done

300
examples/size_vs_lMax/_mode_r_dep.ipynb
View File

@ -1,300 +0,0 @@
{
"cells": [
{
"cell_type": "code",
"execution_count": 1,
"metadata": {},
"outputs": [],
"source": [
"%matplotlib inline\n",
"import re\n",
"import numpy as np\n",
"import matplotlib\n",
"from matplotlib import pyplot as plt\n",
"from scipy.constants import hbar, e as eV, c\n",
"eh = eV/hbar\n",
"import glob\n",
"def ri(z): return (z.real, z.imag)\n",
"#m = re.compile(r\"([^_]+)_r([0-9.]+)nm_\")\n",
"#removek = re.compile(r\"(k\\([^)]+\\)um-1_)\")\n",
"remover = re.compile(r\"r[0-9.]+nm_\")\n",
"\n",
"\n",
"markerdict = {\n",
" 4: \"3\",\n",
" -4: \"4\",\n",
" 3: \"^\",\n",
" -3: \"v\",\n",
" -2: 'x',\n",
" 2: '+',\n",
" 1: 's',\n",
" -1: 'd',\n",
"}\n",
"\n",
"prop_cycle = plt.rcParams['axes.prop_cycle']\n",
"colors = prop_cycle.by_key()['color']\n",
"colordict = {i: colors[(i+1)] for i in range(-4,8)}\n",
"\n",
"def markerfun(b):\n",
" if b in markerdict.keys():\n",
" return markerdict[b]\n",
" else: return 'X'\n",
"\n",
"def colorfun(b):\n",
" if (b+1) in colordict.keys():\n",
" return colordict[b+1]\n",
" else: return colordict[0]"
]
},
{
"cell_type": "code",
"execution_count": 2,
"metadata": {},
"outputs": [],
"source": [
"allfiles=glob.glob('*sph*k(0_0)*.npz')\n",
"allgraphs=dict()\n",
"for f in allfiles:\n",
" base = remover.sub('', f)\n",
" if base in allgraphs.keys():\n",
" allgraphs[base] += 1\n",
" else:\n",
" allgraphs[base] = 1\n",
"for k in sorted(allgraphs.keys()):\n",
" print(k, allgraphs[k])"
]
},
{
"cell_type": "code",
"execution_count": 3,
"metadata": {},
"outputs": [
{
"ename": "FileNotFoundError",
"evalue": "[Errno 2] No such file or directory: 'projectors_D4h_lMax1.npz'",
"output_type": "error",
"traceback": [
"\u001b[0;31m---------------------------------------------------------------------------\u001b[0m",
"\u001b[0;31mFileNotFoundError\u001b[0m Traceback (most recent call last)",
"\u001b[0;32m<ipython-input-3-0c266089be08>\u001b[0m in \u001b[0;36m<module>\u001b[0;34m\u001b[0m\n\u001b[1;32m 3\u001b[0m \u001b[0mlMaxes\u001b[0m \u001b[0;34m=\u001b[0m \u001b[0;34m[\u001b[0m\u001b[0mlMax\u001b[0m \u001b[0;32mfor\u001b[0m \u001b[0mlMax\u001b[0m \u001b[0;32min\u001b[0m \u001b[0mrange\u001b[0m\u001b[0;34m(\u001b[0m\u001b[0;36m1\u001b[0m\u001b[0;34m,\u001b[0m\u001b[0;36m6\u001b[0m\u001b[0;34m)\u001b[0m\u001b[0;34m]\u001b[0m\u001b[0;34m\u001b[0m\u001b[0;34m\u001b[0m\u001b[0m\n\u001b[1;32m 4\u001b[0m \u001b[0;32mfor\u001b[0m \u001b[0mlMax\u001b[0m \u001b[0;32min\u001b[0m \u001b[0mlMaxes\u001b[0m\u001b[0;34m:\u001b[0m\u001b[0;34m\u001b[0m\u001b[0;34m\u001b[0m\u001b[0m\n\u001b[0;32m----> 5\u001b[0;31m \u001b[0mproj\u001b[0m \u001b[0;34m=\u001b[0m \u001b[0mnp\u001b[0m\u001b[0;34m.\u001b[0m\u001b[0mload\u001b[0m\u001b[0;34m(\u001b[0m\u001b[0;34m'projectors_D4h_lMax%d.npz'\u001b[0m \u001b[0;34m%\u001b[0m \u001b[0mlMax\u001b[0m\u001b[0;34m)\u001b[0m\u001b[0;34m\u001b[0m\u001b[0;34m\u001b[0m\u001b[0m\n\u001b[0m\u001b[1;32m 6\u001b[0m \u001b[0mirlabels\u001b[0m \u001b[0;34m=\u001b[0m \u001b[0msorted\u001b[0m\u001b[0;34m(\u001b[0m\u001b[0mproj\u001b[0m\u001b[0;34m.\u001b[0m\u001b[0mkeys\u001b[0m\u001b[0;34m(\u001b[0m\u001b[0;34m)\u001b[0m\u001b[0;34m)\u001b[0m\u001b[0;34m\u001b[0m\u001b[0;34m\u001b[0m\u001b[0m\n\u001b[1;32m 7\u001b[0m \u001b[0mproj\u001b[0m \u001b[0;34m=\u001b[0m \u001b[0;34m{\u001b[0m\u001b[0mf\u001b[0m\u001b[0;34m:\u001b[0m \u001b[0mproj\u001b[0m\u001b[0;34m[\u001b[0m\u001b[0mf\u001b[0m\u001b[0;34m]\u001b[0m \u001b[0;32mfor\u001b[0m \u001b[0mf\u001b[0m \u001b[0;32min\u001b[0m \u001b[0mirlabels\u001b[0m\u001b[0;34m}\u001b[0m\u001b[0;34m\u001b[0m\u001b[0;34m\u001b[0m\u001b[0m\n",
"\u001b[0;32m~/.local/lib/python3.7/site-packages/numpy-1.17.3-py3.7-linux-x86_64.egg/numpy/lib/npyio.py\u001b[0m in \u001b[0;36mload\u001b[0;34m(file, mmap_mode, allow_pickle, fix_imports, encoding)\u001b[0m\n\u001b[1;32m 426\u001b[0m \u001b[0mown_fid\u001b[0m \u001b[0;34m=\u001b[0m \u001b[0;32mFalse\u001b[0m\u001b[0;34m\u001b[0m\u001b[0;34m\u001b[0m\u001b[0m\n\u001b[1;32m 427\u001b[0m \u001b[0;32melse\u001b[0m\u001b[0;34m:\u001b[0m\u001b[0;34m\u001b[0m\u001b[0;34m\u001b[0m\u001b[0m\n\u001b[0;32m--> 428\u001b[0;31m \u001b[0mfid\u001b[0m \u001b[0;34m=\u001b[0m \u001b[0mopen\u001b[0m\u001b[0;34m(\u001b[0m\u001b[0mos_fspath\u001b[0m\u001b[0;34m(\u001b[0m\u001b[0mfile\u001b[0m\u001b[0;34m)\u001b[0m\u001b[0;34m,\u001b[0m \u001b[0;34m\"rb\"\u001b[0m\u001b[0;34m)\u001b[0m\u001b[0;34m\u001b[0m\u001b[0;34m\u001b[0m\u001b[0m\n\u001b[0m\u001b[1;32m 429\u001b[0m \u001b[0mown_fid\u001b[0m \u001b[0;34m=\u001b[0m \u001b[0;32mTrue\u001b[0m\u001b[0;34m\u001b[0m\u001b[0;34m\u001b[0m\u001b[0m\n\u001b[1;32m 430\u001b[0m \u001b[0;34m\u001b[0m\u001b[0m\n",
"\u001b[0;31mFileNotFoundError\u001b[0m: [Errno 2] No such file or directory: 'projectors_D4h_lMax1.npz'"
]
}
],
"source": [
"projectors = dict()\n",
"projectors_list = dict()\n",
"lMaxes = [lMax for lMax in range(1,6)]\n",
"for lMax in lMaxes:\n",
" proj = np.load('projectors_D4h_lMax%d.npz' % lMax)\n",
" irlabels = sorted(proj.keys())\n",
" proj = {f: proj[f] for f in irlabels}\n",
" proj_list = [proj[irlabels[i]] for i in range(len(proj))]\n",
" projectors[lMax] = proj\n",
" projectors_list[lMax] = proj_list\n",
"globpattern = '*sph_r*_p580nmx580nm_mAu_n1.52_b?2_k(0_0)um-1_L?_cn???.npz'\n",
"filenames=glob.glob(globpattern)\n",
"plotfilename = 'collected_' + globpattern.replace('*', 'XXX').replace('?', 'X').replace('npz','pdf')\n",
"print(filenames[:4], plotfilename)\n"
]
},
{
"cell_type": "code",
"execution_count": 41,
"metadata": {},
"outputs": [],
"source": [
"#projectors\n",
"#glob.glob('cyl_r100nm*L3*3100.npz')\n",
"#glob.glob('sph_r100*m5*.npz')\n",
"#dat['meta'][()],list(dat.keys())"
]
},
{
"cell_type": "code",
"execution_count": null,
"metadata": {},
"outputs": [],
"source": []
},
{
"cell_type": "code",
"execution_count": 42,
"metadata": {},
"outputs": [
{
"name": "stdout",
"output_type": "stream",
"text": [
"inpure result detected [1. 0.99999999 1. 0.97991334 0.99999996 0.9999989\n",
" 0.99999983 0.99999966 0.99999322 0.99999721 0.99999653] [3.28735741e-04 2.66532534e-05 2.47011478e-05 1.45012420e-01\n",
" 2.44785416e-04 7.05405359e-04 1.60203586e-03 1.71245137e-03\n",
" 1.03244480e-02 9.18732728e-03 1.18651583e-02]\n",
"inpure result detected [1. 1. 0.99999998 0.99999999 0.99999996 0.96608887\n",
" 0.99999852 0.99999397 0.99998951 0.99999912 0.99982435] [2.66223026e-04 2.12357147e-05 3.54211968e-05 1.06651057e-04\n",
" 2.79595790e-04 2.41939163e-01 2.17645058e-03 3.41541473e-03\n",
" 1.14507609e-02 1.49639498e-02 2.33483138e-02]\n",
"inpure result detected [1. 1. 0.92521572 1. 0.99999627 0.99990293\n",
" 0.99946049] [1.59712906e-05 3.60193407e-05 2.48341492e-01 1.21848930e-03\n",
" 3.81805601e-03 2.42649228e-02 2.99534246e-02]\n",
"inpure result detected [1. 1. 0.99999998 0.99999961 0.93267685 0.99999964\n",
" 0.99999822 0.99921774 0.99995547 0.99997301] [5.22490396e-04 3.01556792e-05 4.88795563e-05 6.29703960e-04\n",
" 2.34414238e-01 3.72766210e-03 4.72444059e-03 7.62106094e-02\n",
" 6.32796684e-02 5.63231562e-02]\n"
]
}
],
"source": [
"plotdata = {}\n",
"for file in filenames:\n",
" dat = np.load(file, allow_pickle=True)\n",
" kx = dat['meta'][()]['k'][0]\n",
" radius = dat['meta'][()]['radius']\n",
" b = dat['meta'][()]['band_index']\n",
" eigvals = dat['eigval']\n",
" lMax = dat['meta'][()]['lMax']\n",
" residuals = dat['residuals']\n",
" ef =dat['empty_freqs']\n",
" eigvecs = dat['eigvec']\n",
" irweights = []\n",
" #for proj in projectors_list[lMax]:\n",
" # try:\n",
" # irweights.append(np.linalg.norm(np.tensordot(proj, eigvecs, axes=(-1, -1)), axis=0,ord=2) if len(proj) != 0 else np.zeros((len(eigvecs),)))\n",
" # except ValueError as err:\n",
" # print(proj, len(proj))\n",
" # raise err\n",
" irweights = np.array(irweights)\n",
" #print(irweights)\n",
" irweights = np.array([np.linalg.norm(np.tensordot(proj, eigvecs, axes=(-1, -1)), axis=0,ord=2) if len(proj) != 0 else np.zeros((len(eigvecs),)) for proj in projectors_list[lMax]]).T\n",
" irclass = np.argmax(irweights, axis=-1)\n",
" purities = np.amax(irweights, axis=-1)\n",
" if (np.any(purities < 0.98)):\n",
" print(\"inpure result detected\", purities, residuals)\n",
" #print(purities)\n",
" \n",
" #for i in range(len(residuals)): \n",
" # if residuals[i] < 0.01:\n",
" # vec = eigvecs[i]\n",
" # for irlabel, proj in projectors.items():\n",
" # print(irlabel, np.linalg.norm(np.dot(proj, vec))) #maybe some conj() here?\n",
" # print('--->', irlabels[irclass[i]])\n",
"\n",
" \n",
" plotdata[(lMax,radius)] = (eigvals, residuals, b, ef, irclass,)\n"
]
},
{
"cell_type": "code",
"execution_count": null,
"metadata": {},
"outputs": [],
"source": [
"fig = plt.figure(figsize=(15,6))\n",
"axesR = {}\n",
"axesI = {}\n",
"for i, lMax in enumerate(lMaxes):\n",
" axesR[lMax] = fig.add_subplot(2,len(lMaxes),i+1)\n",
" axesR[lMax].set_xlim([50,300])\n",
" axesR[lMax].set_ylim([1.25, ef[1]/eh])\n",
" axesI[lMax] = fig.add_subplot(2,len(lMaxes),len(lMaxes)+i+1)\n",
" axesI[lMax].set_xlim([50,300])\n",
" axesI[lMax].set_ylim([-60, 30])\n",
" axesR[lMax].set_title('$l_\\max = %d $' % lMax) \n",
" axesR[lMax].tick_params(labelbottom=False) \n",
" if i == len(lMaxes)//2:\n",
" axesI[lMax].set_xlabel(\"Particle base radius / nm\")\n",
" if i == 0:\n",
" axesR[lMax].set_ylabel('$\\hbar \\Re \\omega / \\mathrm{eV}$')\n",
" axesI[lMax].set_ylabel('$\\hbar \\Im \\omega / \\mathrm{meV}$')\n",
" else:\n",
" axesR[lMax].tick_params(labelleft=False) \n",
" axesI[lMax].tick_params(labelleft=False) \n",
"\n",
"res_thr = 0.005\n",
"\n",
"ir_labeled=set()\n",
"if True:\n",
" for (lMax, radius), (eigvals, residuals, b, ef, irclass) in plotdata.items():\n",
" for i, (e, res, iri) in enumerate(zip(eigvals, residuals, irclass)):\n",
" #if i == 0:\n",
" if res < res_thr:# and e.real < 2.14e15:\n",
" if iri in ir_labeled: \n",
" label=None\n",
" else:\n",
" ir_labeled.add(iri)\n",
" label=irlabels[iri]\n",
" axesR[lMax].plot(radius*1e9, e.real/eh, \n",
" marker='.',\n",
" #marker=markerfun(b),\n",
" ms=4, #c=colorfun(b)\n",
" c=matplotlib.cm.hsv(iri/9),\n",
" #c = colorfun(iri),\n",
" label=label,\n",
" )\n",
" axesI[lMax].plot(radius*1e9, e.imag/eh*1000, \n",
" #marker='x', \n",
" #c=colorfun(b), \n",
" c=matplotlib.cm.hsv(iri/9),#colorfun(iri),\n",
" marker='.', #markerfun(b),\n",
" ms=4,\n",
" #label=label\n",
" )\n",
"fig.legend(title=\"Irrep\", loc=\"center right\")\n",
"#fig.suptitle('$l_\\mathrm{max}=%d$, residual threshold = %g' % (lMax, res_thr) )\n",
"fig.savefig(plotfilename)\n",
"fig.savefig(plotfilename.replace('pdf', 'png'))\n",
"print(plotfilename)"
]
},
{
"cell_type": "code",
"execution_count": 55,
"metadata": {},
"outputs": [
{
"data": {
"text/plain": [
"array([0. , 1.40635433, 1.98888536, 2.81270865, 3.14470387,\n",
" 3.97777072, 4.21906298, 4.44728287])"
]
},
"execution_count": 55,
"metadata": {},
"output_type": "execute_result"
}
],
"source": [
"ef / eh"
]
},
{
"cell_type": "code",
"execution_count": null,
"metadata": {},
"outputs": [],
"source": []
}
],
"metadata": {
"kernelspec": {
"display_name": "Python 3",
"language": "python",
"name": "python3"
},
"language_info": {
"codemirror_mode": {
"name": "ipython",
"version": 3
},
"file_extension": ".py",
"mimetype": "text/x-python",
"name": "python",
"nbconvert_exporter": "python",
"pygments_lexer": "ipython3",
"version": "3.7.6"
}
},
"nbformat": 4,
"nbformat_minor": 4
}

19
faddeeva/CMakeLists.txt
View File

@ -1,19 +0,0 @@
cmake_minimum_required(VERSION 3.0)
include(GNUInstallDirs)
project(Faddeeva VERSION 1.0 LANGUAGES C)
option(FADDEEVA_BUILD_STATIC "Build Faddeeva as static library" OFF)
if (FADDEEVA_BUILD_STATIC)
add_library(Faddeeva STATIC Faddeeva.h Faddeeva.c Faddeeva.cc)
else (FADDEEVA_BUILD_STATIC)
add_library(Faddeeva SHARED Faddeeva.c)
set_target_properties(Faddeeva PROPERTIES PUBLIC_HEADER "Faddeeva.h")
install(TARGETS Faddeeva
LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR}
PUBLIC_HEADER DESTINATION ${CMAKE_INSTALL_INCLUDEDIR})
endif (FADDEEVA_BUILD_STATIC)
target_include_directories(Faddeeva PUBLIC ${CMAKE_CURRENT_SOURCE_DIR})

3
faddeeva/Faddeeva.c
View File

@ -1,3 +0,0 @@
/* The Faddeeva.cc file contains macros to let it compile as C code
(assuming C99 complex-number support), so just #include it. */
#include "Faddeeva.cc"

2517
faddeeva/Faddeeva.cc
View File

File diff suppressed because it is too large Load Diff

Some files were not shown because too many files have changed in this diff Show More