tx258/lammps-gran-kokkos
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'develop' into imd-v3-integration

Browse Source
This commit is contained in:
ljwoods2
2024-11-25 16:26:56 -07:00
parent f7915109f9 43fbdc2d93
commit 6f36dcecc6
210 changed files with 23091 additions and 355 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3
.github/CODEOWNERS vendored
View File

@ -101,7 +101,8 @@ src/group.* @sjplimp
src/improper.* @sjplimp
src/info.* @akohlmey
src/kspace.* @sjplimp
src/lmptyp.h @sjplimp
src/lmptype.h @sjplimp
src/label_map.* @jrgissing @akohlmey
src/library.* @sjplimp @akohlmey
src/main.cpp @sjplimp
src/min_*.* @sjplimp

58
.github/release_steps.md vendored Normal file
View File

@ -0,0 +1,58 @@
# LAMMPS Release Steps
The following notes chronicle the current steps for preparing and publishing LAMMPS releases.
For definition of what LAMMPS versions and the different kinds of releases mean, please
refer to [the corresponding section in the LAMMPS manual](https://docs.lammps.org/Manual_version.html).
## LAMMPS Feature Release
A LAMMPS feature release is currently prepared after about 500 to 750 commits to the
'develop' branch or after a period of four weeks up to two months.
### Preparing a 'next\_release' branch
Create a 'next\_release' branch off 'develop' and make the following changes:
- set the LAMMPS\_VERSION define to the planned release date in src/version.h in the format "D Mmm YYYY" or "DD Mmm YYYY"
- remove the LAMMPS\_UPDATE define in src/version.h
- update the release date in doc/lammps.1
- update all TBD arguments for ..versionadded::, ..versionchanged:: ..deprecated:: to the
planned release date in the format "DMmmYYYY" or "DDMmmYYYY"
Submit this pull request, rebase if needed. This is the last pull request merged for the release
and should not contain any other changes. (Exceptions: this document, last minute trivial(!) changes).
This PR shall not be merged before **all** pending tests have completed and cleared. If needed, a
bugfix pull request should be created and merged to clear all tests.
## LAMMPS Stable Release
A LAMMPS stable release is prepared about once per year in the months July, August, or September.
One (or two, if needed) feature releases before the stable release shall contain only bug fixes
or minor feature updates in optional packages. Also substantial changes to the core of the code
shall be applied rather toward the beginning of a development cycle between two stable releases
than toward the end. The intention is to stablilize significant change to the core and have
outside users and developers try them out during the development cycle; the sooner the changes
are included, the better chances for spotting peripheral bugs and issues.
### Prerequesites
Before making a stable release all remaining backported bugfixes shall be released as a (final)
stable update release (see below).
A LAMMPS stable release process starts like a feature release (see above), only that this feature
release is called a "Stable Release Candidate" and no assets are uploaded to GitHub.
### Synchronize 'maintenance' branch with 'release'
The state of the 'release' branch is then transferred to the 'maintenance' branch (which will
have diverged significantly from 'release' due to the selectively backported bug fixes).
### Fast-forward merge of 'maintenance' into 'stable' and apply tag
At this point it should be possible to do a fast-forward merge of 'maintenance' to 'stable'
and then apply the stable\_DMmmYYYY tag.
### Push branches and tags
## LAMMPS Stable Update Release

14
.github/workflows/kokkos-regression.yaml vendored
View File

@ -2,7 +2,7 @@
name: "Kokkos OpenMP Regression Test"
on:
pull_request:
push:
branches:
- develop
@ -16,9 +16,9 @@ jobs:
env:
CCACHE_DIR: ${{ github.workspace }}/.ccache
strategy:
max-parallel: 4
max-parallel: 6
matrix:
idx: [ 'pair', 'fix', 'compute', 'misc' ]
idx: [ 'pair-0', 'pair-1', 'fix-0', 'fix-1', 'compute', 'misc' ]
steps:
- name: Checkout repository
@ -82,6 +82,7 @@ jobs:
-D PKG_REAXFF=on \
-D PKG_REPLICA=on \
-D PKG_SRD=on \
-D PKG_SPH=on \
-D PKG_VORONOI=on \
-G Ninja
cmake --build build
@ -92,9 +93,10 @@ jobs:
run: |
source linuxenv/bin/activate
python3 tools/regression-tests/get_kokkos_input.py \
--examples-top-level=examples \
--filter-out="balance;fire;gcmc;granregion;mdi;mliap;neb;pace;prd;pour;python;snap"
--examples-top-level=examples --batch-size=50 \
--filter-out="balance;fire;gcmc;granregion;hyper;mc;mdi;mliap;neb;pace;prd;pour;python;rigid;snap;streitz;shear;ttm"
export OMP_PROC_BIND=false
python3 tools/regression-tests/run_tests.py \
--lmp-bin=build/lmp \
--config-file=tools/regression-tests/config_kokkos_openmp.yaml \
@ -102,7 +104,7 @@ jobs:
--output-file=output-${{ matrix.idx }}.xml \
--progress-file=progress-${{ matrix.idx }}.yaml \
--log-file=run-${{ matrix.idx }}.log \
--quick-max=100 --verbose
--quick-max=100
tar -cvf kokkos-regression-test-${{ matrix.idx }}.tar run-${{ matrix.idx }}.log progress-${{ matrix.idx }}.yaml output-${{ matrix.idx }}.xml

11
cmake/CMakeLists.txt
View File

@ -141,7 +141,7 @@ endif()
# silence nvcc warnings
if((PKG_KOKKOS) AND (Kokkos_ENABLE_CUDA) AND NOT (CMAKE_CXX_COMPILER_ID STREQUAL "Clang"))
set(CMAKE_TUNE_DEFAULT "${CMAKE_TUNE_DEFAULT} -Xcudafe --diag_suppress=unrecognized_pragma -Xcudafe --diag_suppress=128")
set(CMAKE_TUNE_DEFAULT "${CMAKE_TUNE_DEFAULT}" "-Xcudafe --diag_suppress=unrecognized_pragma,--diag_suppress=128")
endif()
# we require C++11 without extensions. Kokkos requires at least C++17 (currently)
@ -588,13 +588,8 @@ endif()
set(CMAKE_TUNE_FLAGS "${CMAKE_TUNE_DEFAULT}" CACHE STRING "Compiler and machine specific optimization flags (compilation only)")
separate_arguments(CMAKE_TUNE_FLAGS)
foreach(_FLAG ${CMAKE_TUNE_FLAGS})
target_compile_options(lammps PRIVATE ${_FLAG})
# skip these flags when linking the main executable
if(NOT (("${_FLAG}" STREQUAL "-Xcudafe") OR (("${_FLAG}" STREQUAL "--diag_suppress=unrecognized_pragma"))))
target_compile_options(lmp PRIVATE ${_FLAG})
endif()
endforeach()
target_compile_options(lammps PRIVATE ${CMAKE_TUNE_FLAGS})
target_compile_options(lmp PRIVATE ${CMAKE_TUNE_FLAGS})
########################################################################
# Basic system tests (standard libraries, headers, functions, types) #
########################################################################

1
cmake/Modules/Packages/KOKKOS.cmake
View File

@ -130,6 +130,7 @@ set(KOKKOS_PKG_SOURCES ${KOKKOS_PKG_SOURCES_DIR}/kokkos.cpp
${KOKKOS_PKG_SOURCES_DIR}/atom_vec_kokkos.cpp
${KOKKOS_PKG_SOURCES_DIR}/comm_kokkos.cpp
${KOKKOS_PKG_SOURCES_DIR}/comm_tiled_kokkos.cpp
${KOKKOS_PKG_SOURCES_DIR}/group_kokkos.cpp
${KOKKOS_PKG_SOURCES_DIR}/min_kokkos.cpp
${KOKKOS_PKG_SOURCES_DIR}/min_linesearch_kokkos.cpp
${KOKKOS_PKG_SOURCES_DIR}/neighbor_kokkos.cpp

9
doc/documentation_conventions.md
View File

@ -10,7 +10,7 @@ Last change: 2022-12-30
In fall 2019, the LAMMPS documentation file format has changed from a
home grown markup designed to generate HTML format files only, to
[reStructuredText](https://docutils.sourceforge.io/rst.html>. For a
[reStructuredText](https://docutils.sourceforge.io/rst.html>). For a
transition period all files in the old .txt format were transparently
converted to .rst and then processed. The `txt2rst tool` is still
included in the distribution to obtain an initial .rst file for legacy
@ -45,8 +45,7 @@ what kind of information and sections are needed.
## Formatting conventions
For headlines we try to follow the conventions posted here:
https://documentation-style-guide-sphinx.readthedocs.io/en/latest/style-guide.html#headings
For headlines we try to follow the conventions posted [here](https://documentation-style-guide-sphinx.readthedocs.io/en/latest/style-guide.html#headings).
It seems to be sufficient to have this consistent only within
any single file and it is not (yet) enforced strictly, but making
this globally consistent makes it easier to move sections around.
@ -64,7 +63,7 @@ Groups of shell commands or LAMMPS input script or C/C++/Python source
code should be typeset into a `.. code-block::` section. A syntax
highlighting extension for LAMMPS input scripts is provided, so `LAMMPS`
can be used to indicate the language in the code block in addition to
`bash`, `c`, `c++`, `console`, `csh`, `diff', `fortran`, `json`, `make`,
`bash`, `c`, `c++`, `console`, `csh`, `diff`, `fortran`, `json`, `make`,
`perl`, `powershell`, `python`, `sh`, or `tcl`, `text`, or `yaml`. When
no syntax style is indicated, no syntax highlighting is performed. When
typesetting commands executed on the shell, please do not prefix
@ -84,7 +83,7 @@ block can be used, followed by multiple `.. tab::` blocks, one
for each alternative. This is only used for HTML output. For other
outputs, the `.. tabs::` directive is transparently removed and
the individual `.. tab::` blocks will be replaced with an
`.. admonition::`` block. Thus in PDF and ePUB output those will
`.. admonition::` block. Thus in PDF and ePUB output those will
be realized as sequential and plain notes.
Special remarks can be highlighted with a `.. note::` block and

15
doc/github-development-workflow.md
View File

@ -6,7 +6,9 @@ choices the LAMMPS developers have agreed on. Git and GitHub provide the
tools, but do not set policies, so it is up to the developers to come to
an agreement as to how to define and interpret policies. This document
is likely to change as our experiences and needs change, and we try to
adapt it accordingly. Last change 2023-02-10.
adapt it accordingly.
Last change: 2023-02-10
## Table of Contents
@ -72,7 +74,7 @@ be assigned to signal urgency to merge this pull request quickly.
People can be assigned to review a pull request in two ways:
* They can be assigned manually to review a pull request
by the submitter or a LAMMPS developer
by the submitter or a LAMMPS developer.
* They can be automatically assigned, because a developer's GitHub
handle matches a file pattern in the `.github/CODEOWNERS` file,
which associates developers with the code they contributed and
@ -86,9 +88,9 @@ required before merging, in addition to passing all automated
compilation and unit tests. Merging counts as implicit approval, so
does submission of a pull request (by a LAMMPS developer). So the person
doing the merge may not also submit an approving review. The GitHub
feature, that reviews from code owners are "hard" reviews (i.e. they
must all approve before merging is allowed), is currently disabled.
It is in the discretion of the merge maintainer to assess when a
feature that reviews from code owners are "hard" reviews (i.e. they
must all approve before merging is allowed) is currently disabled.
It is at the discretion of the merge maintainer to assess when a
sufficient degree of approval has been reached, especially from external
collaborators. Reviews may be (automatically) dismissed, when the
reviewed code has been changed. Review may be requested a second time.
@ -147,7 +149,8 @@ only contain bug fixes, feature additions to peripheral functionality,
and documentation updates. In between stable releases, bug fixes and
infrastructure updates are back-ported from the "develop" branch to the
"maintenance" branch and occasionally merged into "stable" and published
as update releases.
as update releases. Further explanation of LAMMPS versions can be found
[in the documentation](https://docs.lammps.org/Manual_version.html).
## Project Management

4
doc/lammps.1
View File

@ -1,7 +1,7 @@
.TH LAMMPS "1" "29 August 2024" "2024-08-29"
.TH LAMMPS "1" "19 November 2024" "2024-11-19"
.SH NAME
.B LAMMPS
\- Molecular Dynamics Simulator. Version 29 August 2024
\- Molecular Dynamics Simulator. Version 19 November 2024
.SH SYNOPSIS
.B lmp

9
doc/src/Commands_fix.rst
View File

@ -43,7 +43,7 @@ OPT.
* :doc:`brownian/asphere <fix_brownian>`
* :doc:`brownian/sphere <fix_brownian>`
* :doc:`charge/regulation <fix_charge_regulation>`
* :doc:`cmap <fix_cmap>`
* :doc:`cmap (k) <fix_cmap>`
* :doc:`colvars <fix_colvars>`
* :doc:`controller <fix_controller>`
* :doc:`damping/cundall <fix_damping_cundall>`
@ -134,7 +134,7 @@ OPT.
* :doc:`nve/dot <fix_nve_dot>`
* :doc:`nve/dotc/langevin <fix_nve_dotc_langevin>`
* :doc:`nve/eff <fix_nve_eff>`
* :doc:`nve/limit <fix_nve_limit>`
* :doc:`nve/limit (k) <fix_nve_limit>`
* :doc:`nve/line <fix_nve_line>`
* :doc:`nve/manifold/rattle <fix_nve_manifold_rattle>`
* :doc:`nve/noforce <fix_nve_noforce>`
@ -187,10 +187,11 @@ OPT.
* :doc:`qeq/slater <fix_qeq>`
* :doc:`qmmm <fix_qmmm>`
* :doc:`qtb <fix_qtb>`
* :doc:`qtpie/reaxff <fix_qtpie_reaxff>`
* :doc:`rattle <fix_shake>`
* :doc:`reaxff/bonds (k) <fix_reaxff_bonds>`
* :doc:`reaxff/species (k) <fix_reaxff_species>`
* :doc:`recenter <fix_recenter>`
* :doc:`recenter (k) <fix_recenter>`
* :doc:`restrain <fix_restrain>`
* :doc:`rheo <fix_rheo>`
* :doc:`rheo/oxidation <fix_rheo_oxidation>`
@ -268,7 +269,7 @@ OPT.
* :doc:`wall/piston <fix_wall_piston>`
* :doc:`wall/reflect (k) <fix_wall_reflect>`
* :doc:`wall/reflect/stochastic <fix_wall_reflect_stochastic>`
* :doc:`wall/region <fix_wall_region>`
* :doc:`wall/region (k) <fix_wall_region>`
* :doc:`wall/region/ees <fix_wall_ees>`
* :doc:`wall/srd <fix_wall_srd>`
* :doc:`wall/table <fix_wall>`

1
doc/src/fix.rst
View File

@ -366,6 +366,7 @@ accelerated styles exist.
* :doc:`qeq/slater <fix_qeq>` - charge equilibration via Slater method
* :doc:`qmmm <fix_qmmm>` - functionality to enable a quantum mechanics/molecular mechanics coupling
* :doc:`qtb <fix_qtb>` - implement quantum thermal bath scheme
* :doc:`qtpie/reaxff <fix_qtpie_reaxff>` - apply QTPIE charge equilibration
* :doc:`rattle <fix_shake>` - RATTLE constraints on bonds and/or angles
* :doc:`reaxff/bonds <fix_reaxff_bonds>` - write out ReaxFF bond information
* :doc:`reaxff/species <fix_reaxff_species>` - write out ReaxFF molecule information

6
doc/src/fix_acks2_reaxff.rst
View File

@ -111,7 +111,8 @@ LAMMPS was built with that package. See the :doc:`Build package
This fix does not correctly handle interactions involving multiple
periodic images of the same atom. Hence, it should not be used for
periodic cell dimensions less than :math:`10~\AA`.
periodic cell dimensions smaller than the non-bonded cutoff radius,
which is typically :math:`10~\AA` for ReaxFF simulations.
This fix may be used in combination with :doc:`fix efield <fix_efield>`
and will apply the external electric field during charge equilibration,
@ -122,7 +123,8 @@ components in non-periodic directions.
Related commands
""""""""""""""""
:doc:`pair_style reaxff <pair_reaxff>`, :doc:`fix qeq/reaxff <fix_qeq_reaxff>`
:doc:`pair_style reaxff <pair_reaxff>`, :doc:`fix qeq/reaxff <fix_qeq_reaxff>`,
:doc:`fix qtpi/reaxff <fix_qtpie_reaxff>`
Default
"""""""

8
doc/src/fix_adapt.rst
View File

@ -119,6 +119,14 @@ style supports it. Note that the :doc:`pair_style <pair_style>` and
to specify these parameters initially; the fix adapt command simply
overrides the parameters.
.. note::
Pair_coeff settings must be made **explicitly** in order for fix
adapt to be able to change them. Settings inferred from mixing
are not suitable. If necessary all mixed settings can be output
to a file using the :doc:`write_coeff command <write_coeff>` and
then the desired mixed pair_coeff settings copied from that file.
The *pstyle* argument is the name of the pair style. If
:doc:`pair_style hybrid or hybrid/overlay <pair_hybrid>` is used,
*pstyle* should be a sub-style name. If there are multiple

22
doc/src/fix_adapt_fep.rst
View File

@ -116,12 +116,22 @@ style supports it. Note that the :doc:`pair_style <pair_style>` and
to specify these parameters initially; the fix adapt command simply
overrides the parameters.
The *pstyle* argument is the name of the pair style. If :doc:`pair_style hybrid or hybrid/overlay <pair_hybrid>` is used, *pstyle* should be
a sub-style name. For example, *pstyle* could be specified as "soft"
or "lubricate". The *pparam* argument is the name of the parameter to
change. This is the current list of pair styles and parameters that
can be varied by this fix. See the doc pages for individual pair
styles and their energy formulas for the meaning of these parameters:
.. note::
Pair_coeff settings must be made **explicitly** in order for fix
adapt/fep to be able to change them. Settings inferred from mixing
are not suitable. If necessary all mixed settings can be output
to a file using the :doc:`write_coeff command <write_coeff>` and
then the desired mixed pair_coeff settings copied from that file.
The *pstyle* argument is the name of the pair style. If
:doc:`pair_style hybrid or hybrid/overlay <pair_hybrid>` is used,
*pstyle* should be a sub-style name. For example, *pstyle* could be
specified as "soft" or "lubricate". The *pparam* argument is the name
of the parameter to change. This is the current list of pair styles and
parameters that can be varied by this fix. See the doc pages for
individual pair styles and their energy formulas for the meaning of
these parameters:
+------------------------------------------------------------------------------+-------------------------+------------+
| :doc:`born <pair_born>` | a,b,c | type pairs |

9
doc/src/fix_cmap.rst
View File

@ -1,8 +1,11 @@
.. index:: fix cmap
.. index:: fix cmap/kk
fix cmap command
================
Accelerator Variants: *cmap/kk*
Syntax
""""""
@ -141,6 +144,12 @@ outermost level.
MUST not disable the :doc:`fix_modify <fix_modify>` *energy* option
for this fix.
----------
.. include:: accel_styles.rst
----------
Restrictions
""""""""""""

13
doc/src/fix_colvars.rst
View File

@ -1,8 +1,11 @@
.. index:: fix colvars
.. index:: fix colvars/kk
fix colvars command
===================
Accelerator Variants: *colvars/kk*
Syntax
""""""
@ -118,6 +121,16 @@ thermostat target temperature.
The *seed* keyword contains the seed for the random number generator
that will be used in the colvars module.
----------
.. note::
Fix colvars/kk is not really ported to KOKKOS, since the colvars
library has not been ported to KOKKOS. It merely has some
optimizations to reduce the data transfers between host and device
for KOKKOS with GPUs.
----------
Restarting
""""""""""

9
doc/src/fix_nve_limit.rst
View File

@ -1,8 +1,11 @@
.. index:: fix nve/limit
.. index:: fix nve/limit/kk
fix nve/limit command
=====================
Accelerator Variants: *nve/limit/kk*
Syntax
""""""
@ -79,6 +82,12 @@ is "extensive".
No parameter of this fix can be used with the *start/stop* keywords of
the :doc:`run <run>` command. This fix is not invoked during :doc:`energy minimization <minimize>`.
----------
.. include:: accel_styles.rst
----------
Restrictions
""""""""""""
none

2
doc/src/fix_qeq.rst
View File

@ -190,7 +190,7 @@ on atoms via the matrix inversion method. A tolerance of 1.0e-6 is
usually a good number. Keyword *alpha* can be used to change the Slater
type orbital exponent.
.. versionadded:: TBD
.. versionadded:: 19Nov2024
The *qeq/ctip* style describes partial charges on atoms in the same way
as style *qeq/shielded* but also enables the definition of charge

6
doc/src/fix_qeq_reaxff.rst
View File

@ -124,7 +124,8 @@ LAMMPS was built with that package. See the :doc:`Build package
This fix does not correctly handle interactions involving multiple
periodic images of the same atom. Hence, it should not be used for
periodic cell dimensions less than 10 Angstroms.
periodic cell dimensions smaller than the non-bonded cutoff radius,
which is typically :math:`10~\AA` for ReaxFF simulations.
This fix may be used in combination with :doc:`fix efield <fix_efield>`
and will apply the external electric field during charge equilibration,
@ -138,7 +139,8 @@ as an atom-style variable using the *potential* keyword for `fix efield`.
Related commands
""""""""""""""""
:doc:`pair_style reaxff <pair_reaxff>`, :doc:`fix qeq/shielded <fix_qeq>`
:doc:`pair_style reaxff <pair_reaxff>`, :doc:`fix qeq/shielded <fix_qeq>`,
:doc:`fix acks2/reaxff <fix_acks2_reaxff>`, :doc:`fix qtpie/reaxff <fix_qtpie_reaxff>`
Default
"""""""

200
doc/src/fix_qtpie_reaxff.rst Normal file
View File

@ -0,0 +1,200 @@
.. index:: fix qtpie/reaxff
fix qtpie/reaxff command
========================
Syntax
""""""
.. code-block:: LAMMPS
fix ID group-ID qtpie/reaxff Nevery cutlo cuthi tolerance params gfile args
* ID, group-ID are documented in :doc:`fix <fix>` command
* qtpie/reaxff = style name of this fix command
* Nevery = perform QTPIE every this many steps
* cutlo,cuthi = lo and hi cutoff for Taper radius
* tolerance = precision to which charges will be equilibrated
* params = reaxff or a filename
* gfile = the name of a file containing Gaussian orbital exponents
* one or more keywords or keyword/value pairs may be appended
.. parsed-literal::
keyword = *maxiter*
*maxiter* N = limit the number of iterations to *N*
Examples
""""""""
.. code-block:: LAMMPS
fix 1 all qtpie/reaxff 1 0.0 10.0 1.0e-6 reaxff exp.qtpie
fix 1 all qtpie/reaxff 1 0.0 10.0 1.0e-6 params.qtpie exp.qtpie maxiter 500
Description
"""""""""""
.. versionadded:: 19Nov2024
The QTPIE charge equilibration method is an extension of the QEq charge
equilibration method. With QTPIE, the partial charges on individual atoms
are computed by minimizing the electrostatic energy of the system in the
same way as the QEq method but where the absolute electronegativity,
:math:`\chi_i`, of each atom in the QEq charge equilibration scheme
:ref:`(Rappe and Goddard) <Rappe3>` is replaced with an effective
electronegativity given by :ref:`(Chen) <qtpie-Chen>`
.. math::
\chi_{\mathrm{eff},i} = \frac{\sum_{j=1}^{N} (\chi_i - \chi_j) S_{ij}}
{\sum_{m=1}^{N}S_{im}},
which acts to penalize long-range charge transfer seen with the QEq charge
equilibration scheme. In this equation, :math:`N` is the number of atoms in
the system and :math:`S_{ij}` is the overlap integral between atom :math:`i`
and atom :math:`j`.
The effect of an external electric field can be incorporated into the QTPIE
method by modifying the absolute or effective electronegativities of each
atom :ref:`(Chen) <qtpie-Chen>`. This fix models the effect of an external
electric field by using the effective electronegativity given in
:ref:`(Gergs) <Gergs>`:
.. math::
\chi_{\mathrm{eff},i} = \frac{\sum_{j=1}^{N} (\chi_i - \chi_j + \phi_i - \phi_j) S_{ij}}
{\sum_{m=1}^{N}S_{im}},
where :math:`\phi_i` and :math:`\phi_j` are the electric
potentials at the positions of atom :math:`i` and :math:`j`
due to the external electric field.
This fix is typically used in conjunction with the ReaxFF force
field model as implemented in the :doc:`pair_style reaxff <pair_reaxff>`
command, but it can be used with any potential in LAMMPS, so long as it
defines and uses charges on each atom. For more technical details about the
charge equilibration performed by `fix qtpie/reaxff`, which is the same as in
:doc:`fix qeq/reaxff <fix_qeq_reaxff>` except for the use of
:math:`\chi_{\mathrm{eff},i}`, please refer to :ref:`(Aktulga) <qeq-Aktulga2>`.
To be explicit, this fix replaces :math:`\chi_k` of eq. 3 in
:ref:`(Aktulga) <qeq-Aktulga2>` with :math:`\chi_{\mathrm{eff},k}`.
This fix requires the absolute electronegativity, :math:`\chi`, in eV, the
self-Coulomb potential, :math:`\eta`, in eV, and the shielded Coulomb
constant, :math:`\gamma`, in :math:`\AA^{-1}`. If the *params* setting above
is the word "reaxff", then these are extracted from the
:doc:`pair_style reaxff <pair_reaxff>` command and the ReaxFF force field
file it reads in. If a file name is specified for *params*, then the
parameters are taken from the specified file and the file must contain
one line for each atom type. The latter form must be used when performing
QTPIE with a non-ReaxFF potential. Each line should be formatted as follows,
ensuring that the parameters are given in units of eV, eV, and :math:`\AA^{-1}`,
respectively:
.. parsed-literal::
itype chi eta gamma
where *itype* is the atom type from 1 to Ntypes. Note that eta is
defined here as twice the eta value in the ReaxFF file.
The overlap integrals in the equation for :math:`\chi_{\mathrm{eff},i}`
are computed by using normalized 1s Gaussian type orbitals. The Gaussian
orbital exponents, :math:`\alpha`, that are needed to compute the overlap
integrals are taken from the file given by *gfile*.
This file must contain one line for each atom type and provide the Gaussian
orbital exponent for each atom type in units of inverse square Bohr radius.
Each line should be formatted as follows:
.. parsed-literal::
itype alpha
Empty lines or any text following the pound sign (#) are ignored. An example
*gfile* for a system with two atom types is
.. parsed-literal::
# An example gfile. Exponents are taken from Table 2.2 of Chen, J. (2009).
# Theory and applications of fluctuating-charge models.
# The units of the exponents are 1 / (Bohr radius)^2 .
1 0.2240 # O
2 0.5434 # H
The optional *maxiter* keyword allows changing the max number
of iterations in the linear solver. The default value is 200.
.. note::
In order to solve the self-consistent equations for electronegativity
equalization, LAMMPS imposes the additional constraint that all the
charges in the fix group must add up to zero. The initial charge
assignments should also satisfy this constraint. LAMMPS will print a
warning if that is not the case.
Restart, fix_modify, output, run start/stop, minimize info
"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
No information about this fix is written to :doc:`binary restart files
<restart>`. This fix computes a global scalar (the number of
iterations) and a per-atom vector (the effective electronegativity), which
can be accessed by various :doc:`output commands <Howto_output>`.
No parameter of this fix can be used with the *start/stop* keywords of
the :doc:`run <run>` command.
This fix is invoked during :doc:`energy minimization <minimize>`.
Restrictions
""""""""""""
This fix is part of the REAXFF package. It is only enabled if
LAMMPS was built with that package. See the :doc:`Build package
<Build_package>` page for more info.
This fix does not correctly handle interactions involving multiple
periodic images of the same atom. Hence, it should not be used for
periodic cell dimensions smaller than the non-bonded cutoff radius,
which is typically :math:`10~\AA` for ReaxFF simulations.
This fix may be used in combination with :doc:`fix efield <fix_efield>`
and will apply the external electric field during charge equilibration,
but there may be only one fix efield instance used and the electric field
must be applied to all atoms in the system. Consequently, `fix efield` must
be used with *group-ID* all and must not be used with the keyword *region*.
Equal-style variables can be used for electric field vector
components without any further settings. Atom-style variables can be used
for spatially-varying electric field vector components, but the resulting
electric potential must be specified as an atom-style variable using
the *potential* keyword for `fix efield`.
Related commands
""""""""""""""""
:doc:`pair_style reaxff <pair_reaxff>`, :doc:`fix qeq/reaxff <fix_qeq_reaxff>`,
:doc:`fix acks2/reaxff <fix_acks2_reaxff>`
Default
"""""""
maxiter 200
----------
.. _Rappe3:
**(Rappe)** Rappe and Goddard III, Journal of Physical Chemistry, 95,
3358-3363 (1991).
.. _qtpie-Chen:
**(Chen)** Chen, Jiahao. Theory and applications of fluctuating-charge models.
University of Illinois at Urbana-Champaign, 2009.
.. _Gergs:
**(Gergs)** Gergs, Dirkmann and Mussenbrock.
Journal of Applied Physics 123.24 (2018).
.. _qeq-Aktulga2:
**(Aktulga)** Aktulga, Fogarty, Pandit, Grama, Parallel Computing, 38,
245-259 (2012).

9
doc/src/fix_recenter.rst
View File

@ -1,8 +1,11 @@
.. index:: fix recenter
.. index:: fix recenter/kk
fix recenter command
====================
Accelerator Variants: *recenter/kk*
Syntax
""""""
@ -113,6 +116,12 @@ The scalar and vector values calculated by this fix are "extensive".
No parameter of this fix can be used with the *start/stop* keywords of
the :doc:`run <run>` command. This fix is not invoked during :doc:`energy minimization <minimize>`.
----------
.. include:: accel_styles.rst
----------
Restrictions
""""""""""""

23
doc/src/fix_spring_self.rst
View File

@ -13,7 +13,7 @@ Syntax
* ID, group-ID are documented in :doc:`fix <fix>` command
* spring/self = style name of this fix command
* K = spring constant (force/distance units)
* K = spring constant (force/distance units), can be a variable (see below)
* dir = xyz, xy, xz, yz, x, y, or z (optional, default: xyz)
Examples
@ -22,6 +22,7 @@ Examples
.. code-block:: LAMMPS
fix tether boundary-atoms spring/self 10.0
fix var all spring/self v_kvar
fix zrest move spring/self 10.0 z
Description
@ -42,6 +43,22 @@ directions, but it can be limited to the xy-, xz-, yz-plane and the
x-, y-, or z-direction, thus restraining the atoms to a line or a
plane, respectively.
The force constant *k* can be specified as an equal-style or atom-style
:doc:`variable <variable>`. If the value is a variable, it should be specified
as v_name, where name is the variable name. In this case, the variable
will be evaluated each time step, and its value(s) will be used as
force constant for the spring force.
Equal-style variables can specify formulas with various mathematical
functions and include :doc:`thermo_style <thermo_style>` command
keywords for the simulation box parameters, time step, and elapsed time.
Thus, it is easy to specify a time-dependent force field.
Atom-style variables can specify the same formulas as equal-style
variables but can also include per-atom values, such as atom
coordinates. Thus, it is easy to specify a spatially-dependent force
field with optional time-dependence as well.
Restart, fix_modify, output, run start/stop, minimize info
"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
@ -89,7 +106,9 @@ invoked by the :doc:`minimize <minimize>` command.
Restrictions
""""""""""""
none
The KOKKOS version, *fix spring/self/kk* may only be used with a constant
value of K, not a variable.
Related commands
""""""""""""""""

9
doc/src/fix_wall_region.rst
View File

@ -1,8 +1,11 @@
.. index:: fix wall/region
.. index:: fix wall/region/kk
fix wall/region command
=======================
Accelerator Variants: *wall/region/kk*
Syntax
""""""
@ -234,6 +237,12 @@ invoked by the :doc:`minimize <minimize>` command.
minimized), you MUST enable the :doc:`fix_modify <fix_modify>`
*energy* option for this fix.
----------
.. include:: accel_styles.rst
----------
Restrictions
""""""""""""
none

2
doc/src/pair_coul.rst
View File

@ -180,7 +180,7 @@ coulomb styles in :doc:`hybrid pair styles <pair_hybrid>`.
----------
.. versionadded:: TBD
.. versionadded:: 19Nov2024
Style *coul/ctip* computes the Coulomb interactions as described in
:ref:`Plummer <Plummer1>`. It uses the the damped shifted model as in

26
doc/src/pair_reaxff.rst
View File

@ -20,7 +20,7 @@ Syntax
.. parsed-literal::
keyword = *checkqeq* or *lgvdw* or *safezone* or *mincap* or *minhbonds* or *tabulate* or *list/blocking*
*checkqeq* value = *yes* or *no* = whether or not to require qeq/reaxff or acks2/reaxff fix
*checkqeq* value = *yes* or *no* = whether or not to require one of fix qeq/reaxff, fix acks2/reaxff or fix qtpie/reaxff
*enobonds* value = *yes* or *no* = whether or not to tally energy of atoms with no bonds
*lgvdw* value = *yes* or *no* = whether or not to use a low gradient vdW correction
*safezone* = factor used for array allocation
@ -120,20 +120,22 @@ up that process.
The ReaxFF parameter files provided were created using a charge
equilibration (QEq) model for handling the electrostatic interactions.
Therefore, by default, LAMMPS requires that either the
:doc:`fix qeq/reaxff <fix_qeq_reaxff>` or the
:doc:`fix qeq/shielded <fix_qeq>` or :doc:`fix acks2/reaxff <fix_acks2_reaxff>`
command be used with
*pair_style reaxff* when simulating a ReaxFF model, to equilibrate
the charges each timestep.
Therefore, by default, LAMMPS requires that
:doc:`fix qeq/reaxff <fix_qeq_reaxff>` or :doc:`fix qeq/shielded <fix_qeq>`
or :doc:`fix acks2/reaxff <fix_acks2_reaxff>`
or :doc:`fix qtpie/reaxff <fix_qtpie_reaxff>`
is used with *pair_style reaxff* when simulating a ReaxFF model,
to equilibrate the charges at each timestep.
See the :doc:`fix qeq/reaxff <fix_qeq_reaxff>` or :doc:`fix qeq/shielded <fix_qeq>`
or :doc:`fix acks2/reaxff <fix_acks2_reaxff>`
or :doc:`fix qtpie/reaxff <fix_qtpie_reaxff>`
command documentation for more details.
Using the keyword *checkqeq* with the value *no* turns off the check
for the QEq fixes, allowing a simulation to be run without charge
equilibration. In this case, the static charges you assign to each
atom will be used for computing the electrostatic interactions in
the system. See the :doc:`fix qeq/reaxff <fix_qeq_reaxff>` or
:doc:`fix qeq/shielded <fix_qeq>` or :doc:`fix acks2/reaxff <fix_acks2_reaxff>`
command documentation for more details.
the system.
Using the optional keyword *lgvdw* with the value *yes* turns on the
low-gradient correction of ReaxFF for long-range London Dispersion,
@ -372,8 +374,8 @@ Related commands
""""""""""""""""
:doc:`pair_coeff <pair_coeff>`, :doc:`fix qeq/reaxff <fix_qeq_reaxff>`,
:doc:`fix acks2/reaxff <fix_acks2_reaxff>`, :doc:`fix reaxff/bonds <fix_reaxff_bonds>`,
:doc:`fix reaxff/species <fix_reaxff_species>`,
:doc:`fix acks2/reaxff <fix_acks2_reaxff>`, :doc:`fix qtpie/reaxff <fix_qtpie_reaxff>`,
:doc:`fix reaxff/bonds <fix_reaxff_bonds>`, :doc:`fix reaxff/species <fix_reaxff_species>`,
:doc:`compute reaxff/atom <compute_reaxff_atom>`
Default

8
doc/src/region.rst
View File

@ -3,6 +3,8 @@
region command
==============
Accelerator Variants: *block/kk*, *sphere/kk*
Syntax
""""""
@ -74,7 +76,7 @@ Syntax
Rx,Ry,Rz = axis of rotation vector
*open* value = integer from 1-6 corresponding to face index (see below)
* accelerated styles (with same args) = *block/kk*
* accelerated styles (with same args) = *block/kk, sphere/kk*
Examples
""""""""
@ -401,9 +403,9 @@ sub-regions can be defined with the *open* keyword.
.. note::
Currently, only *block* style regions are supported by Kokkos. The
Currently, only *block* and *sphere* style regions are supported by KOKKOS. The
code using the region (such as a fix or compute) must also be
supported by Kokkos or no acceleration will occur.
supported by KOKKOS or no acceleration will occur.
----------

9
doc/utils/check-styles.py
View File

@ -73,8 +73,6 @@ omp = re.compile("(.+)/omp\\s*$")
opt = re.compile("(.+)/opt\\s*$")
removed = re.compile("(.*)Deprecated$")
accel_pattern = re.compile(r"^.. include::\s+accel_styles.rst$")
def require_accel_include(path):
found = False
needs = False
@ -94,6 +92,7 @@ def require_accel_include(path):
if kokkos.match(line): needs = True
if intel.match(line): needs = True
if opt.match(line): needs = True
if path == "src/fix_colvars.rst": needs = False
m = cmd_pattern.match(line)
if m:
if gpu.match(line): needs = True
@ -167,7 +166,9 @@ def check_style(filename, dirname, pattern, styles, name, suffix=False, skip=set
# known undocumented aliases we need to skip
if c in skip: continue
s = c
if suffix: s = add_suffix(styles, c)
if suffix:
s = add_suffix(styles, c)
if s == 'colvars (k)' : continue
if not s in matches:
if not styles[c]['removed']:
print(f"{name} style entry {s} is missing or incomplete in {filename}")
@ -300,7 +301,7 @@ for command_type, entries in index.items():
print("Total number of style index entries:", total_index)
skip_angle = ('sdk')
skip_fix = ('python', 'NEIGH_HISTORY/omp','acks2/reax','qeq/reax','reax/c/bonds','reax/c/species', 'pimd')
skip_fix = ('python', 'NEIGH_HISTORY/omp','acks2/reax','qeq/reax','reax/c/bonds','reax/c/species', 'pimd', 'colvars/kk')
skip_pair = ('meam/c','lj/sf','reax/c','lj/sdk','lj/sdk/coul/long','lj/sdk/coul/msm')
skip_compute = ('pressure/cylinder')

8
doc/utils/sphinx-config/false_positives.txt
View File

@ -815,6 +815,7 @@ dipoleflag
dir
Direc
dirname
Dirkmann
discoverable
discretization
discretized
@ -976,6 +977,7 @@ elaplong
elastance
Electroneg
electronegative
electronegativities
electronegativity
electroneutral
electroneutrality
@ -1293,6 +1295,7 @@ Geocomputing
georg
Georg
Geotechnica
Gergs
germain
Germann
Germano
@ -1305,6 +1308,7 @@ gettimeofday
geturl
gewald
Gezelter
gfile
Gflop
gfortran
ghostneigh
@ -1712,6 +1716,7 @@ Jewett
jgissing
ji
Jiang
Jiahao
Jiao
jik
JIK
@ -2366,6 +2371,7 @@ mui
Mukherjee
Mulders
Müller
Mulliken
mult
multi
multibody
@ -2390,6 +2396,7 @@ Murdick
Murtola
Murty
Muser
Mussenbrock
mutexes
Muto
muVT
@ -3073,6 +3080,7 @@ qqr
qqrd
Qsb
qtb
qtpie
quadratically
quadrupolar
quadrupole

5
examples/reaxff/water/gauss_exp.txt Normal file
View File

@ -0,0 +1,5 @@
# Gaussian orbital exponents (required for fix qtpie/reaxff) taken from Table 2.2
# of Chen, J. (2009). Theory and applications of fluctuating-charge models.
# The units of the exponents are 1 / (Bohr radius)^2 .
1 0.2240 # O
2 0.5434 # H

29
examples/reaxff/water/in.water.qtpie Normal file
View File

@ -0,0 +1,29 @@
# QTPIE Water
boundary p p p
units real
atom_style charge
read_data data.water
variable x index 1
variable y index 1
variable z index 1
replicate $x $y $z
pair_style reaxff NULL safezone 3.0 mincap 150
pair_coeff * * qeq_ff.water O H
neighbor 0.5 bin
neigh_modify every 1 delay 0 check yes
velocity all create 300.0 4928459 rot yes dist gaussian
fix 1 all qtpie/reaxff 1 0.0 10.0 1.0e-6 reaxff gauss_exp.txt
fix 2 all nvt temp 300 300 50.0
timestep 0.5
thermo 10
thermo_style custom step temp press density vol
run 20

30
examples/reaxff/water/in.water.qtpie.field Normal file
View File

@ -0,0 +1,30 @@
# QTPIE Water
boundary p p p
units real
atom_style charge
read_data data.water
variable x index 1
variable y index 1
variable z index 1
replicate $x $y $z
pair_style reaxff NULL safezone 3.0 mincap 150
pair_coeff * * qeq_ff.water O H
neighbor 0.5 bin
neigh_modify every 1 delay 0 check yes
velocity all create 300.0 4928459 rot yes dist gaussian
fix 1 all qtpie/reaxff 1 0.0 10.0 1.0e-6 reaxff gauss_exp.txt
fix 2 all nvt temp 300 300 50.0
fix 3 all efield 0.0 0.0 0.05
timestep 0.5
thermo 10
thermo_style custom step temp press density vol
run 20

127
examples/reaxff/water/log.29Aug24.reaxff.water-qtpie-field.g++.1 Normal file
View File

@ -0,0 +1,127 @@
LAMMPS (29 Aug 2024 - Development - patch_29Aug2024-76-g3f232caf9b)
using 1 OpenMP thread(s) per MPI task
# QTPIE Water
boundary p p p
units real
atom_style charge
read_data data.water
Reading data file ...
orthogonal box = (0 0 0) to (31.043046 31.043046 31.043046)
1 by 1 by 1 MPI processor grid
reading atoms ...
3000 atoms
read_data CPU = 0.056 seconds
variable x index 1
variable y index 1
variable z index 1
replicate $x $y $z
replicate 1 $y $z
replicate 1 1 $z
replicate 1 1 1
Replication is creating a 1x1x1 = 1 times larger system...
orthogonal box = (0 0 0) to (31.043046 31.043046 31.043046)
1 by 1 by 1 MPI processor grid
3000 atoms
replicate CPU = 0.001 seconds
pair_style reaxff NULL safezone 3.0 mincap 150
pair_coeff * * qeq_ff.water O H
WARNING: Changed valency_val to valency_boc for X (src/REAXFF/reaxff_ffield.cpp:294)
neighbor 0.5 bin
neigh_modify every 1 delay 0 check yes
velocity all create 300.0 4928459 rot yes dist gaussian
fix 1 all qtpie/reaxff 1 0.0 10.0 1.0e-6 reaxff gauss_exp.txt
fix 2 all nvt temp 300 300 50.0
fix 3 all efield 0.0 0.0 0.05
timestep 0.5
thermo 10
thermo_style custom step temp press density vol
run 20
CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE
Your simulation uses code contributions which should be cited:
- Type Label Framework: https://doi.org/10.1021/acs.jpcb.3c08419
@Article{Gissinger24,
author = {Jacob R. Gissinger, Ilia Nikiforov, Yaser Afshar, Brendon Waters, Moon-ki Choi, Daniel S. Karls, Alexander Stukowski, Wonpil Im, Hendrik Heinz, Axel Kohlmeyer, and Ellad B. Tadmor},
title = {Type Label Framework for Bonded Force Fields in LAMMPS},
journal = {J. Phys. Chem. B},
year = 2024,
volume = 128,
number = 13,
pages = {3282–-3297}
}
- pair reaxff command: doi:10.1016/j.parco.2011.08.005
@Article{Aktulga12,
author = {H. M. Aktulga and J. C. Fogarty and S. A. Pandit and A. Y. Grama},
title = {Parallel Reactive Molecular Dynamics: {N}umerical Methods and Algorithmic Techniques},
journal = {Parallel Computing},
year = 2012,
volume = 38,
number = {4--5},
pages = {245--259}
}
CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE
Neighbor list info ...
update: every = 1 steps, delay = 0 steps, check = yes
max neighbors/atom: 2000, page size: 100000
master list distance cutoff = 10.5
ghost atom cutoff = 10.5
binsize = 5.25, bins = 6 6 6
2 neighbor lists, perpetual/occasional/extra = 2 0 0
(1) pair reaxff, perpetual
attributes: half, newton off, ghost
pair build: half/bin/ghost/newtoff
stencil: full/ghost/bin/3d
bin: standard
(2) fix qtpie/reaxff, perpetual, copy from (1)
attributes: half, newton off
pair build: copy
stencil: none
bin: none
Per MPI rank memory allocation (min/avg/max) = 539.2 | 539.2 | 539.2 Mbytes
Step Temp Press Density Volume
0 300 10137.041 1 29915.273
10 296.09128 3564.7969 1 29915.273
20 293.04308 10299.201 1 29915.273
Loop time of 10.7863 on 1 procs for 20 steps with 3000 atoms
Performance: 0.080 ns/day, 299.620 hours/ns, 1.854 timesteps/s, 5.563 katom-step/s
100.0% CPU use with 1 MPI tasks x 1 OpenMP threads
MPI task timing breakdown:
Section | min time | avg time | max time |%varavg| %total
---------------------------------------------------------------
Pair | 4.7275 | 4.7275 | 4.7275 | 0.0 | 43.83
Neigh | 0.17533 | 0.17533 | 0.17533 | 0.0 | 1.63
Comm | 0.0017376 | 0.0017376 | 0.0017376 | 0.0 | 0.02
Output | 8.2065e-05 | 8.2065e-05 | 8.2065e-05 | 0.0 | 0.00
Modify | 5.8812 | 5.8812 | 5.8812 | 0.0 | 54.52
Other | | 0.0005226 | | | 0.00
Nlocal: 3000 ave 3000 max 3000 min
Histogram: 1 0 0 0 0 0 0 0 0 0
Nghost: 11077 ave 11077 max 11077 min
Histogram: 1 0 0 0 0 0 0 0 0 0
Neighs: 971775 ave 971775 max 971775 min
Histogram: 1 0 0 0 0 0 0 0 0 0
Total # of neighbors = 971775
Ave neighs/atom = 323.925
Neighbor list builds = 2
Dangerous builds = 0
Total wall time: 0:00:12

127
examples/reaxff/water/log.29Aug24.reaxff.water-qtpie-field.g++.4 Normal file
View File

@ -0,0 +1,127 @@
LAMMPS (29 Aug 2024 - Development - patch_29Aug2024-76-g3f232caf9b)
using 1 OpenMP thread(s) per MPI task
# QTPIE Water
boundary p p p
units real
atom_style charge
read_data data.water
Reading data file ...
orthogonal box = (0 0 0) to (31.043046 31.043046 31.043046)
1 by 2 by 2 MPI processor grid
reading atoms ...
3000 atoms
read_data CPU = 0.053 seconds
variable x index 1
variable y index 1
variable z index 1
replicate $x $y $z
replicate 1 $y $z
replicate 1 1 $z
replicate 1 1 1
Replication is creating a 1x1x1 = 1 times larger system...
orthogonal box = (0 0 0) to (31.043046 31.043046 31.043046)
1 by 2 by 2 MPI processor grid
3000 atoms
replicate CPU = 0.002 seconds
pair_style reaxff NULL safezone 3.0 mincap 150
pair_coeff * * qeq_ff.water O H
WARNING: Changed valency_val to valency_boc for X (src/REAXFF/reaxff_ffield.cpp:294)
neighbor 0.5 bin
neigh_modify every 1 delay 0 check yes
velocity all create 300.0 4928459 rot yes dist gaussian
fix 1 all qtpie/reaxff 1 0.0 10.0 1.0e-6 reaxff gauss_exp.txt
fix 2 all nvt temp 300 300 50.0
fix 3 all efield 0.0 0.0 0.05
timestep 0.5
thermo 10
thermo_style custom step temp press density vol
run 20
CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE
Your simulation uses code contributions which should be cited:
- Type Label Framework: https://doi.org/10.1021/acs.jpcb.3c08419
@Article{Gissinger24,
author = {Jacob R. Gissinger, Ilia Nikiforov, Yaser Afshar, Brendon Waters, Moon-ki Choi, Daniel S. Karls, Alexander Stukowski, Wonpil Im, Hendrik Heinz, Axel Kohlmeyer, and Ellad B. Tadmor},
title = {Type Label Framework for Bonded Force Fields in LAMMPS},
journal = {J. Phys. Chem. B},
year = 2024,
volume = 128,
number = 13,
pages = {3282–-3297}
}
- pair reaxff command: doi:10.1016/j.parco.2011.08.005
@Article{Aktulga12,
author = {H. M. Aktulga and J. C. Fogarty and S. A. Pandit and A. Y. Grama},
title = {Parallel Reactive Molecular Dynamics: {N}umerical Methods and Algorithmic Techniques},
journal = {Parallel Computing},
year = 2012,
volume = 38,
number = {4--5},
pages = {245--259}
}
CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE
Neighbor list info ...
update: every = 1 steps, delay = 0 steps, check = yes
max neighbors/atom: 2000, page size: 100000
master list distance cutoff = 10.5
ghost atom cutoff = 10.5
binsize = 5.25, bins = 6 6 6
2 neighbor lists, perpetual/occasional/extra = 2 0 0
(1) pair reaxff, perpetual
attributes: half, newton off, ghost
pair build: half/bin/ghost/newtoff
stencil: full/ghost/bin/3d
bin: standard
(2) fix qtpie/reaxff, perpetual, copy from (1)
attributes: half, newton off
pair build: copy
stencil: none
bin: none
Per MPI rank memory allocation (min/avg/max) = 260.5 | 262.2 | 263.6 Mbytes
Step Temp Press Density Volume
0 300 10137.041 1 29915.273
10 296.09128 3564.7969 1 29915.273
20 293.04308 10299.201 1 29915.273
Loop time of 3.14492 on 4 procs for 20 steps with 3000 atoms
Performance: 0.275 ns/day, 87.359 hours/ns, 6.359 timesteps/s, 19.078 katom-step/s
99.6% CPU use with 4 MPI tasks x 1 OpenMP threads
MPI task timing breakdown:
Section | min time | avg time | max time |%varavg| %total
---------------------------------------------------------------
Pair | 1.6557 | 1.6847 | 1.7281 | 2.1 | 53.57
Neigh | 0.086503 | 0.086968 | 0.087627 | 0.2 | 2.77
Comm | 0.003309 | 0.046699 | 0.075729 | 12.4 | 1.48
Output | 5.0156e-05 | 5.483e-05 | 6.8111e-05 | 0.0 | 0.00
Modify | 1.3254 | 1.3261 | 1.3266 | 0.0 | 42.16
Other | | 0.0004552 | | | 0.01
Nlocal: 750 ave 760 max 735 min
Histogram: 1 0 0 0 1 0 0 0 0 2
Nghost: 6230.5 ave 6253 max 6193 min
Histogram: 1 0 0 0 0 0 1 0 1 1
Neighs: 276995 ave 280886 max 271360 min
Histogram: 1 0 0 0 1 0 0 0 1 1
Total # of neighbors = 1107981
Ave neighs/atom = 369.327
Neighbor list builds = 2
Dangerous builds = 0
Total wall time: 0:00:03

126
examples/reaxff/water/log.29Aug24.reaxff.water-qtpie.g++.1 Normal file
View File

@ -0,0 +1,126 @@
LAMMPS (29 Aug 2024 - Development - patch_29Aug2024-76-g3f232caf9b)
using 1 OpenMP thread(s) per MPI task
# QTPIE Water
boundary p p p
units real
atom_style charge
read_data data.water
Reading data file ...
orthogonal box = (0 0 0) to (31.043046 31.043046 31.043046)
1 by 1 by 1 MPI processor grid
reading atoms ...
3000 atoms
read_data CPU = 0.055 seconds
variable x index 1
variable y index 1
variable z index 1
replicate $x $y $z
replicate 1 $y $z
replicate 1 1 $z
replicate 1 1 1
Replication is creating a 1x1x1 = 1 times larger system...
orthogonal box = (0 0 0) to (31.043046 31.043046 31.043046)
1 by 1 by 1 MPI processor grid
3000 atoms
replicate CPU = 0.001 seconds
pair_style reaxff NULL safezone 3.0 mincap 150
pair_coeff * * qeq_ff.water O H
WARNING: Changed valency_val to valency_boc for X (src/REAXFF/reaxff_ffield.cpp:294)
neighbor 0.5 bin
neigh_modify every 1 delay 0 check yes
velocity all create 300.0 4928459 rot yes dist gaussian
fix 1 all qtpie/reaxff 1 0.0 10.0 1.0e-6 reaxff gauss_exp.txt
fix 2 all nvt temp 300 300 50.0
timestep 0.5
thermo 10
thermo_style custom step temp press density vol
run 20
CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE
Your simulation uses code contributions which should be cited:
- Type Label Framework: https://doi.org/10.1021/acs.jpcb.3c08419
@Article{Gissinger24,
author = {Jacob R. Gissinger, Ilia Nikiforov, Yaser Afshar, Brendon Waters, Moon-ki Choi, Daniel S. Karls, Alexander Stukowski, Wonpil Im, Hendrik Heinz, Axel Kohlmeyer, and Ellad B. Tadmor},
title = {Type Label Framework for Bonded Force Fields in LAMMPS},
journal = {J. Phys. Chem. B},
year = 2024,
volume = 128,
number = 13,
pages = {3282–-3297}
}
- pair reaxff command: doi:10.1016/j.parco.2011.08.005
@Article{Aktulga12,
author = {H. M. Aktulga and J. C. Fogarty and S. A. Pandit and A. Y. Grama},
title = {Parallel Reactive Molecular Dynamics: {N}umerical Methods and Algorithmic Techniques},
journal = {Parallel Computing},
year = 2012,
volume = 38,
number = {4--5},
pages = {245--259}
}
CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE
Neighbor list info ...
update: every = 1 steps, delay = 0 steps, check = yes
max neighbors/atom: 2000, page size: 100000
master list distance cutoff = 10.5
ghost atom cutoff = 10.5
binsize = 5.25, bins = 6 6 6
2 neighbor lists, perpetual/occasional/extra = 2 0 0
(1) pair reaxff, perpetual
attributes: half, newton off, ghost
pair build: half/bin/ghost/newtoff
stencil: full/ghost/bin/3d
bin: standard
(2) fix qtpie/reaxff, perpetual, copy from (1)
attributes: half, newton off
pair build: copy
stencil: none
bin: none
Per MPI rank memory allocation (min/avg/max) = 539.2 | 539.2 | 539.2 Mbytes
Step Temp Press Density Volume
0 300 10138.375 1 29915.273
10 295.97879 3575.2769 1 29915.273
20 292.76583 10309.128 1 29915.273
Loop time of 10.8138 on 1 procs for 20 steps with 3000 atoms
Performance: 0.080 ns/day, 300.383 hours/ns, 1.849 timesteps/s, 5.548 katom-step/s
99.9% CPU use with 1 MPI tasks x 1 OpenMP threads
MPI task timing breakdown:
Section | min time | avg time | max time |%varavg| %total
---------------------------------------------------------------
Pair | 4.7177 | 4.7177 | 4.7177 | 0.0 | 43.63
Neigh | 0.17607 | 0.17607 | 0.17607 | 0.0 | 1.63
Comm | 0.0017295 | 0.0017295 | 0.0017295 | 0.0 | 0.02
Output | 8.5431e-05 | 8.5431e-05 | 8.5431e-05 | 0.0 | 0.00
Modify | 5.9177 | 5.9177 | 5.9177 | 0.0 | 54.72
Other | | 0.0004911 | | | 0.00
Nlocal: 3000 ave 3000 max 3000 min
Histogram: 1 0 0 0 0 0 0 0 0 0
Nghost: 11077 ave 11077 max 11077 min
Histogram: 1 0 0 0 0 0 0 0 0 0
Neighs: 971830 ave 971830 max 971830 min
Histogram: 1 0 0 0 0 0 0 0 0 0
Total # of neighbors = 971830
Ave neighs/atom = 323.94333
Neighbor list builds = 2
Dangerous builds = 0
Total wall time: 0:00:12

126
examples/reaxff/water/log.29Aug24.reaxff.water-qtpie.g++.4 Normal file
View File

@ -0,0 +1,126 @@
LAMMPS (29 Aug 2024 - Development - patch_29Aug2024-76-g3f232caf9b)
using 1 OpenMP thread(s) per MPI task
# QTPIE Water
boundary p p p
units real
atom_style charge
read_data data.water
Reading data file ...
orthogonal box = (0 0 0) to (31.043046 31.043046 31.043046)
1 by 2 by 2 MPI processor grid
reading atoms ...
3000 atoms
read_data CPU = 0.053 seconds
variable x index 1
variable y index 1
variable z index 1
replicate $x $y $z
replicate 1 $y $z
replicate 1 1 $z
replicate 1 1 1
Replication is creating a 1x1x1 = 1 times larger system...
orthogonal box = (0 0 0) to (31.043046 31.043046 31.043046)
1 by 2 by 2 MPI processor grid
3000 atoms
replicate CPU = 0.002 seconds
pair_style reaxff NULL safezone 3.0 mincap 150
pair_coeff * * qeq_ff.water O H
WARNING: Changed valency_val to valency_boc for X (src/REAXFF/reaxff_ffield.cpp:294)
neighbor 0.5 bin
neigh_modify every 1 delay 0 check yes
velocity all create 300.0 4928459 rot yes dist gaussian
fix 1 all qtpie/reaxff 1 0.0 10.0 1.0e-6 reaxff gauss_exp.txt
fix 2 all nvt temp 300 300 50.0
timestep 0.5
thermo 10
thermo_style custom step temp press density vol
run 20
CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE
Your simulation uses code contributions which should be cited:
- Type Label Framework: https://doi.org/10.1021/acs.jpcb.3c08419
@Article{Gissinger24,
author = {Jacob R. Gissinger, Ilia Nikiforov, Yaser Afshar, Brendon Waters, Moon-ki Choi, Daniel S. Karls, Alexander Stukowski, Wonpil Im, Hendrik Heinz, Axel Kohlmeyer, and Ellad B. Tadmor},
title = {Type Label Framework for Bonded Force Fields in LAMMPS},
journal = {J. Phys. Chem. B},
year = 2024,
volume = 128,
number = 13,
pages = {3282–-3297}
}
- pair reaxff command: doi:10.1016/j.parco.2011.08.005
@Article{Aktulga12,
author = {H. M. Aktulga and J. C. Fogarty and S. A. Pandit and A. Y. Grama},
title = {Parallel Reactive Molecular Dynamics: {N}umerical Methods and Algorithmic Techniques},
journal = {Parallel Computing},
year = 2012,
volume = 38,
number = {4--5},
pages = {245--259}
}
CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE
Neighbor list info ...
update: every = 1 steps, delay = 0 steps, check = yes
max neighbors/atom: 2000, page size: 100000
master list distance cutoff = 10.5
ghost atom cutoff = 10.5
binsize = 5.25, bins = 6 6 6
2 neighbor lists, perpetual/occasional/extra = 2 0 0
(1) pair reaxff, perpetual
attributes: half, newton off, ghost
pair build: half/bin/ghost/newtoff
stencil: full/ghost/bin/3d
bin: standard
(2) fix qtpie/reaxff, perpetual, copy from (1)
attributes: half, newton off
pair build: copy
stencil: none
bin: none
Per MPI rank memory allocation (min/avg/max) = 260.5 | 262.2 | 263.6 Mbytes
Step Temp Press Density Volume
0 300 10138.375 1 29915.273
10 295.97879 3575.2769 1 29915.273
20 292.76583 10309.128 1 29915.273
Loop time of 3.13598 on 4 procs for 20 steps with 3000 atoms
Performance: 0.276 ns/day, 87.111 hours/ns, 6.378 timesteps/s, 19.133 katom-step/s
99.6% CPU use with 4 MPI tasks x 1 OpenMP threads
MPI task timing breakdown:
Section | min time | avg time | max time |%varavg| %total
---------------------------------------------------------------
Pair | 1.6622 | 1.695 | 1.7252 | 2.2 | 54.05
Neigh | 0.086543 | 0.087117 | 0.087848 | 0.2 | 2.78
Comm | 0.0048192 | 0.035002 | 0.067754 | 15.4 | 1.12
Output | 4.8033e-05 | 5.3375e-05 | 6.6893e-05 | 0.0 | 0.00
Modify | 1.3176 | 1.3183 | 1.3189 | 0.0 | 42.04
Other | | 0.0004753 | | | 0.02
Nlocal: 750 ave 760 max 735 min
Histogram: 1 0 0 0 1 0 0 0 0 2
Nghost: 6229.5 ave 6253 max 6191 min
Histogram: 1 0 0 0 0 0 1 0 1 1
Neighs: 277011 ave 280900 max 271380 min
Histogram: 1 0 0 0 1 0 0 0 1 1
Total # of neighbors = 1108044
Ave neighs/atom = 369.348
Neighbor list builds = 2
Dangerous builds = 0
Total wall time: 0:00:03

40
examples/wall/in.wall.block Normal file
View File

@ -0,0 +1,40 @@
units real
molecule water tip3p.mol
atom_style full
variable radius equal 100.0
region box block $(-v_radius) $(v_radius) $(-v_radius) $(v_radius) $(-v_radius) $(v_radius)
create_box 2 box bond/types 1 angle/types 1 &
extra/bond/per/atom 2 extra/angle/per/atom 1 extra/special/per/atom 2
mass 1 15.9994
mass 2 1.008
bond_style zero
bond_coeff 1 0.9574
angle_style zero
angle_coeff 1 104.52
region block1 block -80 80 -80 80 -80 80
region block2 block -70 70 -70 70 -70 70
create_atoms 0 random 5000 12345 block2 mol water 12345 overlap 2
thermo 1
thermo_style custom step time spcpu temp press etotal pe
fix wall all wall/region block1 harmonic 1000.0 0.0 2.5
fix_modify wall energy yes
pair_style lj/cut/coul/cut 8.0
pair_coeff 1 1 0.1521 3.1507
pair_coeff 2 2 0.0 1.0
velocity all create 300.0 12345
fix 1 all nvt temp 300 300 100.0
fix 2 all shake 0.001 10 10000 b 1 a 1
dump 2 all movie 10 wall.block.mpg type type size 1500 1500 fsaa yes
dump_modify 2 pad 4 acolor * white/red/green/blue/aqua/magenta
run 100

40
examples/wall/in.wall.sphere Normal file
View File

@ -0,0 +1,40 @@
units real
molecule water tip3p.mol
atom_style full
variable radius equal 100.0
region box block $(-v_radius) $(v_radius) $(-v_radius) $(v_radius) $(-v_radius) $(v_radius)
create_box 2 box bond/types 1 angle/types 1 &
extra/bond/per/atom 2 extra/angle/per/atom 1 extra/special/per/atom 2
mass 1 15.9994
mass 2 1.008
bond_style zero
bond_coeff 1 0.9574
angle_style zero
angle_coeff 1 104.52
region sphere1 sphere 0 0 0 $(v_radius-10) side in
region sphere2 sphere 0 0 0 $(v_radius-20) side in
create_atoms 0 random 5000 12345 sphere2 mol water 12345 overlap 2
thermo 1
thermo_style custom step time spcpu temp press etotal pe
fix wall all wall/region sphere1 harmonic 1000.0 0.0 2.5
fix_modify wall energy yes
pair_style lj/cut/coul/cut 8.0
pair_coeff 1 1 0.1521 3.1507
pair_coeff 2 2 0.0 1.0
velocity all create 300.0 12345
fix 1 all nvt temp 300 300 100.0
fix 2 all shake 0.001 10 10000 b 1 a 1
dump 2 all movie 10 wall.sphere.mpg type type size 1500 1500 fsaa yes
dump_modify 2 pad 4 acolor * white/red/green/blue/aqua/magenta
run 100

62
examples/wall/tip3p.mol Normal file
View File

@ -0,0 +1,62 @@
# Water molecule. TIP3P geometry
3 atoms
2 bonds
1 angles
Coords
1 0.00000 -0.06556 0.00000
2 0.75695 0.52032 0.00000
3 -0.75695 0.52032 0.00000
Types
1 1
2 2
3 2
Charges
1 -0.834
2 0.417
3 0.417
Bonds
1 1 1 2
2 1 1 3
Angles
1 1 2 1 3
Shake Flags
1 1
2 1
3 1
Shake Atoms
1 1 2 3
2 1 2 3
3 1 2 3
Shake Bond Types
1 1 1 1
2 1 1 1
3 1 1 1
Special Bond Counts
1 2 0 0
2 1 1 0
3 1 1 0
Special Bonds
1 2 3
2 1 3
3 1 2

4
lib/gpu/lal_neighbor.cpp
View File

@ -365,7 +365,9 @@ void Neighbor::get_host(const int inum, int *ilist, int *numj,
int i=ilist[ii];
three_ilist[i] = ii;
}
three_ilist.update_device(inum,true);
// needs to transfer _max_atoms because three_ilist indexes all the atoms (local and ghost)
// not just inum (number of neighbor list items)
three_ilist.update_device(_max_atoms,true);
}
time_nbor.stop();

282
lib/linalg/dbdsdc.cpp Normal file
View File

@ -0,0 +1,282 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static integer c__9 = 9;
static integer c__0 = 0;
static doublereal c_b15 = 1.;
static integer c__1 = 1;
static doublereal c_b29 = 0.;
int dbdsdc_(char *uplo, char *compq, integer *n, doublereal *d__, doublereal *e, doublereal *u,
integer *ldu, doublereal *vt, integer *ldvt, doublereal *q, integer *iq,
doublereal *work, integer *iwork, integer *info, ftnlen uplo_len, ftnlen compq_len)
{
integer u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2;
doublereal d__1;
double d_lmp_sign(doublereal *, doublereal *), log(doublereal);
integer i__, j, k;
doublereal p, r__;
integer z__, ic, ii, kk;
doublereal cs;
integer is, iu;
doublereal sn;
integer nm1;
doublereal eps;
integer ivt, difl, difr, ierr, perm, mlvl, sqre;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern int dlasr_(char *, char *, char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, ftnlen, ftnlen, ftnlen),
dcopy_(integer *, doublereal *, integer *, doublereal *, integer *),
dswap_(integer *, doublereal *, integer *, doublereal *, integer *);
integer poles, iuplo, nsize, start;
extern int dlasd0_(integer *, integer *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *, integer *, integer *, doublereal *, integer *);
extern doublereal dlamch_(char *, ftnlen);
extern int dlasda_(integer *, integer *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
integer *),
dlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, integer *,
doublereal *, integer *, integer *, ftnlen),
dlasdq_(char *, integer *, integer *, integer *, integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, ftnlen),
dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *,
ftnlen),
dlartg_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
extern int xerbla_(char *, integer *, ftnlen);
integer givcol;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *, ftnlen);
integer icompq;
doublereal orgnrm;
integer givnum, givptr, qstart, smlsiz, wstart, smlszp;
--d__;
--e;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1;
vt -= vt_offset;
--q;
--iq;
--work;
--iwork;
*info = 0;
iuplo = 0;
if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) {
iuplo = 1;
}
if (lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) {
iuplo = 2;
}
if (lsame_(compq, (char *)"N", (ftnlen)1, (ftnlen)1)) {
icompq = 0;
} else if (lsame_(compq, (char *)"P", (ftnlen)1, (ftnlen)1)) {
icompq = 1;
} else if (lsame_(compq, (char *)"I", (ftnlen)1, (ftnlen)1)) {
icompq = 2;
} else {
icompq = -1;
}
if (iuplo == 0) {
*info = -1;
} else if (icompq < 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ldu < 1 || icompq == 2 && *ldu < *n) {
*info = -7;
} else if (*ldvt < 1 || icompq == 2 && *ldvt < *n) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"DBDSDC", &i__1, (ftnlen)6);
return 0;
}
if (*n == 0) {
return 0;
}
smlsiz = ilaenv_(&c__9, (char *)"DBDSDC", (char *)" ", &c__0, &c__0, &c__0, &c__0, (ftnlen)6, (ftnlen)1);
if (*n == 1) {
if (icompq == 1) {
q[1] = d_lmp_sign(&c_b15, &d__[1]);
q[smlsiz * *n + 1] = 1.;
} else if (icompq == 2) {
u[u_dim1 + 1] = d_lmp_sign(&c_b15, &d__[1]);
vt[vt_dim1 + 1] = 1.;
}
d__[1] = abs(d__[1]);
return 0;
}
nm1 = *n - 1;
wstart = 1;
qstart = 3;
if (icompq == 1) {
dcopy_(n, &d__[1], &c__1, &q[1], &c__1);
i__1 = *n - 1;
dcopy_(&i__1, &e[1], &c__1, &q[*n + 1], &c__1);
}
if (iuplo == 2) {
qstart = 5;
if (icompq == 2) {
wstart = (*n << 1) - 1;
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
d__[i__] = r__;
e[i__] = sn * d__[i__ + 1];
d__[i__ + 1] = cs * d__[i__ + 1];
if (icompq == 1) {
q[i__ + (*n << 1)] = cs;
q[i__ + *n * 3] = sn;
} else if (icompq == 2) {
work[i__] = cs;
work[nm1 + i__] = -sn;
}
}
}
if (icompq == 0) {
dlasdq_((char *)"U", &c__0, n, &c__0, &c__0, &c__0, &d__[1], &e[1], &vt[vt_offset], ldvt,
&u[u_offset], ldu, &u[u_offset], ldu, &work[1], info, (ftnlen)1);
goto L40;
}
if (*n <= smlsiz) {
if (icompq == 2) {
dlaset_((char *)"A", n, n, &c_b29, &c_b15, &u[u_offset], ldu, (ftnlen)1);
dlaset_((char *)"A", n, n, &c_b29, &c_b15, &vt[vt_offset], ldvt, (ftnlen)1);
dlasdq_((char *)"U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &vt[vt_offset], ldvt, &u[u_offset],
ldu, &u[u_offset], ldu, &work[wstart], info, (ftnlen)1);
} else if (icompq == 1) {
iu = 1;
ivt = iu + *n;
dlaset_((char *)"A", n, n, &c_b29, &c_b15, &q[iu + (qstart - 1) * *n], n, (ftnlen)1);
dlaset_((char *)"A", n, n, &c_b29, &c_b15, &q[ivt + (qstart - 1) * *n], n, (ftnlen)1);
dlasdq_((char *)"U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &q[ivt + (qstart - 1) * *n], n,
&q[iu + (qstart - 1) * *n], n, &q[iu + (qstart - 1) * *n], n, &work[wstart],
info, (ftnlen)1);
}
goto L40;
}
if (icompq == 2) {
dlaset_((char *)"A", n, n, &c_b29, &c_b15, &u[u_offset], ldu, (ftnlen)1);
dlaset_((char *)"A", n, n, &c_b29, &c_b15, &vt[vt_offset], ldvt, (ftnlen)1);
}
orgnrm = dlanst_((char *)"M", n, &d__[1], &e[1], (ftnlen)1);
if (orgnrm == 0.) {
return 0;
}
dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b15, n, &c__1, &d__[1], n, &ierr, (ftnlen)1);
dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b15, &nm1, &c__1, &e[1], &nm1, &ierr, (ftnlen)1);
eps = dlamch_((char *)"Epsilon", (ftnlen)7) * .9;
mlvl = (integer)(log((doublereal)(*n) / (doublereal)(smlsiz + 1)) / log(2.)) + 1;
smlszp = smlsiz + 1;
if (icompq == 1) {
iu = 1;
ivt = smlsiz + 1;
difl = ivt + smlszp;
difr = difl + mlvl;
z__ = difr + (mlvl << 1);
ic = z__ + mlvl;
is = ic + 1;
poles = is + 1;
givnum = poles + (mlvl << 1);
k = 1;
givptr = 2;
perm = 3;
givcol = perm + mlvl;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = d__[i__], abs(d__1)) < eps) {
d__[i__] = d_lmp_sign(&eps, &d__[i__]);
}
}
start = 1;
sqre = 0;
i__1 = nm1;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = e[i__], abs(d__1)) < eps || i__ == nm1) {
if (i__ < nm1) {
nsize = i__ - start + 1;
} else if ((d__1 = e[i__], abs(d__1)) >= eps) {
nsize = *n - start + 1;
} else {
nsize = i__ - start + 1;
if (icompq == 2) {
u[*n + *n * u_dim1] = d_lmp_sign(&c_b15, &d__[*n]);
vt[*n + *n * vt_dim1] = 1.;
} else if (icompq == 1) {
q[*n + (qstart - 1) * *n] = d_lmp_sign(&c_b15, &d__[*n]);
q[*n + (smlsiz + qstart - 1) * *n] = 1.;
}
d__[*n] = (d__1 = d__[*n], abs(d__1));
}
if (icompq == 2) {
dlasd0_(&nsize, &sqre, &d__[start], &e[start], &u[start + start * u_dim1], ldu,
&vt[start + start * vt_dim1], ldvt, &smlsiz, &iwork[1], &work[wstart],
info);
} else {
dlasda_(&icompq, &smlsiz, &nsize, &sqre, &d__[start], &e[start],
&q[start + (iu + qstart - 2) * *n], n, &q[start + (ivt + qstart - 2) * *n],
&iq[start + k * *n], &q[start + (difl + qstart - 2) * *n],
&q[start + (difr + qstart - 2) * *n], &q[start + (z__ + qstart - 2) * *n],
&q[start + (poles + qstart - 2) * *n], &iq[start + givptr * *n],
&iq[start + givcol * *n], n, &iq[start + perm * *n],
&q[start + (givnum + qstart - 2) * *n], &q[start + (ic + qstart - 2) * *n],
&q[start + (is + qstart - 2) * *n], &work[wstart], &iwork[1], info);
}
if (*info != 0) {
return 0;
}
start = i__ + 1;
}
}
dlascl_((char *)"G", &c__0, &c__0, &c_b15, &orgnrm, n, &c__1, &d__[1], n, &ierr, (ftnlen)1);
L40:
i__1 = *n;
for (ii = 2; ii <= i__1; ++ii) {
i__ = ii - 1;
kk = i__;
p = d__[i__];
i__2 = *n;
for (j = ii; j <= i__2; ++j) {
if (d__[j] > p) {
kk = j;
p = d__[j];
}
}
if (kk != i__) {
d__[kk] = d__[i__];
d__[i__] = p;
if (icompq == 1) {
iq[i__] = kk;
} else if (icompq == 2) {
dswap_(n, &u[i__ * u_dim1 + 1], &c__1, &u[kk * u_dim1 + 1], &c__1);
dswap_(n, &vt[i__ + vt_dim1], ldvt, &vt[kk + vt_dim1], ldvt);
}
} else if (icompq == 1) {
iq[i__] = i__;
}
}
if (icompq == 1) {
if (iuplo == 1) {
iq[*n] = 1;
} else {
iq[*n] = 0;
}
}
if (iuplo == 2 && icompq == 2) {
dlasr_((char *)"L", (char *)"V", (char *)"B", n, n, &work[1], &work[*n], &u[u_offset], ldu, (ftnlen)1, (ftnlen)1,
(ftnlen)1);
}
return 0;
}
#ifdef __cplusplus
}
#endif

26
lib/linalg/dcombssq.cpp Normal file
View File

@ -0,0 +1,26 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
int dcombssq_(doublereal *v1, doublereal *v2)
{
doublereal d__1;
--v2;
--v1;
if (v1[1] >= v2[1]) {
if (v1[1] != 0.) {
d__1 = v2[1] / v1[1];
v1[2] += d__1 * d__1 * v2[2];
} else {
v1[2] += v2[2];
}
} else {
d__1 = v1[1] / v2[1];
v1[2] = v2[2] + d__1 * d__1 * v1[2];
v1[1] = v2[1];
}
return 0;
}
#ifdef __cplusplus
}
#endif

117
lib/linalg/dgebak.cpp Normal file
View File

@ -0,0 +1,117 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
int dgebak_(char *job, char *side, integer *n, integer *ilo, integer *ihi, doublereal *scale,
integer *m, doublereal *v, integer *ldv, integer *info, ftnlen job_len, ftnlen side_len)
{
integer v_dim1, v_offset, i__1;
integer i__, k;
doublereal s;
integer ii;
extern int dscal_(integer *, doublereal *, doublereal *, integer *);
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern int dswap_(integer *, doublereal *, integer *, doublereal *, integer *);
logical leftv;
extern int xerbla_(char *, integer *, ftnlen);
logical rightv;
--scale;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
rightv = lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1);
leftv = lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1);
*info = 0;
if (!lsame_(job, (char *)"N", (ftnlen)1, (ftnlen)1) && !lsame_(job, (char *)"P", (ftnlen)1, (ftnlen)1) &&
!lsame_(job, (char *)"S", (ftnlen)1, (ftnlen)1) && !lsame_(job, (char *)"B", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (!rightv && !leftv) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ilo < 1 || *ilo > max(1, *n)) {
*info = -4;
} else if (*ihi < min(*ilo, *n) || *ihi > *n) {
*info = -5;
} else if (*m < 0) {
*info = -7;
} else if (*ldv < max(1, *n)) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"DGEBAK", &i__1, (ftnlen)6);
return 0;
}
if (*n == 0) {
return 0;
}
if (*m == 0) {
return 0;
}
if (lsame_(job, (char *)"N", (ftnlen)1, (ftnlen)1)) {
return 0;
}
if (*ilo == *ihi) {
goto L30;
}
if (lsame_(job, (char *)"S", (ftnlen)1, (ftnlen)1) || lsame_(job, (char *)"B", (ftnlen)1, (ftnlen)1)) {
if (rightv) {
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
s = scale[i__];
dscal_(m, &s, &v[i__ + v_dim1], ldv);
}
}
if (leftv) {
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
s = 1. / scale[i__];
dscal_(m, &s, &v[i__ + v_dim1], ldv);
}
}
}
L30:
if (lsame_(job, (char *)"P", (ftnlen)1, (ftnlen)1) || lsame_(job, (char *)"B", (ftnlen)1, (ftnlen)1)) {
if (rightv) {
i__1 = *n;
for (ii = 1; ii <= i__1; ++ii) {
i__ = ii;
if (i__ >= *ilo && i__ <= *ihi) {
goto L40;
}
if (i__ < *ilo) {
i__ = *ilo - ii;
}
k = (integer)scale[i__];
if (k == i__) {
goto L40;
}
dswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
L40:;
}
}
if (leftv) {
i__1 = *n;
for (ii = 1; ii <= i__1; ++ii) {
i__ = ii;
if (i__ >= *ilo && i__ <= *ihi) {
goto L50;
}
if (i__ < *ilo) {
i__ = *ilo - ii;
}
k = (integer)scale[i__];
if (k == i__) {
goto L50;
}
dswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
L50:;
}
}
}
return 0;
}
#ifdef __cplusplus
}
#endif

513
lib/linalg/dgebal.cpp Normal file
View File

@ -0,0 +1,513 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static integer c__1 = 1;
static integer c__0 = 0;
static integer c_n1 = -1;
int dgebal_(char *job, integer *n, doublereal *a, integer *lda, integer *ilo, integer *ihi,
doublereal *scale, integer *info, ftnlen job_len)
{
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1, d__2;
doublereal c__, f, g;
integer i__, j, k, l, m;
doublereal r__, s, ca, ra;
integer ica, ira, iexc;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
extern int dscal_(integer *, doublereal *, doublereal *, integer *);
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern int dswap_(integer *, doublereal *, integer *, doublereal *, integer *);
doublereal sfmin1, sfmin2, sfmax1, sfmax2;
extern doublereal dlamch_(char *, ftnlen);
extern integer idamax_(integer *, doublereal *, integer *);
extern logical disnan_(doublereal *);
extern int xerbla_(char *, integer *, ftnlen);
logical noconv;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--scale;
*info = 0;
if (!lsame_(job, (char *)"N", (ftnlen)1, (ftnlen)1) && !lsame_(job, (char *)"P", (ftnlen)1, (ftnlen)1) &&
!lsame_(job, (char *)"S", (ftnlen)1, (ftnlen)1) && !lsame_(job, (char *)"B", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1, *n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"DGEBAL", &i__1, (ftnlen)6);
return 0;
}
k = 1;
l = *n;
if (*n == 0) {
goto L210;
}
if (lsame_(job, (char *)"N", (ftnlen)1, (ftnlen)1)) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
scale[i__] = 1.;
}
goto L210;
}
if (lsame_(job, (char *)"S", (ftnlen)1, (ftnlen)1)) {
goto L120;
}
goto L50;
L20:
scale[m] = (doublereal)j;
if (j == m) {
goto L30;
}
dswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1);
i__1 = *n - k + 1;
dswap_(&i__1, &a[j + k * a_dim1], lda, &a[m + k * a_dim1], lda);
L30:
switch (iexc) {
case 1:
goto L40;
case 2:
goto L80;
}
L40:
if (l == 1) {
goto L210;
}
--l;
L50:
for (j = l; j >= 1; --j) {
i__1 = l;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ == j) {
goto L60;
}
if (a[j + i__ * a_dim1] != 0.) {
goto L70;
}
L60:;
}
m = l;
iexc = 1;
goto L20;
L70:;
}
goto L90;
L80:
++k;
L90:
i__1 = l;
for (j = k; j <= i__1; ++j) {
i__2 = l;
for (i__ = k; i__ <= i__2; ++i__) {
if (i__ == j) {
goto L100;
}
if (a[i__ + j * a_dim1] != 0.) {
goto L110;
}
L100:;
}
m = k;
iexc = 2;
goto L20;
L110:;
}
L120:
i__1 = l;
for (i__ = k; i__ <= i__1; ++i__) {
scale[i__] = 1.;
}
if (lsame_(job, (char *)"P", (ftnlen)1, (ftnlen)1)) {
goto L210;
}
sfmin1 = dlamch_((char *)"S", (ftnlen)1) / dlamch_((char *)"P", (ftnlen)1);
sfmax1 = 1. / sfmin1;
sfmin2 = sfmin1 * 2.;
sfmax2 = 1. / sfmin2;
L140:
noconv = FALSE_;
i__1 = l;
for (i__ = k; i__ <= i__1; ++i__) {
i__2 = l - k + 1;
c__ = dnrm2_(&i__2, &a[k + i__ * a_dim1], &c__1);
i__2 = l - k + 1;
r__ = dnrm2_(&i__2, &a[i__ + k * a_dim1], lda);
ica = idamax_(&l, &a[i__ * a_dim1 + 1], &c__1);
ca = (d__1 = a[ica + i__ * a_dim1], abs(d__1));
i__2 = *n - k + 1;
ira = idamax_(&i__2, &a[i__ + k * a_dim1], lda);
ra = (d__1 = a[i__ + (ira + k - 1) * a_dim1], abs(d__1));
if (c__ == 0. || r__ == 0.) {
goto L200;
}
g = r__ / 2.;
f = 1.;
s = c__ + r__;
L160:
d__1 = max(f, c__);
d__2 = min(r__, g);
if (c__ >= g || max(d__1, ca) >= sfmax2 || min(d__2, ra) <= sfmin2) {
goto L170;
}
d__1 = c__ + f + ca + r__ + g + ra;
if (disnan_(&d__1)) {
*info = -3;
i__2 = -(*info);
xerbla_((char *)"DGEBAL", &i__2, (ftnlen)6);
return 0;
}
f *= 2.;
c__ *= 2.;
ca *= 2.;
r__ /= 2.;
g /= 2.;
ra /= 2.;
goto L160;
L170:
g = c__ / 2.;
L180:
d__1 = min(f, c__), d__1 = min(d__1, g);
if (g < r__ || max(r__, ra) >= sfmax2 || min(d__1, ca) <= sfmin2) {
goto L190;
}
f /= 2.;
c__ /= 2.;
g /= 2.;
ca /= 2.;
r__ *= 2.;
ra *= 2.;
goto L180;
L190:
if (c__ + r__ >= s * .95) {
goto L200;
}
if (f < 1. && scale[i__] < 1.) {
if (f * scale[i__] <= sfmin1) {
goto L200;
}
}
if (f > 1. && scale[i__] > 1.) {
if (scale[i__] >= sfmax1 / f) {
goto L200;
}
}
g = 1. / f;
scale[i__] *= f;
noconv = TRUE_;
i__2 = *n - k + 1;
dscal_(&i__2, &g, &a[i__ + k * a_dim1], lda);
dscal_(&l, &f, &a[i__ * a_dim1 + 1], &c__1);
L200:;
}
if (noconv) {
goto L140;
}
L210:
*ilo = k;
*ihi = l;
return 0;
}
int dgeev_(char *jobvl, char *jobvr, integer *n, doublereal *a, integer *lda, doublereal *wr,
doublereal *wi, doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr,
doublereal *work, integer *lwork, integer *info, ftnlen jobvl_len, ftnlen jobvr_len)
{
integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3;
doublereal d__1, d__2;
double sqrt(doublereal);
integer i__, k;
doublereal r__, cs, sn;
integer ihi;
doublereal scl;
integer ilo;
doublereal dum[1], eps;
integer lwork_trevc__, ibal;
char side[1];
doublereal anrm;
integer ierr, itau;
extern int drot_(integer *, doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *);
integer iwrk, nout;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
extern int dscal_(integer *, doublereal *, doublereal *, integer *);
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern doublereal dlapy2_(doublereal *, doublereal *);
extern int dlabad_(doublereal *, doublereal *),
dgebak_(char *, char *, integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, integer *, ftnlen, ftnlen),
dgebal_(char *, integer *, doublereal *, integer *, integer *, integer *, doublereal *,
integer *, ftnlen);
logical scalea;
extern doublereal dlamch_(char *, ftnlen);
doublereal cscale;
extern doublereal dlange_(char *, integer *, integer *, doublereal *, integer *, doublereal *,
ftnlen);
extern int dgehrd_(integer *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, integer *),
dlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, integer *,
doublereal *, integer *, integer *, ftnlen);
extern integer idamax_(integer *, doublereal *, integer *);
extern int dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *,
integer *, ftnlen),
dlartg_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *),
xerbla_(char *, integer *, ftnlen);
logical select[1];
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
doublereal bignum;
extern int dorghr_(integer *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, integer *),
dhseqr_(char *, char *, integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *,
integer *, ftnlen, ftnlen);
integer minwrk, maxwrk;
logical wantvl;
doublereal smlnum;
integer hswork;
logical lquery, wantvr;
extern int dtrevc3_(char *, char *, logical *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *, integer *, doublereal *,
integer *, integer *, ftnlen, ftnlen);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--wr;
--wi;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--work;
*info = 0;
lquery = *lwork == -1;
wantvl = lsame_(jobvl, (char *)"V", (ftnlen)1, (ftnlen)1);
wantvr = lsame_(jobvr, (char *)"V", (ftnlen)1, (ftnlen)1);
if (!wantvl && !lsame_(jobvl, (char *)"N", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (!wantvr && !lsame_(jobvr, (char *)"N", (ftnlen)1, (ftnlen)1)) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1, *n)) {
*info = -5;
} else if (*ldvl < 1 || wantvl && *ldvl < *n) {
*info = -9;
} else if (*ldvr < 1 || wantvr && *ldvr < *n) {
*info = -11;
}
if (*info == 0) {
if (*n == 0) {
minwrk = 1;
maxwrk = 1;
} else {
maxwrk = (*n << 1) +
*n * ilaenv_(&c__1, (char *)"DGEHRD", (char *)" ", n, &c__1, n, &c__0, (ftnlen)6, (ftnlen)1);
if (wantvl) {
minwrk = *n << 2;
i__1 = maxwrk,
i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1, (char *)"DORGHR", (char *)" ", n, &c__1, n, &c_n1,
(ftnlen)6, (ftnlen)1);
maxwrk = max(i__1, i__2);
dhseqr_((char *)"S", (char *)"V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[1], &vl[vl_offset],
ldvl, &work[1], &c_n1, info, (ftnlen)1, (ftnlen)1);
hswork = (integer)work[1];
i__1 = maxwrk, i__2 = *n + 1, i__1 = max(i__1, i__2), i__2 = *n + hswork;
maxwrk = max(i__1, i__2);
dtrevc3_((char *)"L", (char *)"B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl,
&vr[vr_offset], ldvr, n, &nout, &work[1], &c_n1, &ierr, (ftnlen)1,
(ftnlen)1);
lwork_trevc__ = (integer)work[1];
i__1 = maxwrk, i__2 = *n + lwork_trevc__;
maxwrk = max(i__1, i__2);
i__1 = maxwrk, i__2 = *n << 2;
maxwrk = max(i__1, i__2);
} else if (wantvr) {
minwrk = *n << 2;
i__1 = maxwrk,
i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1, (char *)"DORGHR", (char *)" ", n, &c__1, n, &c_n1,
(ftnlen)6, (ftnlen)1);
maxwrk = max(i__1, i__2);
dhseqr_((char *)"S", (char *)"V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[1], &vr[vr_offset],
ldvr, &work[1], &c_n1, info, (ftnlen)1, (ftnlen)1);
hswork = (integer)work[1];
i__1 = maxwrk, i__2 = *n + 1, i__1 = max(i__1, i__2), i__2 = *n + hswork;
maxwrk = max(i__1, i__2);
dtrevc3_((char *)"R", (char *)"B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl,
&vr[vr_offset], ldvr, n, &nout, &work[1], &c_n1, &ierr, (ftnlen)1,
(ftnlen)1);
lwork_trevc__ = (integer)work[1];
i__1 = maxwrk, i__2 = *n + lwork_trevc__;
maxwrk = max(i__1, i__2);
i__1 = maxwrk, i__2 = *n << 2;
maxwrk = max(i__1, i__2);
} else {
minwrk = *n * 3;
dhseqr_((char *)"E", (char *)"N", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[1], &vr[vr_offset],
ldvr, &work[1], &c_n1, info, (ftnlen)1, (ftnlen)1);
hswork = (integer)work[1];
i__1 = maxwrk, i__2 = *n + 1, i__1 = max(i__1, i__2), i__2 = *n + hswork;
maxwrk = max(i__1, i__2);
}
maxwrk = max(maxwrk, minwrk);
}
work[1] = (doublereal)maxwrk;
if (*lwork < minwrk && !lquery) {
*info = -13;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"DGEEV ", &i__1, (ftnlen)6);
return 0;
} else if (lquery) {
return 0;
}
if (*n == 0) {
return 0;
}
eps = dlamch_((char *)"P", (ftnlen)1);
smlnum = dlamch_((char *)"S", (ftnlen)1);
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1. / smlnum;
anrm = dlange_((char *)"M", n, n, &a[a_offset], lda, dum, (ftnlen)1);
scalea = FALSE_;
if (anrm > 0. && anrm < smlnum) {
scalea = TRUE_;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = TRUE_;
cscale = bignum;
}
if (scalea) {
dlascl_((char *)"G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &ierr, (ftnlen)1);
}
ibal = 1;
dgebal_((char *)"B", n, &a[a_offset], lda, &ilo, &ihi, &work[ibal], &ierr, (ftnlen)1);
itau = ibal + *n;
iwrk = itau + *n;
i__1 = *lwork - iwrk + 1;
dgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, &ierr);
if (wantvl) {
*(unsigned char *)side = 'L';
dlacpy_((char *)"L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl, (ftnlen)1);
i__1 = *lwork - iwrk + 1;
dorghr_(n, &ilo, &ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk], &i__1, &ierr);
iwrk = itau;
i__1 = *lwork - iwrk + 1;
dhseqr_((char *)"S", (char *)"V", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &vl[vl_offset], ldvl,
&work[iwrk], &i__1, info, (ftnlen)1, (ftnlen)1);
if (wantvr) {
*(unsigned char *)side = 'B';
dlacpy_((char *)"F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, (ftnlen)1);
}
} else if (wantvr) {
*(unsigned char *)side = 'R';
dlacpy_((char *)"L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr, (ftnlen)1);
i__1 = *lwork - iwrk + 1;
dorghr_(n, &ilo, &ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk], &i__1, &ierr);
iwrk = itau;
i__1 = *lwork - iwrk + 1;
dhseqr_((char *)"S", (char *)"V", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &vr[vr_offset], ldvr,
&work[iwrk], &i__1, info, (ftnlen)1, (ftnlen)1);
} else {
iwrk = itau;
i__1 = *lwork - iwrk + 1;
dhseqr_((char *)"E", (char *)"N", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &vr[vr_offset], ldvr,
&work[iwrk], &i__1, info, (ftnlen)1, (ftnlen)1);
}
if (*info != 0) {
goto L50;
}
if (wantvl || wantvr) {
i__1 = *lwork - iwrk + 1;
dtrevc3_(side, (char *)"B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl, &vr[vr_offset],
ldvr, n, &nout, &work[iwrk], &i__1, &ierr, (ftnlen)1, (ftnlen)1);
}
if (wantvl) {
dgebak_((char *)"B", (char *)"L", n, &ilo, &ihi, &work[ibal], n, &vl[vl_offset], ldvl, &ierr, (ftnlen)1,
(ftnlen)1);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (wi[i__] == 0.) {
scl = 1. / dnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
dscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
} else if (wi[i__] > 0.) {
d__1 = dnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
d__2 = dnrm2_(n, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
scl = 1. / dlapy2_(&d__1, &d__2);
dscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
dscal_(n, &scl, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
d__1 = vl[k + i__ * vl_dim1];
d__2 = vl[k + (i__ + 1) * vl_dim1];
work[iwrk + k - 1] = d__1 * d__1 + d__2 * d__2;
}
k = idamax_(n, &work[iwrk], &c__1);
dlartg_(&vl[k + i__ * vl_dim1], &vl[k + (i__ + 1) * vl_dim1], &cs, &sn, &r__);
drot_(n, &vl[i__ * vl_dim1 + 1], &c__1, &vl[(i__ + 1) * vl_dim1 + 1], &c__1, &cs,
&sn);
vl[k + (i__ + 1) * vl_dim1] = 0.;
}
}
}
if (wantvr) {
dgebak_((char *)"B", (char *)"R", n, &ilo, &ihi, &work[ibal], n, &vr[vr_offset], ldvr, &ierr, (ftnlen)1,
(ftnlen)1);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (wi[i__] == 0.) {
scl = 1. / dnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
dscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
} else if (wi[i__] > 0.) {
d__1 = dnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
d__2 = dnrm2_(n, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
scl = 1. / dlapy2_(&d__1, &d__2);
dscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
dscal_(n, &scl, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
d__1 = vr[k + i__ * vr_dim1];
d__2 = vr[k + (i__ + 1) * vr_dim1];
work[iwrk + k - 1] = d__1 * d__1 + d__2 * d__2;
}
k = idamax_(n, &work[iwrk], &c__1);
dlartg_(&vr[k + i__ * vr_dim1], &vr[k + (i__ + 1) * vr_dim1], &cs, &sn, &r__);
drot_(n, &vr[i__ * vr_dim1 + 1], &c__1, &vr[(i__ + 1) * vr_dim1 + 1], &c__1, &cs,
&sn);
vr[k + (i__ + 1) * vr_dim1] = 0.;
}
}
}
L50:
if (scalea) {
i__1 = *n - *info;
i__3 = *n - *info;
i__2 = max(i__3, 1);
dlascl_((char *)"G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[*info + 1], &i__2, &ierr,
(ftnlen)1);
i__1 = *n - *info;
i__3 = *n - *info;
i__2 = max(i__3, 1);
dlascl_((char *)"G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[*info + 1], &i__2, &ierr,
(ftnlen)1);
if (*info > 0) {
i__1 = ilo - 1;
dlascl_((char *)"G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[1], n, &ierr, (ftnlen)1);
i__1 = ilo - 1;
dlascl_((char *)"G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[1], n, &ierr, (ftnlen)1);
}
}
work[1] = (doublereal)maxwrk;
return 0;
}
#ifdef __cplusplus
}
#endif

57
lib/linalg/dgehd2.cpp Normal file
View File

@ -0,0 +1,57 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static integer c__1 = 1;
int dgehd2_(integer *n, integer *ilo, integer *ihi, doublereal *a, integer *lda, doublereal *tau,
doublereal *work, integer *info)
{
integer a_dim1, a_offset, i__1, i__2, i__3;
integer i__;
doublereal aii;
extern int dlarf_(char *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, ftnlen),
dlarfg_(integer *, doublereal *, doublereal *, integer *, doublereal *),
xerbla_(char *, integer *, ftnlen);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*ilo < 1 || *ilo > max(1, *n)) {
*info = -2;
} else if (*ihi < min(*ilo, *n) || *ihi > *n) {
*info = -3;
} else if (*lda < max(1, *n)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"DGEHD2", &i__1, (ftnlen)6);
return 0;
}
i__1 = *ihi - 1;
for (i__ = *ilo; i__ <= i__1; ++i__) {
i__2 = *ihi - i__;
i__3 = i__ + 2;
dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3, *n) + i__ * a_dim1], &c__1,
&tau[i__]);
aii = a[i__ + 1 + i__ * a_dim1];
a[i__ + 1 + i__ * a_dim1] = 1.;
i__2 = *ihi - i__;
dlarf_((char *)"Right", ihi, &i__2, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[i__],
&a[(i__ + 1) * a_dim1 + 1], lda, &work[1], (ftnlen)5);
i__2 = *ihi - i__;
i__3 = *n - i__;
dlarf_((char *)"Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[i__],
&a[i__ + 1 + (i__ + 1) * a_dim1], lda, &work[1], (ftnlen)4);
a[i__ + 1 + i__ * a_dim1] = aii;
}
return 0;
}
#ifdef __cplusplus
}
#endif

144
lib/linalg/dgehrd.cpp Normal file
View File

@ -0,0 +1,144 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static integer c__1 = 1;
static integer c_n1 = -1;
static integer c__3 = 3;
static integer c__2 = 2;
static integer c__65 = 65;
static doublereal c_b25 = -1.;
static doublereal c_b26 = 1.;
int dgehrd_(integer *n, integer *ilo, integer *ihi, doublereal *a, integer *lda, doublereal *tau,
doublereal *work, integer *lwork, integer *info)
{
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
integer i__, j, ib;
doublereal ei;
integer nb, nh, nx, iwt;
extern int dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *, integer *,
ftnlen, ftnlen);
integer nbmin, iinfo;
extern int dtrmm_(char *, char *, char *, char *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen,
ftnlen),
daxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *),
dgehd2_(integer *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *),
dlahr2_(integer *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *),
dlarfb_(char *, char *, char *, char *, integer *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, ftnlen, ftnlen, ftnlen, ftnlen),
xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
integer ldwork, lwkopt;
logical lquery;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
*info = 0;
lquery = *lwork == -1;
if (*n < 0) {
*info = -1;
} else if (*ilo < 1 || *ilo > max(1, *n)) {
*info = -2;
} else if (*ihi < min(*ilo, *n) || *ihi > *n) {
*info = -3;
} else if (*lda < max(1, *n)) {
*info = -5;
} else if (*lwork < max(1, *n) && !lquery) {
*info = -8;
}
if (*info == 0) {
i__1 = 64, i__2 = ilaenv_(&c__1, (char *)"DGEHRD", (char *)" ", n, ilo, ihi, &c_n1, (ftnlen)6, (ftnlen)1);
nb = min(i__1, i__2);
lwkopt = *n * nb + 4160;
work[1] = (doublereal)lwkopt;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"DGEHRD", &i__1, (ftnlen)6);
return 0;
} else if (lquery) {
return 0;
}
i__1 = *ilo - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
tau[i__] = 0.;
}
i__1 = *n - 1;
for (i__ = max(1, *ihi); i__ <= i__1; ++i__) {
tau[i__] = 0.;
}
nh = *ihi - *ilo + 1;
if (nh <= 1) {
work[1] = 1.;
return 0;
}
i__1 = 64, i__2 = ilaenv_(&c__1, (char *)"DGEHRD", (char *)" ", n, ilo, ihi, &c_n1, (ftnlen)6, (ftnlen)1);
nb = min(i__1, i__2);
nbmin = 2;
if (nb > 1 && nb < nh) {
i__1 = nb, i__2 = ilaenv_(&c__3, (char *)"DGEHRD", (char *)" ", n, ilo, ihi, &c_n1, (ftnlen)6, (ftnlen)1);
nx = max(i__1, i__2);
if (nx < nh) {
if (*lwork < *n * nb + 4160) {
i__1 = 2,
i__2 = ilaenv_(&c__2, (char *)"DGEHRD", (char *)" ", n, ilo, ihi, &c_n1, (ftnlen)6, (ftnlen)1);
nbmin = max(i__1, i__2);
if (*lwork >= *n * nbmin + 4160) {
nb = (*lwork - 4160) / *n;
} else {
nb = 1;
}
}
}
}
ldwork = *n;
if (nb < nbmin || nb >= nh) {
i__ = *ilo;
} else {
iwt = *n * nb + 1;
i__1 = *ihi - 1 - nx;
i__2 = nb;
for (i__ = *ilo; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
i__3 = nb, i__4 = *ihi - i__;
ib = min(i__3, i__4);
dlahr2_(ihi, &i__, &ib, &a[i__ * a_dim1 + 1], lda, &tau[i__], &work[iwt], &c__65,
&work[1], &ldwork);
ei = a[i__ + ib + (i__ + ib - 1) * a_dim1];
a[i__ + ib + (i__ + ib - 1) * a_dim1] = 1.;
i__3 = *ihi - i__ - ib + 1;
dgemm_((char *)"No transpose", (char *)"Transpose", ihi, &i__3, &ib, &c_b25, &work[1], &ldwork,
&a[i__ + ib + i__ * a_dim1], lda, &c_b26, &a[(i__ + ib) * a_dim1 + 1], lda,
(ftnlen)12, (ftnlen)9);
a[i__ + ib + (i__ + ib - 1) * a_dim1] = ei;
i__3 = ib - 1;
dtrmm_((char *)"Right", (char *)"Lower", (char *)"Transpose", (char *)"Unit", &i__, &i__3, &c_b26,
&a[i__ + 1 + i__ * a_dim1], lda, &work[1], &ldwork, (ftnlen)5, (ftnlen)5,
(ftnlen)9, (ftnlen)4);
i__3 = ib - 2;
for (j = 0; j <= i__3; ++j) {
daxpy_(&i__, &c_b25, &work[ldwork * j + 1], &c__1, &a[(i__ + j + 1) * a_dim1 + 1],
&c__1);
}
i__3 = *ihi - i__;
i__4 = *n - i__ - ib + 1;
dlarfb_((char *)"Left", (char *)"Transpose", (char *)"Forward", (char *)"Columnwise", &i__3, &i__4, &ib,
&a[i__ + 1 + i__ * a_dim1], lda, &work[iwt], &c__65,
&a[i__ + 1 + (i__ + ib) * a_dim1], lda, &work[1], &ldwork, (ftnlen)4, (ftnlen)9,
(ftnlen)7, (ftnlen)10);
}
}
dgehd2_(n, &i__, ihi, &a[a_offset], lda, &tau[1], &work[1], &iinfo);
work[1] = (doublereal)lwkopt;
return 0;
}
#ifdef __cplusplus
}
#endif

788
lib/linalg/dgesdd.cpp Normal file
View File

@ -0,0 +1,788 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static integer c_n1 = -1;
static integer c__0 = 0;
static doublereal c_b63 = 0.;
static integer c__1 = 1;
static doublereal c_b84 = 1.;
int dgesdd_(char *jobz, integer *m, integer *n, doublereal *a, integer *lda, doublereal *s,
doublereal *u, integer *ldu, doublereal *vt, integer *ldvt, doublereal *work,
integer *lwork, integer *iwork, integer *info, ftnlen jobz_len)
{
integer a_dim1, a_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2, i__3;
double sqrt(doublereal);
integer lwork_dorglq_mn__, lwork_dorglq_nn__, lwork_dorgqr_mm__, lwork_dorgqr_mn__, i__, ie,
lwork_dorgbr_p_mm__, il, lwork_dorgbr_q_nn__, ir, iu, blk;
doublereal dum[1], eps;
integer ivt, iscl;
doublereal anrm;
integer idum[1], ierr, itau, lwork_dormbr_qln_mm__, lwork_dormbr_qln_mn__,
lwork_dormbr_qln_nn__, lwork_dormbr_prt_mm__, lwork_dormbr_prt_mn__, lwork_dormbr_prt_nn__;
extern int dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *, integer *,
ftnlen, ftnlen);
extern logical lsame_(char *, char *, ftnlen, ftnlen);
integer chunk, minmn, wrkbl, itaup, itauq, mnthr;
logical wntqa;
integer nwork;
logical wntqn, wntqo, wntqs;
extern int dbdsdc_(char *, char *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, integer *, ftnlen, ftnlen),
dgebrd_(integer *, integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, integer *);
extern doublereal dlamch_(char *, ftnlen),
dlange_(char *, integer *, integer *, doublereal *, integer *, doublereal *, ftnlen);
integer bdspac;
extern int dgelqf_(integer *, integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *),
dlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, integer *,
doublereal *, integer *, integer *, ftnlen),
dgeqrf_(integer *, integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *),
dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *,
ftnlen),
dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *,
ftnlen),
xerbla_(char *, integer *, ftnlen),
dorgbr_(char *, integer *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, integer *, ftnlen);
doublereal bignum;
extern int dormbr_(char *, char *, char *, integer *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, doublereal *, integer *,
integer *, ftnlen, ftnlen, ftnlen),
dorglq_(integer *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, integer *),
dorgqr_(integer *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, integer *);
integer ldwrkl, ldwrkr, minwrk, ldwrku, maxwrk, ldwkvt;
doublereal smlnum;
logical wntqas, lquery;
integer lwork_dgebrd_mm__, lwork_dgebrd_mn__, lwork_dgebrd_nn__, lwork_dgelqf_mn__,
lwork_dgeqrf_mn__;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--s;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1;
vt -= vt_offset;
--work;
--iwork;
*info = 0;
minmn = min(*m, *n);
wntqa = lsame_(jobz, (char *)"A", (ftnlen)1, (ftnlen)1);
wntqs = lsame_(jobz, (char *)"S", (ftnlen)1, (ftnlen)1);
wntqas = wntqa || wntqs;
wntqo = lsame_(jobz, (char *)"O", (ftnlen)1, (ftnlen)1);
wntqn = lsame_(jobz, (char *)"N", (ftnlen)1, (ftnlen)1);
lquery = *lwork == -1;
if (!(wntqa || wntqs || wntqo || wntqn)) {
*info = -1;
} else if (*m < 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1, *m)) {
*info = -5;
} else if (*ldu < 1 || wntqas && *ldu < *m || wntqo && *m < *n && *ldu < *m) {
*info = -8;
} else if (*ldvt < 1 || wntqa && *ldvt < *n || wntqs && *ldvt < minmn ||
wntqo && *m >= *n && *ldvt < *n) {
*info = -10;
}
if (*info == 0) {
minwrk = 1;
maxwrk = 1;
bdspac = 0;
mnthr = (integer)(minmn * 11. / 6.);
if (*m >= *n && minmn > 0) {
if (wntqn) {
bdspac = *n * 7;
} else {
bdspac = *n * 3 * *n + (*n << 2);
}
dgebrd_(m, n, dum, m, dum, dum, dum, dum, dum, &c_n1, &ierr);
lwork_dgebrd_mn__ = (integer)dum[0];
dgebrd_(n, n, dum, n, dum, dum, dum, dum, dum, &c_n1, &ierr);
lwork_dgebrd_nn__ = (integer)dum[0];
dgeqrf_(m, n, dum, m, dum, dum, &c_n1, &ierr);
lwork_dgeqrf_mn__ = (integer)dum[0];
dorgbr_((char *)"Q", n, n, n, dum, n, dum, dum, &c_n1, &ierr, (ftnlen)1);
lwork_dorgbr_q_nn__ = (integer)dum[0];
dorgqr_(m, m, n, dum, m, dum, dum, &c_n1, &ierr);
lwork_dorgqr_mm__ = (integer)dum[0];
dorgqr_(m, n, n, dum, m, dum, dum, &c_n1, &ierr);
lwork_dorgqr_mn__ = (integer)dum[0];
dormbr_((char *)"P", (char *)"R", (char *)"T", n, n, n, dum, n, dum, dum, n, dum, &c_n1, &ierr, (ftnlen)1,
(ftnlen)1, (ftnlen)1);
lwork_dormbr_prt_nn__ = (integer)dum[0];
dormbr_((char *)"Q", (char *)"L", (char *)"N", n, n, n, dum, n, dum, dum, n, dum, &c_n1, &ierr, (ftnlen)1,
(ftnlen)1, (ftnlen)1);
lwork_dormbr_qln_nn__ = (integer)dum[0];
dormbr_((char *)"Q", (char *)"L", (char *)"N", m, n, n, dum, m, dum, dum, m, dum, &c_n1, &ierr, (ftnlen)1,
(ftnlen)1, (ftnlen)1);
lwork_dormbr_qln_mn__ = (integer)dum[0];
dormbr_((char *)"Q", (char *)"L", (char *)"N", m, m, n, dum, m, dum, dum, m, dum, &c_n1, &ierr, (ftnlen)1,
(ftnlen)1, (ftnlen)1);
lwork_dormbr_qln_mm__ = (integer)dum[0];
if (*m >= mnthr) {
if (wntqn) {
wrkbl = *n + lwork_dgeqrf_mn__;
i__1 = wrkbl, i__2 = *n * 3 + lwork_dgebrd_nn__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = bdspac + *n;
maxwrk = max(i__1, i__2);
minwrk = bdspac + *n;
} else if (wntqo) {
wrkbl = *n + lwork_dgeqrf_mn__;
i__1 = wrkbl, i__2 = *n + lwork_dorgqr_mn__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *n * 3 + lwork_dgebrd_nn__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *n * 3 + lwork_dormbr_qln_nn__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *n * 3 + lwork_dormbr_prt_nn__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *n * 3 + bdspac;
wrkbl = max(i__1, i__2);
maxwrk = wrkbl + (*n << 1) * *n;
minwrk = bdspac + (*n << 1) * *n + *n * 3;
} else if (wntqs) {
wrkbl = *n + lwork_dgeqrf_mn__;
i__1 = wrkbl, i__2 = *n + lwork_dorgqr_mn__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *n * 3 + lwork_dgebrd_nn__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *n * 3 + lwork_dormbr_qln_nn__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *n * 3 + lwork_dormbr_prt_nn__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *n * 3 + bdspac;
wrkbl = max(i__1, i__2);
maxwrk = wrkbl + *n * *n;
minwrk = bdspac + *n * *n + *n * 3;
} else if (wntqa) {
wrkbl = *n + lwork_dgeqrf_mn__;
i__1 = wrkbl, i__2 = *n + lwork_dorgqr_mm__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *n * 3 + lwork_dgebrd_nn__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *n * 3 + lwork_dormbr_qln_nn__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *n * 3 + lwork_dormbr_prt_nn__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *n * 3 + bdspac;
wrkbl = max(i__1, i__2);
maxwrk = wrkbl + *n * *n;
i__1 = *n * 3 + bdspac, i__2 = *n + *m;
minwrk = *n * *n + max(i__1, i__2);
}
} else {
wrkbl = *n * 3 + lwork_dgebrd_mn__;
if (wntqn) {
i__1 = wrkbl, i__2 = *n * 3 + bdspac;
maxwrk = max(i__1, i__2);
minwrk = *n * 3 + max(*m, bdspac);
} else if (wntqo) {
i__1 = wrkbl, i__2 = *n * 3 + lwork_dormbr_prt_nn__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *n * 3 + lwork_dormbr_qln_mn__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *n * 3 + bdspac;
wrkbl = max(i__1, i__2);
maxwrk = wrkbl + *m * *n;
i__1 = *m, i__2 = *n * *n + bdspac;
minwrk = *n * 3 + max(i__1, i__2);
} else if (wntqs) {
i__1 = wrkbl, i__2 = *n * 3 + lwork_dormbr_qln_mn__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *n * 3 + lwork_dormbr_prt_nn__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *n * 3 + bdspac;
maxwrk = max(i__1, i__2);
minwrk = *n * 3 + max(*m, bdspac);
} else if (wntqa) {
i__1 = wrkbl, i__2 = *n * 3 + lwork_dormbr_qln_mm__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *n * 3 + lwork_dormbr_prt_nn__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *n * 3 + bdspac;
maxwrk = max(i__1, i__2);
minwrk = *n * 3 + max(*m, bdspac);
}
}
} else if (minmn > 0) {
if (wntqn) {
bdspac = *m * 7;
} else {
bdspac = *m * 3 * *m + (*m << 2);
}
dgebrd_(m, n, dum, m, dum, dum, dum, dum, dum, &c_n1, &ierr);
lwork_dgebrd_mn__ = (integer)dum[0];
dgebrd_(m, m, &a[a_offset], m, &s[1], dum, dum, dum, dum, &c_n1, &ierr);
lwork_dgebrd_mm__ = (integer)dum[0];
dgelqf_(m, n, &a[a_offset], m, dum, dum, &c_n1, &ierr);
lwork_dgelqf_mn__ = (integer)dum[0];
dorglq_(n, n, m, dum, n, dum, dum, &c_n1, &ierr);
lwork_dorglq_nn__ = (integer)dum[0];
dorglq_(m, n, m, &a[a_offset], m, dum, dum, &c_n1, &ierr);
lwork_dorglq_mn__ = (integer)dum[0];
dorgbr_((char *)"P", m, m, m, &a[a_offset], n, dum, dum, &c_n1, &ierr, (ftnlen)1);
lwork_dorgbr_p_mm__ = (integer)dum[0];
dormbr_((char *)"P", (char *)"R", (char *)"T", m, m, m, dum, m, dum, dum, m, dum, &c_n1, &ierr, (ftnlen)1,
(ftnlen)1, (ftnlen)1);
lwork_dormbr_prt_mm__ = (integer)dum[0];
dormbr_((char *)"P", (char *)"R", (char *)"T", m, n, m, dum, m, dum, dum, m, dum, &c_n1, &ierr, (ftnlen)1,
(ftnlen)1, (ftnlen)1);
lwork_dormbr_prt_mn__ = (integer)dum[0];
dormbr_((char *)"P", (char *)"R", (char *)"T", n, n, m, dum, n, dum, dum, n, dum, &c_n1, &ierr, (ftnlen)1,
(ftnlen)1, (ftnlen)1);
lwork_dormbr_prt_nn__ = (integer)dum[0];
dormbr_((char *)"Q", (char *)"L", (char *)"N", m, m, m, dum, m, dum, dum, m, dum, &c_n1, &ierr, (ftnlen)1,
(ftnlen)1, (ftnlen)1);
lwork_dormbr_qln_mm__ = (integer)dum[0];
if (*n >= mnthr) {
if (wntqn) {
wrkbl = *m + lwork_dgelqf_mn__;
i__1 = wrkbl, i__2 = *m * 3 + lwork_dgebrd_mm__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = bdspac + *m;
maxwrk = max(i__1, i__2);
minwrk = bdspac + *m;
} else if (wntqo) {
wrkbl = *m + lwork_dgelqf_mn__;
i__1 = wrkbl, i__2 = *m + lwork_dorglq_mn__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *m * 3 + lwork_dgebrd_mm__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *m * 3 + lwork_dormbr_qln_mm__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *m * 3 + lwork_dormbr_prt_mm__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *m * 3 + bdspac;
wrkbl = max(i__1, i__2);
maxwrk = wrkbl + (*m << 1) * *m;
minwrk = bdspac + (*m << 1) * *m + *m * 3;
} else if (wntqs) {
wrkbl = *m + lwork_dgelqf_mn__;
i__1 = wrkbl, i__2 = *m + lwork_dorglq_mn__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *m * 3 + lwork_dgebrd_mm__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *m * 3 + lwork_dormbr_qln_mm__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *m * 3 + lwork_dormbr_prt_mm__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *m * 3 + bdspac;
wrkbl = max(i__1, i__2);
maxwrk = wrkbl + *m * *m;
minwrk = bdspac + *m * *m + *m * 3;
} else if (wntqa) {
wrkbl = *m + lwork_dgelqf_mn__;
i__1 = wrkbl, i__2 = *m + lwork_dorglq_nn__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *m * 3 + lwork_dgebrd_mm__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *m * 3 + lwork_dormbr_qln_mm__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *m * 3 + lwork_dormbr_prt_mm__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *m * 3 + bdspac;
wrkbl = max(i__1, i__2);
maxwrk = wrkbl + *m * *m;
i__1 = *m * 3 + bdspac, i__2 = *m + *n;
minwrk = *m * *m + max(i__1, i__2);
}
} else {
wrkbl = *m * 3 + lwork_dgebrd_mn__;
if (wntqn) {
i__1 = wrkbl, i__2 = *m * 3 + bdspac;
maxwrk = max(i__1, i__2);
minwrk = *m * 3 + max(*n, bdspac);
} else if (wntqo) {
i__1 = wrkbl, i__2 = *m * 3 + lwork_dormbr_qln_mm__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *m * 3 + lwork_dormbr_prt_mn__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *m * 3 + bdspac;
wrkbl = max(i__1, i__2);
maxwrk = wrkbl + *m * *n;
i__1 = *n, i__2 = *m * *m + bdspac;
minwrk = *m * 3 + max(i__1, i__2);
} else if (wntqs) {
i__1 = wrkbl, i__2 = *m * 3 + lwork_dormbr_qln_mm__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *m * 3 + lwork_dormbr_prt_mn__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *m * 3 + bdspac;
maxwrk = max(i__1, i__2);
minwrk = *m * 3 + max(*n, bdspac);
} else if (wntqa) {
i__1 = wrkbl, i__2 = *m * 3 + lwork_dormbr_qln_mm__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *m * 3 + lwork_dormbr_prt_nn__;
wrkbl = max(i__1, i__2);
i__1 = wrkbl, i__2 = *m * 3 + bdspac;
maxwrk = max(i__1, i__2);
minwrk = *m * 3 + max(*n, bdspac);
}
}
}
maxwrk = max(maxwrk, minwrk);
work[1] = (doublereal)maxwrk;
if (*lwork < minwrk && !lquery) {
*info = -12;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"DGESDD", &i__1, (ftnlen)6);
return 0;
} else if (lquery) {
return 0;
}
if (*m == 0 || *n == 0) {
return 0;
}
eps = dlamch_((char *)"P", (ftnlen)1);
smlnum = sqrt(dlamch_((char *)"S", (ftnlen)1)) / eps;
bignum = 1. / smlnum;
anrm = dlange_((char *)"M", m, n, &a[a_offset], lda, dum, (ftnlen)1);
iscl = 0;
if (anrm > 0. && anrm < smlnum) {
iscl = 1;
dlascl_((char *)"G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, &ierr, (ftnlen)1);
} else if (anrm > bignum) {
iscl = 1;
dlascl_((char *)"G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, &ierr, (ftnlen)1);
}
if (*m >= *n) {
if (*m >= mnthr) {
if (wntqn) {
itau = 1;
nwork = itau + *n;
i__1 = *lwork - nwork + 1;
dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1, &ierr);
i__1 = *n - 1;
i__2 = *n - 1;
dlaset_((char *)"L", &i__1, &i__2, &c_b63, &c_b63, &a[a_dim1 + 2], lda, (ftnlen)1);
ie = 1;
itauq = ie + *n;
itaup = itauq + *n;
nwork = itaup + *n;
i__1 = *lwork - nwork + 1;
dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &work[itaup],
&work[nwork], &i__1, &ierr);
nwork = ie + *n;
dbdsdc_((char *)"U", (char *)"N", n, &s[1], &work[ie], dum, &c__1, dum, &c__1, dum, idum,
&work[nwork], &iwork[1], info, (ftnlen)1, (ftnlen)1);
} else if (wntqo) {
ir = 1;
if (*lwork >= *lda * *n + *n * *n + *n * 3 + bdspac) {
ldwrkr = *lda;
} else {
ldwrkr = (*lwork - *n * *n - *n * 3 - bdspac) / *n;
}
itau = ir + ldwrkr * *n;
nwork = itau + *n;
i__1 = *lwork - nwork + 1;
dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1, &ierr);
dlacpy_((char *)"U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr, (ftnlen)1);
i__1 = *n - 1;
i__2 = *n - 1;
dlaset_((char *)"L", &i__1, &i__2, &c_b63, &c_b63, &work[ir + 1], &ldwrkr, (ftnlen)1);
i__1 = *lwork - nwork + 1;
dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1, &ierr);
ie = itau;
itauq = ie + *n;
itaup = itauq + *n;
nwork = itaup + *n;
i__1 = *lwork - nwork + 1;
dgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &work[itauq], &work[itaup],
&work[nwork], &i__1, &ierr);
iu = nwork;
nwork = iu + *n * *n;
dbdsdc_((char *)"U", (char *)"I", n, &s[1], &work[ie], &work[iu], n, &vt[vt_offset], ldvt, dum,
idum, &work[nwork], &iwork[1], info, (ftnlen)1, (ftnlen)1);
i__1 = *lwork - nwork + 1;
dormbr_((char *)"Q", (char *)"L", (char *)"N", n, n, n, &work[ir], &ldwrkr, &work[itauq], &work[iu], n,
&work[nwork], &i__1, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1);
i__1 = *lwork - nwork + 1;
dormbr_((char *)"P", (char *)"R", (char *)"T", n, n, n, &work[ir], &ldwrkr, &work[itaup], &vt[vt_offset],
ldvt, &work[nwork], &i__1, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1);
i__1 = *m;
i__2 = ldwrkr;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
i__3 = *m - i__ + 1;
chunk = min(i__3, ldwrkr);
dgemm_((char *)"N", (char *)"N", &chunk, n, n, &c_b84, &a[i__ + a_dim1], lda, &work[iu], n,
&c_b63, &work[ir], &ldwrkr, (ftnlen)1, (ftnlen)1);
dlacpy_((char *)"F", &chunk, n, &work[ir], &ldwrkr, &a[i__ + a_dim1], lda, (ftnlen)1);
}
} else if (wntqs) {
ir = 1;
ldwrkr = *n;
itau = ir + ldwrkr * *n;
nwork = itau + *n;
i__2 = *lwork - nwork + 1;
dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__2, &ierr);
dlacpy_((char *)"U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr, (ftnlen)1);
i__2 = *n - 1;
i__1 = *n - 1;
dlaset_((char *)"L", &i__2, &i__1, &c_b63, &c_b63, &work[ir + 1], &ldwrkr, (ftnlen)1);
i__2 = *lwork - nwork + 1;
dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__2, &ierr);
ie = itau;
itauq = ie + *n;
itaup = itauq + *n;
nwork = itaup + *n;
i__2 = *lwork - nwork + 1;
dgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &work[itauq], &work[itaup],
&work[nwork], &i__2, &ierr);
dbdsdc_((char *)"U", (char *)"I", n, &s[1], &work[ie], &u[u_offset], ldu, &vt[vt_offset], ldvt, dum,
idum, &work[nwork], &iwork[1], info, (ftnlen)1, (ftnlen)1);
i__2 = *lwork - nwork + 1;
dormbr_((char *)"Q", (char *)"L", (char *)"N", n, n, n, &work[ir], &ldwrkr, &work[itauq], &u[u_offset], ldu,
&work[nwork], &i__2, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1);
i__2 = *lwork - nwork + 1;
dormbr_((char *)"P", (char *)"R", (char *)"T", n, n, n, &work[ir], &ldwrkr, &work[itaup], &vt[vt_offset],
ldvt, &work[nwork], &i__2, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1);
dlacpy_((char *)"F", n, n, &u[u_offset], ldu, &work[ir], &ldwrkr, (ftnlen)1);
dgemm_((char *)"N", (char *)"N", m, n, n, &c_b84, &a[a_offset], lda, &work[ir], &ldwrkr, &c_b63,
&u[u_offset], ldu, (ftnlen)1, (ftnlen)1);
} else if (wntqa) {
iu = 1;
ldwrku = *n;
itau = iu + ldwrku * *n;
nwork = itau + *n;
i__2 = *lwork - nwork + 1;
dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__2, &ierr);
dlacpy_((char *)"L", m, n, &a[a_offset], lda, &u[u_offset], ldu, (ftnlen)1);
i__2 = *lwork - nwork + 1;
dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &work[nwork], &i__2, &ierr);
i__2 = *n - 1;
i__1 = *n - 1;
dlaset_((char *)"L", &i__2, &i__1, &c_b63, &c_b63, &a[a_dim1 + 2], lda, (ftnlen)1);
ie = itau;
itauq = ie + *n;
itaup = itauq + *n;
nwork = itaup + *n;
i__2 = *lwork - nwork + 1;
dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &work[itaup],
&work[nwork], &i__2, &ierr);
dbdsdc_((char *)"U", (char *)"I", n, &s[1], &work[ie], &work[iu], n, &vt[vt_offset], ldvt, dum,
idum, &work[nwork], &iwork[1], info, (ftnlen)1, (ftnlen)1);
i__2 = *lwork - nwork + 1;
dormbr_((char *)"Q", (char *)"L", (char *)"N", n, n, n, &a[a_offset], lda, &work[itauq], &work[iu], &ldwrku,
&work[nwork], &i__2, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1);
i__2 = *lwork - nwork + 1;
dormbr_((char *)"P", (char *)"R", (char *)"T", n, n, n, &a[a_offset], lda, &work[itaup], &vt[vt_offset],
ldvt, &work[nwork], &i__2, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1);
dgemm_((char *)"N", (char *)"N", m, n, n, &c_b84, &u[u_offset], ldu, &work[iu], &ldwrku, &c_b63,
&a[a_offset], lda, (ftnlen)1, (ftnlen)1);
dlacpy_((char *)"F", m, n, &a[a_offset], lda, &u[u_offset], ldu, (ftnlen)1);
}
} else {
ie = 1;
itauq = ie + *n;
itaup = itauq + *n;
nwork = itaup + *n;
i__2 = *lwork - nwork + 1;
dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &work[itaup],
&work[nwork], &i__2, &ierr);
if (wntqn) {
dbdsdc_((char *)"U", (char *)"N", n, &s[1], &work[ie], dum, &c__1, dum, &c__1, dum, idum,
&work[nwork], &iwork[1], info, (ftnlen)1, (ftnlen)1);
} else if (wntqo) {
iu = nwork;
if (*lwork >= *m * *n + *n * 3 + bdspac) {
ldwrku = *m;
nwork = iu + ldwrku * *n;
dlaset_((char *)"F", m, n, &c_b63, &c_b63, &work[iu], &ldwrku, (ftnlen)1);
ir = -1;
} else {
ldwrku = *n;
nwork = iu + ldwrku * *n;
ir = nwork;
ldwrkr = (*lwork - *n * *n - *n * 3) / *n;
}
nwork = iu + ldwrku * *n;
dbdsdc_((char *)"U", (char *)"I", n, &s[1], &work[ie], &work[iu], &ldwrku, &vt[vt_offset], ldvt,
dum, idum, &work[nwork], &iwork[1], info, (ftnlen)1, (ftnlen)1);
i__2 = *lwork - nwork + 1;
dormbr_((char *)"P", (char *)"R", (char *)"T", n, n, n, &a[a_offset], lda, &work[itaup], &vt[vt_offset],
ldvt, &work[nwork], &i__2, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1);
if (*lwork >= *m * *n + *n * 3 + bdspac) {
i__2 = *lwork - nwork + 1;
dormbr_((char *)"Q", (char *)"L", (char *)"N", m, n, n, &a[a_offset], lda, &work[itauq], &work[iu],
&ldwrku, &work[nwork], &i__2, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1);
dlacpy_((char *)"F", m, n, &work[iu], &ldwrku, &a[a_offset], lda, (ftnlen)1);
} else {
i__2 = *lwork - nwork + 1;
dorgbr_((char *)"Q", m, n, n, &a[a_offset], lda, &work[itauq], &work[nwork], &i__2,
&ierr, (ftnlen)1);
i__2 = *m;
i__1 = ldwrkr;
for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
i__3 = *m - i__ + 1;
chunk = min(i__3, ldwrkr);
dgemm_((char *)"N", (char *)"N", &chunk, n, n, &c_b84, &a[i__ + a_dim1], lda, &work[iu],
&ldwrku, &c_b63, &work[ir], &ldwrkr, (ftnlen)1, (ftnlen)1);
dlacpy_((char *)"F", &chunk, n, &work[ir], &ldwrkr, &a[i__ + a_dim1], lda,
(ftnlen)1);
}
}
} else if (wntqs) {
dlaset_((char *)"F", m, n, &c_b63, &c_b63, &u[u_offset], ldu, (ftnlen)1);
dbdsdc_((char *)"U", (char *)"I", n, &s[1], &work[ie], &u[u_offset], ldu, &vt[vt_offset], ldvt, dum,
idum, &work[nwork], &iwork[1], info, (ftnlen)1, (ftnlen)1);
i__1 = *lwork - nwork + 1;
dormbr_((char *)"Q", (char *)"L", (char *)"N", m, n, n, &a[a_offset], lda, &work[itauq], &u[u_offset], ldu,
&work[nwork], &i__1, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1);
i__1 = *lwork - nwork + 1;
dormbr_((char *)"P", (char *)"R", (char *)"T", n, n, n, &a[a_offset], lda, &work[itaup], &vt[vt_offset],
ldvt, &work[nwork], &i__1, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1);
} else if (wntqa) {
dlaset_((char *)"F", m, m, &c_b63, &c_b63, &u[u_offset], ldu, (ftnlen)1);
dbdsdc_((char *)"U", (char *)"I", n, &s[1], &work[ie], &u[u_offset], ldu, &vt[vt_offset], ldvt, dum,
idum, &work[nwork], &iwork[1], info, (ftnlen)1, (ftnlen)1);
if (*m > *n) {
i__1 = *m - *n;
i__2 = *m - *n;
dlaset_((char *)"F", &i__1, &i__2, &c_b63, &c_b84, &u[*n + 1 + (*n + 1) * u_dim1], ldu,
(ftnlen)1);
}
i__1 = *lwork - nwork + 1;
dormbr_((char *)"Q", (char *)"L", (char *)"N", m, m, n, &a[a_offset], lda, &work[itauq], &u[u_offset], ldu,
&work[nwork], &i__1, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1);
i__1 = *lwork - nwork + 1;
dormbr_((char *)"P", (char *)"R", (char *)"T", n, n, m, &a[a_offset], lda, &work[itaup], &vt[vt_offset],
ldvt, &work[nwork], &i__1, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1);
}
}
} else {
if (*n >= mnthr) {
if (wntqn) {
itau = 1;
nwork = itau + *m;
i__1 = *lwork - nwork + 1;
dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1, &ierr);
i__1 = *m - 1;
i__2 = *m - 1;
dlaset_((char *)"U", &i__1, &i__2, &c_b63, &c_b63, &a[(a_dim1 << 1) + 1], lda, (ftnlen)1);
ie = 1;
itauq = ie + *m;
itaup = itauq + *m;
nwork = itaup + *m;
i__1 = *lwork - nwork + 1;
dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &work[itaup],
&work[nwork], &i__1, &ierr);
nwork = ie + *m;
dbdsdc_((char *)"U", (char *)"N", m, &s[1], &work[ie], dum, &c__1, dum, &c__1, dum, idum,
&work[nwork], &iwork[1], info, (ftnlen)1, (ftnlen)1);
} else if (wntqo) {
ivt = 1;
il = ivt + *m * *m;
if (*lwork >= *m * *n + *m * *m + *m * 3 + bdspac) {
ldwrkl = *m;
chunk = *n;
} else {
ldwrkl = *m;
chunk = (*lwork - *m * *m) / *m;
}
itau = il + ldwrkl * *m;
nwork = itau + *m;
i__1 = *lwork - nwork + 1;
dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1, &ierr);
dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[il], &ldwrkl, (ftnlen)1);
i__1 = *m - 1;
i__2 = *m - 1;
dlaset_((char *)"U", &i__1, &i__2, &c_b63, &c_b63, &work[il + ldwrkl], &ldwrkl, (ftnlen)1);
i__1 = *lwork - nwork + 1;
dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[nwork], &i__1, &ierr);
ie = itau;
itauq = ie + *m;
itaup = itauq + *m;
nwork = itaup + *m;
i__1 = *lwork - nwork + 1;
dgebrd_(m, m, &work[il], &ldwrkl, &s[1], &work[ie], &work[itauq], &work[itaup],
&work[nwork], &i__1, &ierr);
dbdsdc_((char *)"U", (char *)"I", m, &s[1], &work[ie], &u[u_offset], ldu, &work[ivt], m, dum, idum,
&work[nwork], &iwork[1], info, (ftnlen)1, (ftnlen)1);
i__1 = *lwork - nwork + 1;
dormbr_((char *)"Q", (char *)"L", (char *)"N", m, m, m, &work[il], &ldwrkl, &work[itauq], &u[u_offset], ldu,
&work[nwork], &i__1, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1);
i__1 = *lwork - nwork + 1;
dormbr_((char *)"P", (char *)"R", (char *)"T", m, m, m, &work[il], &ldwrkl, &work[itaup], &work[ivt], m,
&work[nwork], &i__1, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1);
i__1 = *n;
i__2 = chunk;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
i__3 = *n - i__ + 1;
blk = min(i__3, chunk);
dgemm_((char *)"N", (char *)"N", m, &blk, m, &c_b84, &work[ivt], m, &a[i__ * a_dim1 + 1], lda,
&c_b63, &work[il], &ldwrkl, (ftnlen)1, (ftnlen)1);
dlacpy_((char *)"F", m, &blk, &work[il], &ldwrkl, &a[i__ * a_dim1 + 1], lda, (ftnlen)1);
}
} else if (wntqs) {
il = 1;
ldwrkl = *m;
itau = il + ldwrkl * *m;
nwork = itau + *m;
i__2 = *lwork - nwork + 1;
dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__2, &ierr);
dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[il], &ldwrkl, (ftnlen)1);
i__2 = *m - 1;
i__1 = *m - 1;
dlaset_((char *)"U", &i__2, &i__1, &c_b63, &c_b63, &work[il + ldwrkl], &ldwrkl, (ftnlen)1);
i__2 = *lwork - nwork + 1;
dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[nwork], &i__2, &ierr);
ie = itau;
itauq = ie + *m;
itaup = itauq + *m;
nwork = itaup + *m;
i__2 = *lwork - nwork + 1;
dgebrd_(m, m, &work[il], &ldwrkl, &s[1], &work[ie], &work[itauq], &work[itaup],
&work[nwork], &i__2, &ierr);
dbdsdc_((char *)"U", (char *)"I", m, &s[1], &work[ie], &u[u_offset], ldu, &vt[vt_offset], ldvt, dum,
idum, &work[nwork], &iwork[1], info, (ftnlen)1, (ftnlen)1);
i__2 = *lwork - nwork + 1;
dormbr_((char *)"Q", (char *)"L", (char *)"N", m, m, m, &work[il], &ldwrkl, &work[itauq], &u[u_offset], ldu,
&work[nwork], &i__2, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1);
i__2 = *lwork - nwork + 1;
dormbr_((char *)"P", (char *)"R", (char *)"T", m, m, m, &work[il], &ldwrkl, &work[itaup], &vt[vt_offset],
ldvt, &work[nwork], &i__2, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1);
dlacpy_((char *)"F", m, m, &vt[vt_offset], ldvt, &work[il], &ldwrkl, (ftnlen)1);
dgemm_((char *)"N", (char *)"N", m, n, m, &c_b84, &work[il], &ldwrkl, &a[a_offset], lda, &c_b63,
&vt[vt_offset], ldvt, (ftnlen)1, (ftnlen)1);
} else if (wntqa) {
ivt = 1;
ldwkvt = *m;
itau = ivt + ldwkvt * *m;
nwork = itau + *m;
i__2 = *lwork - nwork + 1;
dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__2, &ierr);
dlacpy_((char *)"U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt, (ftnlen)1);
i__2 = *lwork - nwork + 1;
dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &work[nwork], &i__2, &ierr);
i__2 = *m - 1;
i__1 = *m - 1;
dlaset_((char *)"U", &i__2, &i__1, &c_b63, &c_b63, &a[(a_dim1 << 1) + 1], lda, (ftnlen)1);
ie = itau;
itauq = ie + *m;
itaup = itauq + *m;
nwork = itaup + *m;
i__2 = *lwork - nwork + 1;
dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &work[itaup],
&work[nwork], &i__2, &ierr);
dbdsdc_((char *)"U", (char *)"I", m, &s[1], &work[ie], &u[u_offset], ldu, &work[ivt], &ldwkvt, dum,
idum, &work[nwork], &iwork[1], info, (ftnlen)1, (ftnlen)1);
i__2 = *lwork - nwork + 1;
dormbr_((char *)"Q", (char *)"L", (char *)"N", m, m, m, &a[a_offset], lda, &work[itauq], &u[u_offset], ldu,
&work[nwork], &i__2, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1);
i__2 = *lwork - nwork + 1;
dormbr_((char *)"P", (char *)"R", (char *)"T", m, m, m, &a[a_offset], lda, &work[itaup], &work[ivt],
&ldwkvt, &work[nwork], &i__2, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1);
dgemm_((char *)"N", (char *)"N", m, n, m, &c_b84, &work[ivt], &ldwkvt, &vt[vt_offset], ldvt, &c_b63,
&a[a_offset], lda, (ftnlen)1, (ftnlen)1);
dlacpy_((char *)"F", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt, (ftnlen)1);
}
} else {
ie = 1;
itauq = ie + *m;
itaup = itauq + *m;
nwork = itaup + *m;
i__2 = *lwork - nwork + 1;
dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &work[itaup],
&work[nwork], &i__2, &ierr);
if (wntqn) {
dbdsdc_((char *)"L", (char *)"N", m, &s[1], &work[ie], dum, &c__1, dum, &c__1, dum, idum,
&work[nwork], &iwork[1], info, (ftnlen)1, (ftnlen)1);
} else if (wntqo) {
ldwkvt = *m;
ivt = nwork;
if (*lwork >= *m * *n + *m * 3 + bdspac) {
dlaset_((char *)"F", m, n, &c_b63, &c_b63, &work[ivt], &ldwkvt, (ftnlen)1);
nwork = ivt + ldwkvt * *n;
il = -1;
} else {
nwork = ivt + ldwkvt * *m;
il = nwork;
chunk = (*lwork - *m * *m - *m * 3) / *m;
}
dbdsdc_((char *)"L", (char *)"I", m, &s[1], &work[ie], &u[u_offset], ldu, &work[ivt], &ldwkvt, dum,
idum, &work[nwork], &iwork[1], info, (ftnlen)1, (ftnlen)1);
i__2 = *lwork - nwork + 1;
dormbr_((char *)"Q", (char *)"L", (char *)"N", m, m, n, &a[a_offset], lda, &work[itauq], &u[u_offset], ldu,
&work[nwork], &i__2, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1);
if (*lwork >= *m * *n + *m * 3 + bdspac) {
i__2 = *lwork - nwork + 1;
dormbr_((char *)"P", (char *)"R", (char *)"T", m, n, m, &a[a_offset], lda, &work[itaup], &work[ivt],
&ldwkvt, &work[nwork], &i__2, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1);
dlacpy_((char *)"F", m, n, &work[ivt], &ldwkvt, &a[a_offset], lda, (ftnlen)1);
} else {
i__2 = *lwork - nwork + 1;
dorgbr_((char *)"P", m, n, m, &a[a_offset], lda, &work[itaup], &work[nwork], &i__2,
&ierr, (ftnlen)1);
i__2 = *n;
i__1 = chunk;
for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
i__3 = *n - i__ + 1;
blk = min(i__3, chunk);
dgemm_((char *)"N", (char *)"N", m, &blk, m, &c_b84, &work[ivt], &ldwkvt,
&a[i__ * a_dim1 + 1], lda, &c_b63, &work[il], m, (ftnlen)1,
(ftnlen)1);
dlacpy_((char *)"F", m, &blk, &work[il], m, &a[i__ * a_dim1 + 1], lda, (ftnlen)1);
}
}
} else if (wntqs) {
dlaset_((char *)"F", m, n, &c_b63, &c_b63, &vt[vt_offset], ldvt, (ftnlen)1);
dbdsdc_((char *)"L", (char *)"I", m, &s[1], &work[ie], &u[u_offset], ldu, &vt[vt_offset], ldvt, dum,
idum, &work[nwork], &iwork[1], info, (ftnlen)1, (ftnlen)1);
i__1 = *lwork - nwork + 1;
dormbr_((char *)"Q", (char *)"L", (char *)"N", m, m, n, &a[a_offset], lda, &work[itauq], &u[u_offset], ldu,
&work[nwork], &i__1, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1);
i__1 = *lwork - nwork + 1;
dormbr_((char *)"P", (char *)"R", (char *)"T", m, n, m, &a[a_offset], lda, &work[itaup], &vt[vt_offset],
ldvt, &work[nwork], &i__1, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1);
} else if (wntqa) {
dlaset_((char *)"F", n, n, &c_b63, &c_b63, &vt[vt_offset], ldvt, (ftnlen)1);
dbdsdc_((char *)"L", (char *)"I", m, &s[1], &work[ie], &u[u_offset], ldu, &vt[vt_offset], ldvt, dum,
idum, &work[nwork], &iwork[1], info, (ftnlen)1, (ftnlen)1);
if (*n > *m) {
i__1 = *n - *m;
i__2 = *n - *m;
dlaset_((char *)"F", &i__1, &i__2, &c_b63, &c_b84, &vt[*m + 1 + (*m + 1) * vt_dim1],
ldvt, (ftnlen)1);
}
i__1 = *lwork - nwork + 1;
dormbr_((char *)"Q", (char *)"L", (char *)"N", m, m, n, &a[a_offset], lda, &work[itauq], &u[u_offset], ldu,
&work[nwork], &i__1, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1);
i__1 = *lwork - nwork + 1;
dormbr_((char *)"P", (char *)"R", (char *)"T", n, n, m, &a[a_offset], lda, &work[itaup], &vt[vt_offset],
ldvt, &work[nwork], &i__1, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1);
}
}
}
if (iscl == 1) {
if (anrm > bignum) {
dlascl_((char *)"G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &minmn, &ierr,
(ftnlen)1);
}
if (anrm < smlnum) {
dlascl_((char *)"G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &minmn, &ierr,
(ftnlen)1);
}
}
work[1] = (doublereal)maxwrk;
return 0;
}
#ifdef __cplusplus
}
#endif

145
lib/linalg/dhseqr.cpp Normal file
View File

@ -0,0 +1,145 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static doublereal c_b11 = 0.;
static doublereal c_b12 = 1.;
static integer c__12 = 12;
static integer c__2 = 2;
static integer c__49 = 49;
int dhseqr_(char *job, char *compz, integer *n, integer *ilo, integer *ihi, doublereal *h__,
integer *ldh, doublereal *wr, doublereal *wi, doublereal *z__, integer *ldz,
doublereal *work, integer *lwork, integer *info, ftnlen job_len, ftnlen compz_len)
{
address a__1[2];
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2[2], i__3;
doublereal d__1;
char ch__1[2];
int s_lmp_cat(char *, char **, integer *, integer *, ftnlen);
integer i__;
doublereal hl[2401];
integer kbot, nmin;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
logical initz;
doublereal workl[49];
logical wantt, wantz;
extern int dlaqr0_(logical *, logical *, integer *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *),
dlahqr_(logical *, logical *, integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *, integer *,
integer *),
dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *,
ftnlen),
dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *,
ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
extern int xerbla_(char *, integer *, ftnlen);
logical lquery;
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--wr;
--wi;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
wantt = lsame_(job, (char *)"S", (ftnlen)1, (ftnlen)1);
initz = lsame_(compz, (char *)"I", (ftnlen)1, (ftnlen)1);
wantz = initz || lsame_(compz, (char *)"V", (ftnlen)1, (ftnlen)1);
work[1] = (doublereal)max(1, *n);
lquery = *lwork == -1;
*info = 0;
if (!lsame_(job, (char *)"E", (ftnlen)1, (ftnlen)1) && !wantt) {
*info = -1;
} else if (!lsame_(compz, (char *)"N", (ftnlen)1, (ftnlen)1) && !wantz) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ilo < 1 || *ilo > max(1, *n)) {
*info = -4;
} else if (*ihi < min(*ilo, *n) || *ihi > *n) {
*info = -5;
} else if (*ldh < max(1, *n)) {
*info = -7;
} else if (*ldz < 1 || wantz && *ldz < max(1, *n)) {
*info = -11;
} else if (*lwork < max(1, *n) && !lquery) {
*info = -13;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"DHSEQR", &i__1, (ftnlen)6);
return 0;
} else if (*n == 0) {
return 0;
} else if (lquery) {
dlaqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &wi[1], ilo, ihi,
&z__[z_offset], ldz, &work[1], lwork, info);
d__1 = (doublereal)max(1, *n);
work[1] = max(d__1, work[1]);
return 0;
} else {
i__1 = *ilo - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
wr[i__] = h__[i__ + i__ * h_dim1];
wi[i__] = 0.;
}
i__1 = *n;
for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
wr[i__] = h__[i__ + i__ * h_dim1];
wi[i__] = 0.;
}
if (initz) {
dlaset_((char *)"A", n, n, &c_b11, &c_b12, &z__[z_offset], ldz, (ftnlen)1);
}
if (*ilo == *ihi) {
wr[*ilo] = h__[*ilo + *ilo * h_dim1];
wi[*ilo] = 0.;
return 0;
}
i__2[0] = 1, a__1[0] = job;
i__2[1] = 1, a__1[1] = compz;
s_lmp_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2);
nmin = ilaenv_(&c__12, (char *)"DHSEQR", ch__1, n, ilo, ihi, lwork, (ftnlen)6, (ftnlen)2);
nmin = max(11, nmin);
if (*n > nmin) {
dlaqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &wi[1], ilo, ihi,
&z__[z_offset], ldz, &work[1], lwork, info);
} else {
dlahqr_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &wi[1], ilo, ihi,
&z__[z_offset], ldz, info);
if (*info > 0) {
kbot = *info;
if (*n >= 49) {
dlaqr0_(&wantt, &wantz, n, ilo, &kbot, &h__[h_offset], ldh, &wr[1], &wi[1], ilo,
ihi, &z__[z_offset], ldz, &work[1], lwork, info);
} else {
dlacpy_((char *)"A", n, n, &h__[h_offset], ldh, hl, &c__49, (ftnlen)1);
hl[*n + 1 + *n * 49 - 50] = 0.;
i__1 = 49 - *n;
dlaset_((char *)"A", &c__49, &i__1, &c_b11, &c_b11, &hl[(*n + 1) * 49 - 49], &c__49,
(ftnlen)1);
dlaqr0_(&wantt, &wantz, &c__49, ilo, &kbot, hl, &c__49, &wr[1], &wi[1], ilo,
ihi, &z__[z_offset], ldz, workl, &c__49, info);
if (wantt || *info != 0) {
dlacpy_((char *)"A", n, n, hl, &c__49, &h__[h_offset], ldh, (ftnlen)1);
}
}
}
}
if ((wantt || *info != 0) && *n > 2) {
i__1 = *n - 2;
i__3 = *n - 2;
dlaset_((char *)"L", &i__1, &i__3, &c_b11, &c_b11, &h__[h_dim1 + 3], ldh, (ftnlen)1);
}
d__1 = (doublereal)max(1, *n);
work[1] = max(d__1, work[1]);
}
return 0;
}
#ifdef __cplusplus
}
#endif

214
lib/linalg/dlaexc.cpp Normal file
View File

@ -0,0 +1,214 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static integer c__1 = 1;
static integer c__4 = 4;
static logical c_false = FALSE_;
static integer c_n1 = -1;
static integer c__2 = 2;
static integer c__3 = 3;
int dlaexc_(logical *wantq, integer *n, doublereal *t, integer *ldt, doublereal *q, integer *ldq,
integer *j1, integer *n1, integer *n2, doublereal *work, integer *info)
{
integer q_dim1, q_offset, t_dim1, t_offset, i__1;
doublereal d__1, d__2, d__3;
doublereal d__[16];
integer k;
doublereal u[3], x[4];
integer j2, j3, j4;
doublereal u1[3], u2[3];
integer nd;
doublereal cs, t11, t22, t33, sn, wi1, wi2, wr1, wr2, eps, tau, tau1, tau2;
integer ierr;
doublereal temp;
extern int drot_(integer *, doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *);
doublereal scale, dnorm, xnorm;
extern int dlanv2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, doublereal *),
dlasy2_(logical *, logical *, integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
extern doublereal dlamch_(char *, ftnlen),
dlange_(char *, integer *, integer *, doublereal *, integer *, doublereal *, ftnlen);
extern int dlarfg_(integer *, doublereal *, doublereal *, integer *, doublereal *),
dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *,
ftnlen),
dlartg_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *),
dlarfx_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, ftnlen);
doublereal thresh, smlnum;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--work;
*info = 0;
if (*n == 0 || *n1 == 0 || *n2 == 0) {
return 0;
}
if (*j1 + *n1 > *n) {
return 0;
}
j2 = *j1 + 1;
j3 = *j1 + 2;
j4 = *j1 + 3;
if (*n1 == 1 && *n2 == 1) {
t11 = t[*j1 + *j1 * t_dim1];
t22 = t[j2 + j2 * t_dim1];
d__1 = t22 - t11;
dlartg_(&t[*j1 + j2 * t_dim1], &d__1, &cs, &sn, &temp);
if (j3 <= *n) {
i__1 = *n - *j1 - 1;
drot_(&i__1, &t[*j1 + j3 * t_dim1], ldt, &t[j2 + j3 * t_dim1], ldt, &cs, &sn);
}
i__1 = *j1 - 1;
drot_(&i__1, &t[*j1 * t_dim1 + 1], &c__1, &t[j2 * t_dim1 + 1], &c__1, &cs, &sn);
t[*j1 + *j1 * t_dim1] = t22;
t[j2 + j2 * t_dim1] = t11;
if (*wantq) {
drot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[j2 * q_dim1 + 1], &c__1, &cs, &sn);
}
} else {
nd = *n1 + *n2;
dlacpy_((char *)"Full", &nd, &nd, &t[*j1 + *j1 * t_dim1], ldt, d__, &c__4, (ftnlen)4);
dnorm = dlange_((char *)"Max", &nd, &nd, d__, &c__4, &work[1], (ftnlen)3);
eps = dlamch_((char *)"P", (ftnlen)1);
smlnum = dlamch_((char *)"S", (ftnlen)1) / eps;
d__1 = eps * 10. * dnorm;
thresh = max(d__1, smlnum);
dlasy2_(&c_false, &c_false, &c_n1, n1, n2, d__, &c__4, &d__[*n1 + 1 + (*n1 + 1 << 2) - 5],
&c__4, &d__[(*n1 + 1 << 2) - 4], &c__4, &scale, x, &c__2, &xnorm, &ierr);
k = *n1 + *n1 + *n2 - 3;
switch (k) {
case 1:
goto L10;
case 2:
goto L20;
case 3:
goto L30;
}
L10:
u[0] = scale;
u[1] = x[0];
u[2] = x[2];
dlarfg_(&c__3, &u[2], u, &c__1, &tau);
u[2] = 1.;
t11 = t[*j1 + *j1 * t_dim1];
dlarfx_((char *)"L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1], (ftnlen)1);
dlarfx_((char *)"R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1], (ftnlen)1);
d__2 = abs(d__[2]), d__3 = abs(d__[6]), d__2 = max(d__2, d__3),
d__3 = (d__1 = d__[10] - t11, abs(d__1));
if (max(d__2, d__3) > thresh) {
goto L50;
}
i__1 = *n - *j1 + 1;
dlarfx_((char *)"L", &c__3, &i__1, u, &tau, &t[*j1 + *j1 * t_dim1], ldt, &work[1], (ftnlen)1);
dlarfx_((char *)"R", &j2, &c__3, u, &tau, &t[*j1 * t_dim1 + 1], ldt, &work[1], (ftnlen)1);
t[j3 + *j1 * t_dim1] = 0.;
t[j3 + j2 * t_dim1] = 0.;
t[j3 + j3 * t_dim1] = t11;
if (*wantq) {
dlarfx_((char *)"R", n, &c__3, u, &tau, &q[*j1 * q_dim1 + 1], ldq, &work[1], (ftnlen)1);
}
goto L40;
L20:
u[0] = -x[0];
u[1] = -x[1];
u[2] = scale;
dlarfg_(&c__3, u, &u[1], &c__1, &tau);
u[0] = 1.;
t33 = t[j3 + j3 * t_dim1];
dlarfx_((char *)"L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1], (ftnlen)1);
dlarfx_((char *)"R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1], (ftnlen)1);
d__2 = abs(d__[1]), d__3 = abs(d__[2]), d__2 = max(d__2, d__3),
d__3 = (d__1 = d__[0] - t33, abs(d__1));
if (max(d__2, d__3) > thresh) {
goto L50;
}
dlarfx_((char *)"R", &j3, &c__3, u, &tau, &t[*j1 * t_dim1 + 1], ldt, &work[1], (ftnlen)1);
i__1 = *n - *j1;
dlarfx_((char *)"L", &c__3, &i__1, u, &tau, &t[*j1 + j2 * t_dim1], ldt, &work[1], (ftnlen)1);
t[*j1 + *j1 * t_dim1] = t33;
t[j2 + *j1 * t_dim1] = 0.;
t[j3 + *j1 * t_dim1] = 0.;
if (*wantq) {
dlarfx_((char *)"R", n, &c__3, u, &tau, &q[*j1 * q_dim1 + 1], ldq, &work[1], (ftnlen)1);
}
goto L40;
L30:
u1[0] = -x[0];
u1[1] = -x[1];
u1[2] = scale;
dlarfg_(&c__3, u1, &u1[1], &c__1, &tau1);
u1[0] = 1.;
temp = -tau1 * (x[2] + u1[1] * x[3]);
u2[0] = -temp * u1[1] - x[3];
u2[1] = -temp * u1[2];
u2[2] = scale;
dlarfg_(&c__3, u2, &u2[1], &c__1, &tau2);
u2[0] = 1.;
dlarfx_((char *)"L", &c__3, &c__4, u1, &tau1, d__, &c__4, &work[1], (ftnlen)1);
dlarfx_((char *)"R", &c__4, &c__3, u1, &tau1, d__, &c__4, &work[1], (ftnlen)1);
dlarfx_((char *)"L", &c__3, &c__4, u2, &tau2, &d__[1], &c__4, &work[1], (ftnlen)1);
dlarfx_((char *)"R", &c__4, &c__3, u2, &tau2, &d__[4], &c__4, &work[1], (ftnlen)1);
d__1 = abs(d__[2]), d__2 = abs(d__[6]), d__1 = max(d__1, d__2), d__2 = abs(d__[3]),
d__1 = max(d__1, d__2), d__2 = abs(d__[7]);
if (max(d__1, d__2) > thresh) {
goto L50;
}
i__1 = *n - *j1 + 1;
dlarfx_((char *)"L", &c__3, &i__1, u1, &tau1, &t[*j1 + *j1 * t_dim1], ldt, &work[1], (ftnlen)1);
dlarfx_((char *)"R", &j4, &c__3, u1, &tau1, &t[*j1 * t_dim1 + 1], ldt, &work[1], (ftnlen)1);
i__1 = *n - *j1 + 1;
dlarfx_((char *)"L", &c__3, &i__1, u2, &tau2, &t[j2 + *j1 * t_dim1], ldt, &work[1], (ftnlen)1);
dlarfx_((char *)"R", &j4, &c__3, u2, &tau2, &t[j2 * t_dim1 + 1], ldt, &work[1], (ftnlen)1);
t[j3 + *j1 * t_dim1] = 0.;
t[j3 + j2 * t_dim1] = 0.;
t[j4 + *j1 * t_dim1] = 0.;
t[j4 + j2 * t_dim1] = 0.;
if (*wantq) {
dlarfx_((char *)"R", n, &c__3, u1, &tau1, &q[*j1 * q_dim1 + 1], ldq, &work[1], (ftnlen)1);
dlarfx_((char *)"R", n, &c__3, u2, &tau2, &q[j2 * q_dim1 + 1], ldq, &work[1], (ftnlen)1);
}
L40:
if (*n2 == 2) {
dlanv2_(&t[*j1 + *j1 * t_dim1], &t[*j1 + j2 * t_dim1], &t[j2 + *j1 * t_dim1],
&t[j2 + j2 * t_dim1], &wr1, &wi1, &wr2, &wi2, &cs, &sn);
i__1 = *n - *j1 - 1;
drot_(&i__1, &t[*j1 + (*j1 + 2) * t_dim1], ldt, &t[j2 + (*j1 + 2) * t_dim1], ldt, &cs,
&sn);
i__1 = *j1 - 1;
drot_(&i__1, &t[*j1 * t_dim1 + 1], &c__1, &t[j2 * t_dim1 + 1], &c__1, &cs, &sn);
if (*wantq) {
drot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[j2 * q_dim1 + 1], &c__1, &cs, &sn);
}
}
if (*n1 == 2) {
j3 = *j1 + *n2;
j4 = j3 + 1;
dlanv2_(&t[j3 + j3 * t_dim1], &t[j3 + j4 * t_dim1], &t[j4 + j3 * t_dim1],
&t[j4 + j4 * t_dim1], &wr1, &wi1, &wr2, &wi2, &cs, &sn);
if (j3 + 2 <= *n) {
i__1 = *n - j3 - 1;
drot_(&i__1, &t[j3 + (j3 + 2) * t_dim1], ldt, &t[j4 + (j3 + 2) * t_dim1], ldt, &cs,
&sn);
}
i__1 = j3 - 1;
drot_(&i__1, &t[j3 * t_dim1 + 1], &c__1, &t[j4 * t_dim1 + 1], &c__1, &cs, &sn);
if (*wantq) {
drot_(n, &q[j3 * q_dim1 + 1], &c__1, &q[j4 * q_dim1 + 1], &c__1, &cs, &sn);
}
}
}
return 0;
L50:
*info = 1;
return 0;
}
#ifdef __cplusplus
}
#endif

311
lib/linalg/dlahqr.cpp Normal file
View File

@ -0,0 +1,311 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static integer c__1 = 1;
int dlahqr_(logical *wantt, logical *wantz, integer *n, integer *ilo, integer *ihi, doublereal *h__,
integer *ldh, doublereal *wr, doublereal *wi, integer *iloz, integer *ihiz,
doublereal *z__, integer *ldz, integer *info)
{
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4;
double sqrt(doublereal);
integer i__, j, k, l, m;
doublereal s, v[3];
integer i1, i2;
doublereal t1, t2, t3, v2, v3, aa, ab, ba, bb, h11, h12, h21, h22, cs;
integer nh;
doublereal sn;
integer nr;
doublereal tr;
integer nz;
doublereal det, h21s;
integer its;
doublereal ulp, sum, tst, rt1i, rt2i, rt1r, rt2r;
extern int drot_(integer *, doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *),
dcopy_(integer *, doublereal *, integer *, doublereal *, integer *);
integer itmax;
extern int dlanv2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, doublereal *),
dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *, ftnlen);
extern int dlarfg_(integer *, doublereal *, doublereal *, integer *, doublereal *);
doublereal safmin, safmax, rtdisc, smlnum;
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--wr;
--wi;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
*info = 0;
if (*n == 0) {
return 0;
}
if (*ilo == *ihi) {
wr[*ilo] = h__[*ilo + *ilo * h_dim1];
wi[*ilo] = 0.;
return 0;
}
i__1 = *ihi - 3;
for (j = *ilo; j <= i__1; ++j) {
h__[j + 2 + j * h_dim1] = 0.;
h__[j + 3 + j * h_dim1] = 0.;
}
if (*ilo <= *ihi - 2) {
h__[*ihi + (*ihi - 2) * h_dim1] = 0.;
}
nh = *ihi - *ilo + 1;
nz = *ihiz - *iloz + 1;
safmin = dlamch_((char *)"SAFE MINIMUM", (ftnlen)12);
safmax = 1. / safmin;
dlabad_(&safmin, &safmax);
ulp = dlamch_((char *)"PRECISION", (ftnlen)9);
smlnum = safmin * ((doublereal)nh / ulp);
if (*wantt) {
i1 = 1;
i2 = *n;
}
itmax = max(10, nh) * 30;
i__ = *ihi;
L20:
l = *ilo;
if (i__ < *ilo) {
goto L160;
}
i__1 = itmax;
for (its = 0; its <= i__1; ++its) {
i__2 = l + 1;
for (k = i__; k >= i__2; --k) {
if ((d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)) <= smlnum) {
goto L40;
}
tst = (d__1 = h__[k - 1 + (k - 1) * h_dim1], abs(d__1)) +
(d__2 = h__[k + k * h_dim1], abs(d__2));
if (tst == 0.) {
if (k - 2 >= *ilo) {
tst += (d__1 = h__[k - 1 + (k - 2) * h_dim1], abs(d__1));
}
if (k + 1 <= *ihi) {
tst += (d__1 = h__[k + 1 + k * h_dim1], abs(d__1));
}
}
if ((d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)) <= ulp * tst) {
d__3 = (d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)),
d__4 = (d__2 = h__[k - 1 + k * h_dim1], abs(d__2));
ab = max(d__3, d__4);
d__3 = (d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)),
d__4 = (d__2 = h__[k - 1 + k * h_dim1], abs(d__2));
ba = min(d__3, d__4);
d__3 = (d__1 = h__[k + k * h_dim1], abs(d__1)),
d__4 = (d__2 = h__[k - 1 + (k - 1) * h_dim1] - h__[k + k * h_dim1], abs(d__2));
aa = max(d__3, d__4);
d__3 = (d__1 = h__[k + k * h_dim1], abs(d__1)),
d__4 = (d__2 = h__[k - 1 + (k - 1) * h_dim1] - h__[k + k * h_dim1], abs(d__2));
bb = min(d__3, d__4);
s = aa + ab;
d__1 = smlnum, d__2 = ulp * (bb * (aa / s));
if (ba * (ab / s) <= max(d__1, d__2)) {
goto L40;
}
}
}
L40:
l = k;
if (l > *ilo) {
h__[l + (l - 1) * h_dim1] = 0.;
}
if (l >= i__ - 1) {
goto L150;
}
if (!(*wantt)) {
i1 = l;
i2 = i__;
}
if (its == 10) {
s = (d__1 = h__[l + 1 + l * h_dim1], abs(d__1)) +
(d__2 = h__[l + 2 + (l + 1) * h_dim1], abs(d__2));
h11 = s * .75 + h__[l + l * h_dim1];
h12 = s * -.4375;
h21 = s;
h22 = h11;
} else if (its == 20) {
s = (d__1 = h__[i__ + (i__ - 1) * h_dim1], abs(d__1)) +
(d__2 = h__[i__ - 1 + (i__ - 2) * h_dim1], abs(d__2));
h11 = s * .75 + h__[i__ + i__ * h_dim1];
h12 = s * -.4375;
h21 = s;
h22 = h11;
} else {
h11 = h__[i__ - 1 + (i__ - 1) * h_dim1];
h21 = h__[i__ + (i__ - 1) * h_dim1];
h12 = h__[i__ - 1 + i__ * h_dim1];
h22 = h__[i__ + i__ * h_dim1];
}
s = abs(h11) + abs(h12) + abs(h21) + abs(h22);
if (s == 0.) {
rt1r = 0.;
rt1i = 0.;
rt2r = 0.;
rt2i = 0.;
} else {
h11 /= s;
h21 /= s;
h12 /= s;
h22 /= s;
tr = (h11 + h22) / 2.;
det = (h11 - tr) * (h22 - tr) - h12 * h21;
rtdisc = sqrt((abs(det)));
if (det >= 0.) {
rt1r = tr * s;
rt2r = rt1r;
rt1i = rtdisc * s;
rt2i = -rt1i;
} else {
rt1r = tr + rtdisc;
rt2r = tr - rtdisc;
if ((d__1 = rt1r - h22, abs(d__1)) <= (d__2 = rt2r - h22, abs(d__2))) {
rt1r *= s;
rt2r = rt1r;
} else {
rt2r *= s;
rt1r = rt2r;
}
rt1i = 0.;
rt2i = 0.;
}
}
i__2 = l;
for (m = i__ - 2; m >= i__2; --m) {
h21s = h__[m + 1 + m * h_dim1];
s = (d__1 = h__[m + m * h_dim1] - rt2r, abs(d__1)) + abs(rt2i) + abs(h21s);
h21s = h__[m + 1 + m * h_dim1] / s;
v[0] = h21s * h__[m + (m + 1) * h_dim1] +
(h__[m + m * h_dim1] - rt1r) * ((h__[m + m * h_dim1] - rt2r) / s) -
rt1i * (rt2i / s);
v[1] = h21s * (h__[m + m * h_dim1] + h__[m + 1 + (m + 1) * h_dim1] - rt1r - rt2r);
v[2] = h21s * h__[m + 2 + (m + 1) * h_dim1];
s = abs(v[0]) + abs(v[1]) + abs(v[2]);
v[0] /= s;
v[1] /= s;
v[2] /= s;
if (m == l) {
goto L60;
}
if ((d__1 = h__[m + (m - 1) * h_dim1], abs(d__1)) * (abs(v[1]) + abs(v[2])) <=
ulp * abs(v[0]) *
((d__2 = h__[m - 1 + (m - 1) * h_dim1], abs(d__2)) +
(d__3 = h__[m + m * h_dim1], abs(d__3)) +
(d__4 = h__[m + 1 + (m + 1) * h_dim1], abs(d__4)))) {
goto L60;
}
}
L60:
i__2 = i__ - 1;
for (k = m; k <= i__2; ++k) {
i__3 = 3, i__4 = i__ - k + 1;
nr = min(i__3, i__4);
if (k > m) {
dcopy_(&nr, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1);
}
dlarfg_(&nr, v, &v[1], &c__1, &t1);
if (k > m) {
h__[k + (k - 1) * h_dim1] = v[0];
h__[k + 1 + (k - 1) * h_dim1] = 0.;
if (k < i__ - 1) {
h__[k + 2 + (k - 1) * h_dim1] = 0.;
}
} else if (m > l) {
h__[k + (k - 1) * h_dim1] *= 1. - t1;
}
v2 = v[1];
t2 = t1 * v2;
if (nr == 3) {
v3 = v[2];
t3 = t1 * v3;
i__3 = i2;
for (j = k; j <= i__3; ++j) {
sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1] +
v3 * h__[k + 2 + j * h_dim1];
h__[k + j * h_dim1] -= sum * t1;
h__[k + 1 + j * h_dim1] -= sum * t2;
h__[k + 2 + j * h_dim1] -= sum * t3;
}
i__4 = k + 3;
i__3 = min(i__4, i__);
for (j = i1; j <= i__3; ++j) {
sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1] +
v3 * h__[j + (k + 2) * h_dim1];
h__[j + k * h_dim1] -= sum * t1;
h__[j + (k + 1) * h_dim1] -= sum * t2;
h__[j + (k + 2) * h_dim1] -= sum * t3;
}
if (*wantz) {
i__3 = *ihiz;
for (j = *iloz; j <= i__3; ++j) {
sum = z__[j + k * z_dim1] + v2 * z__[j + (k + 1) * z_dim1] +
v3 * z__[j + (k + 2) * z_dim1];
z__[j + k * z_dim1] -= sum * t1;
z__[j + (k + 1) * z_dim1] -= sum * t2;
z__[j + (k + 2) * z_dim1] -= sum * t3;
}
}
} else if (nr == 2) {
i__3 = i2;
for (j = k; j <= i__3; ++j) {
sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1];
h__[k + j * h_dim1] -= sum * t1;
h__[k + 1 + j * h_dim1] -= sum * t2;
}
i__3 = i__;
for (j = i1; j <= i__3; ++j) {
sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1];
h__[j + k * h_dim1] -= sum * t1;
h__[j + (k + 1) * h_dim1] -= sum * t2;
}
if (*wantz) {
i__3 = *ihiz;
for (j = *iloz; j <= i__3; ++j) {
sum = z__[j + k * z_dim1] + v2 * z__[j + (k + 1) * z_dim1];
z__[j + k * z_dim1] -= sum * t1;
z__[j + (k + 1) * z_dim1] -= sum * t2;
}
}
}
}
}
*info = i__;
return 0;
L150:
if (l == i__) {
wr[i__] = h__[i__ + i__ * h_dim1];
wi[i__] = 0.;
} else if (l == i__ - 1) {
dlanv2_(&h__[i__ - 1 + (i__ - 1) * h_dim1], &h__[i__ - 1 + i__ * h_dim1],
&h__[i__ + (i__ - 1) * h_dim1], &h__[i__ + i__ * h_dim1], &wr[i__ - 1],
&wi[i__ - 1], &wr[i__], &wi[i__], &cs, &sn);
if (*wantt) {
if (i2 > i__) {
i__1 = i2 - i__;
drot_(&i__1, &h__[i__ - 1 + (i__ + 1) * h_dim1], ldh,
&h__[i__ + (i__ + 1) * h_dim1], ldh, &cs, &sn);
}
i__1 = i__ - i1 - 1;
drot_(&i__1, &h__[i1 + (i__ - 1) * h_dim1], &c__1, &h__[i1 + i__ * h_dim1], &c__1, &cs,
&sn);
}
if (*wantz) {
drot_(&nz, &z__[*iloz + (i__ - 1) * z_dim1], &c__1, &z__[*iloz + i__ * z_dim1], &c__1,
&cs, &sn);
}
}
i__ = l - 1;
goto L20;
L160:
return 0;
}
#ifdef __cplusplus
}
#endif

121
lib/linalg/dlahr2.cpp Normal file
View File

@ -0,0 +1,121 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static doublereal c_b4 = -1.;
static doublereal c_b5 = 1.;
static integer c__1 = 1;
static doublereal c_b38 = 0.;
int dlahr2_(integer *n, integer *k, integer *nb, doublereal *a, integer *lda, doublereal *tau,
doublereal *t, integer *ldt, doublereal *y, integer *ldy)
{
integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2, i__3;
doublereal d__1;
integer i__;
doublereal ei;
extern int dscal_(integer *, doublereal *, doublereal *, integer *),
dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, ftnlen,
ftnlen),
dgemv_(char *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, ftnlen),
dcopy_(integer *, doublereal *, integer *, doublereal *, integer *),
dtrmm_(char *, char *, char *, char *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen),
daxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *),
dtrmv_(char *, char *, char *, integer *, doublereal *, integer *, doublereal *, integer *,
ftnlen, ftnlen, ftnlen),
dlarfg_(integer *, doublereal *, doublereal *, integer *, doublereal *),
dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *,
ftnlen);
--tau;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
y_dim1 = *ldy;
y_offset = 1 + y_dim1;
y -= y_offset;
if (*n <= 1) {
return 0;
}
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ > 1) {
i__2 = *n - *k;
i__3 = i__ - 1;
dgemv_((char *)"NO TRANSPOSE", &i__2, &i__3, &c_b4, &y[*k + 1 + y_dim1], ldy,
&a[*k + i__ - 1 + a_dim1], lda, &c_b5, &a[*k + 1 + i__ * a_dim1], &c__1,
(ftnlen)12);
i__2 = i__ - 1;
dcopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 + 1], &c__1);
i__2 = i__ - 1;
dtrmv_((char *)"Lower", (char *)"Transpose", (char *)"UNIT", &i__2, &a[*k + 1 + a_dim1], lda,
&t[*nb * t_dim1 + 1], &c__1, (ftnlen)5, (ftnlen)9, (ftnlen)4);
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1], lda,
&a[*k + i__ + i__ * a_dim1], &c__1, &c_b5, &t[*nb * t_dim1 + 1], &c__1,
(ftnlen)9);
i__2 = i__ - 1;
dtrmv_((char *)"Upper", (char *)"Transpose", (char *)"NON-UNIT", &i__2, &t[t_offset], ldt, &t[*nb * t_dim1 + 1],
&c__1, (ftnlen)5, (ftnlen)9, (ftnlen)8);
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
dgemv_((char *)"NO TRANSPOSE", &i__2, &i__3, &c_b4, &a[*k + i__ + a_dim1], lda,
&t[*nb * t_dim1 + 1], &c__1, &c_b5, &a[*k + i__ + i__ * a_dim1], &c__1,
(ftnlen)12);
i__2 = i__ - 1;
dtrmv_((char *)"Lower", (char *)"NO TRANSPOSE", (char *)"UNIT", &i__2, &a[*k + 1 + a_dim1], lda,
&t[*nb * t_dim1 + 1], &c__1, (ftnlen)5, (ftnlen)12, (ftnlen)4);
i__2 = i__ - 1;
daxpy_(&i__2, &c_b4, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__ * a_dim1], &c__1);
a[*k + i__ - 1 + (i__ - 1) * a_dim1] = ei;
}
i__2 = *n - *k - i__ + 1;
i__3 = *k + i__ + 1;
dlarfg_(&i__2, &a[*k + i__ + i__ * a_dim1], &a[min(i__3, *n) + i__ * a_dim1], &c__1,
&tau[i__]);
ei = a[*k + i__ + i__ * a_dim1];
a[*k + i__ + i__ * a_dim1] = 1.;
i__2 = *n - *k;
i__3 = *n - *k - i__ + 1;
dgemv_((char *)"NO TRANSPOSE", &i__2, &i__3, &c_b5, &a[*k + 1 + (i__ + 1) * a_dim1], lda,
&a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &y[*k + 1 + i__ * y_dim1], &c__1,
(ftnlen)12);
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1], lda,
&a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &t[i__ * t_dim1 + 1], &c__1, (ftnlen)9);
i__2 = *n - *k;
i__3 = i__ - 1;
dgemv_((char *)"NO TRANSPOSE", &i__2, &i__3, &c_b4, &y[*k + 1 + y_dim1], ldy, &t[i__ * t_dim1 + 1],
&c__1, &c_b5, &y[*k + 1 + i__ * y_dim1], &c__1, (ftnlen)12);
i__2 = *n - *k;
dscal_(&i__2, &tau[i__], &y[*k + 1 + i__ * y_dim1], &c__1);
i__2 = i__ - 1;
d__1 = -tau[i__];
dscal_(&i__2, &d__1, &t[i__ * t_dim1 + 1], &c__1);
i__2 = i__ - 1;
dtrmv_((char *)"Upper", (char *)"No Transpose", (char *)"NON-UNIT", &i__2, &t[t_offset], ldt, &t[i__ * t_dim1 + 1],
&c__1, (ftnlen)5, (ftnlen)12, (ftnlen)8);
t[i__ + i__ * t_dim1] = tau[i__];
}
a[*k + *nb + *nb * a_dim1] = ei;
dlacpy_((char *)"ALL", k, nb, &a[(a_dim1 << 1) + 1], lda, &y[y_offset], ldy, (ftnlen)3);
dtrmm_((char *)"RIGHT", (char *)"Lower", (char *)"NO TRANSPOSE", (char *)"UNIT", k, nb, &c_b5, &a[*k + 1 + a_dim1], lda,
&y[y_offset], ldy, (ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4);
if (*n > *k + *nb) {
i__1 = *n - *k - *nb;
dgemm_((char *)"NO TRANSPOSE", (char *)"NO TRANSPOSE", k, nb, &i__1, &c_b5, &a[(*nb + 2) * a_dim1 + 1], lda,
&a[*k + 1 + *nb + a_dim1], lda, &c_b5, &y[y_offset], ldy, (ftnlen)12, (ftnlen)12);
}
dtrmm_((char *)"RIGHT", (char *)"Upper", (char *)"NO TRANSPOSE", (char *)"NON-UNIT", k, nb, &c_b5, &t[t_offset], ldt,
&y[y_offset], ldy, (ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)8);
return 0;
}
#ifdef __cplusplus
}
#endif

298
lib/linalg/dlaln2.cpp Normal file
View File

@ -0,0 +1,298 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
int dlaln2_(logical *ltrans, integer *na, integer *nw, doublereal *smin, doublereal *ca,
doublereal *a, integer *lda, doublereal *d1, doublereal *d2, doublereal *b,
integer *ldb, doublereal *wr, doublereal *wi, doublereal *x, integer *ldx,
doublereal *scale, doublereal *xnorm, integer *info)
{
static logical zswap[4] = {FALSE_, FALSE_, TRUE_, TRUE_};
static logical rswap[4] = {FALSE_, TRUE_, FALSE_, TRUE_};
static integer ipivot[16] = {1, 2, 3, 4, 2, 1, 4, 3, 3, 4, 1, 2, 4, 3, 2, 1};
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
static doublereal equiv_0[4], equiv_1[4];
integer j;
#define ci (equiv_0)
#define cr (equiv_1)
doublereal bi1, bi2, br1, br2, xi1, xi2, xr1, xr2, ci21, ci22, cr21, cr22, li21, csi, ui11,
lr21, ui12, ui22;
#define civ (equiv_0)
doublereal csr, ur11, ur12, ur22;
#define crv (equiv_1)
doublereal bbnd, cmax, ui11r, ui12s, temp, ur11r, ur12s, u22abs;
integer icmax;
doublereal bnorm, cnorm, smini;
extern doublereal dlamch_(char *, ftnlen);
extern int dladiv_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
doublereal bignum, smlnum;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
smlnum = 2. * dlamch_((char *)"Safe minimum", (ftnlen)12);
bignum = 1. / smlnum;
smini = max(*smin, smlnum);
*info = 0;
*scale = 1.;
if (*na == 1) {
if (*nw == 1) {
csr = *ca * a[a_dim1 + 1] - *wr * *d1;
cnorm = abs(csr);
if (cnorm < smini) {
csr = smini;
cnorm = smini;
*info = 1;
}
bnorm = (d__1 = b[b_dim1 + 1], abs(d__1));
if (cnorm < 1. && bnorm > 1.) {
if (bnorm > bignum * cnorm) {
*scale = 1. / bnorm;
}
}
x[x_dim1 + 1] = b[b_dim1 + 1] * *scale / csr;
*xnorm = (d__1 = x[x_dim1 + 1], abs(d__1));
} else {
csr = *ca * a[a_dim1 + 1] - *wr * *d1;
csi = -(*wi) * *d1;
cnorm = abs(csr) + abs(csi);
if (cnorm < smini) {
csr = smini;
csi = 0.;
cnorm = smini;
*info = 1;
}
bnorm = (d__1 = b[b_dim1 + 1], abs(d__1)) + (d__2 = b[(b_dim1 << 1) + 1], abs(d__2));
if (cnorm < 1. && bnorm > 1.) {
if (bnorm > bignum * cnorm) {
*scale = 1. / bnorm;
}
}
d__1 = *scale * b[b_dim1 + 1];
d__2 = *scale * b[(b_dim1 << 1) + 1];
dladiv_(&d__1, &d__2, &csr, &csi, &x[x_dim1 + 1], &x[(x_dim1 << 1) + 1]);
*xnorm = (d__1 = x[x_dim1 + 1], abs(d__1)) + (d__2 = x[(x_dim1 << 1) + 1], abs(d__2));
}
} else {
cr[0] = *ca * a[a_dim1 + 1] - *wr * *d1;
cr[3] = *ca * a[(a_dim1 << 1) + 2] - *wr * *d2;
if (*ltrans) {
cr[2] = *ca * a[a_dim1 + 2];
cr[1] = *ca * a[(a_dim1 << 1) + 1];
} else {
cr[1] = *ca * a[a_dim1 + 2];
cr[2] = *ca * a[(a_dim1 << 1) + 1];
}
if (*nw == 1) {
cmax = 0.;
icmax = 0;
for (j = 1; j <= 4; ++j) {
if ((d__1 = crv[j - 1], abs(d__1)) > cmax) {
cmax = (d__1 = crv[j - 1], abs(d__1));
icmax = j;
}
}
if (cmax < smini) {
d__3 = (d__1 = b[b_dim1 + 1], abs(d__1)), d__4 = (d__2 = b[b_dim1 + 2], abs(d__2));
bnorm = max(d__3, d__4);
if (smini < 1. && bnorm > 1.) {
if (bnorm > bignum * smini) {
*scale = 1. / bnorm;
}
}
temp = *scale / smini;
x[x_dim1 + 1] = temp * b[b_dim1 + 1];
x[x_dim1 + 2] = temp * b[b_dim1 + 2];
*xnorm = temp * bnorm;
*info = 1;
return 0;
}
ur11 = crv[icmax - 1];
cr21 = crv[ipivot[(icmax << 2) - 3] - 1];
ur12 = crv[ipivot[(icmax << 2) - 2] - 1];
cr22 = crv[ipivot[(icmax << 2) - 1] - 1];
ur11r = 1. / ur11;
lr21 = ur11r * cr21;
ur22 = cr22 - ur12 * lr21;
if (abs(ur22) < smini) {
ur22 = smini;
*info = 1;
}
if (rswap[icmax - 1]) {
br1 = b[b_dim1 + 2];
br2 = b[b_dim1 + 1];
} else {
br1 = b[b_dim1 + 1];
br2 = b[b_dim1 + 2];
}
br2 -= lr21 * br1;
d__2 = (d__1 = br1 * (ur22 * ur11r), abs(d__1)), d__3 = abs(br2);
bbnd = max(d__2, d__3);
if (bbnd > 1. && abs(ur22) < 1.) {
if (bbnd >= bignum * abs(ur22)) {
*scale = 1. / bbnd;
}
}
xr2 = br2 * *scale / ur22;
xr1 = *scale * br1 * ur11r - xr2 * (ur11r * ur12);
if (zswap[icmax - 1]) {
x[x_dim1 + 1] = xr2;
x[x_dim1 + 2] = xr1;
} else {
x[x_dim1 + 1] = xr1;
x[x_dim1 + 2] = xr2;
}
d__1 = abs(xr1), d__2 = abs(xr2);
*xnorm = max(d__1, d__2);
if (*xnorm > 1. && cmax > 1.) {
if (*xnorm > bignum / cmax) {
temp = cmax / bignum;
x[x_dim1 + 1] = temp * x[x_dim1 + 1];
x[x_dim1 + 2] = temp * x[x_dim1 + 2];
*xnorm = temp * *xnorm;
*scale = temp * *scale;
}
}
} else {
ci[0] = -(*wi) * *d1;
ci[1] = 0.;
ci[2] = 0.;
ci[3] = -(*wi) * *d2;
cmax = 0.;
icmax = 0;
for (j = 1; j <= 4; ++j) {
if ((d__1 = crv[j - 1], abs(d__1)) + (d__2 = civ[j - 1], abs(d__2)) > cmax) {
cmax = (d__1 = crv[j - 1], abs(d__1)) + (d__2 = civ[j - 1], abs(d__2));
icmax = j;
}
}
if (cmax < smini) {
d__5 = (d__1 = b[b_dim1 + 1], abs(d__1)) + (d__2 = b[(b_dim1 << 1) + 1], abs(d__2)),
d__6 = (d__3 = b[b_dim1 + 2], abs(d__3)) + (d__4 = b[(b_dim1 << 1) + 2], abs(d__4));
bnorm = max(d__5, d__6);
if (smini < 1. && bnorm > 1.) {
if (bnorm > bignum * smini) {
*scale = 1. / bnorm;
}
}
temp = *scale / smini;
x[x_dim1 + 1] = temp * b[b_dim1 + 1];
x[x_dim1 + 2] = temp * b[b_dim1 + 2];
x[(x_dim1 << 1) + 1] = temp * b[(b_dim1 << 1) + 1];
x[(x_dim1 << 1) + 2] = temp * b[(b_dim1 << 1) + 2];
*xnorm = temp * bnorm;
*info = 1;
return 0;
}
ur11 = crv[icmax - 1];
ui11 = civ[icmax - 1];
cr21 = crv[ipivot[(icmax << 2) - 3] - 1];
ci21 = civ[ipivot[(icmax << 2) - 3] - 1];
ur12 = crv[ipivot[(icmax << 2) - 2] - 1];
ui12 = civ[ipivot[(icmax << 2) - 2] - 1];
cr22 = crv[ipivot[(icmax << 2) - 1] - 1];
ci22 = civ[ipivot[(icmax << 2) - 1] - 1];
if (icmax == 1 || icmax == 4) {
if (abs(ur11) > abs(ui11)) {
temp = ui11 / ur11;
d__1 = temp;
ur11r = 1. / (ur11 * (d__1 * d__1 + 1.));
ui11r = -temp * ur11r;
} else {
temp = ur11 / ui11;
d__1 = temp;
ui11r = -1. / (ui11 * (d__1 * d__1 + 1.));
ur11r = -temp * ui11r;
}
lr21 = cr21 * ur11r;
li21 = cr21 * ui11r;
ur12s = ur12 * ur11r;
ui12s = ur12 * ui11r;
ur22 = cr22 - ur12 * lr21;
ui22 = ci22 - ur12 * li21;
} else {
ur11r = 1. / ur11;
ui11r = 0.;
lr21 = cr21 * ur11r;
li21 = ci21 * ur11r;
ur12s = ur12 * ur11r;
ui12s = ui12 * ur11r;
ur22 = cr22 - ur12 * lr21 + ui12 * li21;
ui22 = -ur12 * li21 - ui12 * lr21;
}
u22abs = abs(ur22) + abs(ui22);
if (u22abs < smini) {
ur22 = smini;
ui22 = 0.;
*info = 1;
}
if (rswap[icmax - 1]) {
br2 = b[b_dim1 + 1];
br1 = b[b_dim1 + 2];
bi2 = b[(b_dim1 << 1) + 1];
bi1 = b[(b_dim1 << 1) + 2];
} else {
br1 = b[b_dim1 + 1];
br2 = b[b_dim1 + 2];
bi1 = b[(b_dim1 << 1) + 1];
bi2 = b[(b_dim1 << 1) + 2];
}
br2 = br2 - lr21 * br1 + li21 * bi1;
bi2 = bi2 - li21 * br1 - lr21 * bi1;
d__1 = (abs(br1) + abs(bi1)) * (u22abs * (abs(ur11r) + abs(ui11r))),
d__2 = abs(br2) + abs(bi2);
bbnd = max(d__1, d__2);
if (bbnd > 1. && u22abs < 1.) {
if (bbnd >= bignum * u22abs) {
*scale = 1. / bbnd;
br1 = *scale * br1;
bi1 = *scale * bi1;
br2 = *scale * br2;
bi2 = *scale * bi2;
}
}
dladiv_(&br2, &bi2, &ur22, &ui22, &xr2, &xi2);
xr1 = ur11r * br1 - ui11r * bi1 - ur12s * xr2 + ui12s * xi2;
xi1 = ui11r * br1 + ur11r * bi1 - ui12s * xr2 - ur12s * xi2;
if (zswap[icmax - 1]) {
x[x_dim1 + 1] = xr2;
x[x_dim1 + 2] = xr1;
x[(x_dim1 << 1) + 1] = xi2;
x[(x_dim1 << 1) + 2] = xi1;
} else {
x[x_dim1 + 1] = xr1;
x[x_dim1 + 2] = xr2;
x[(x_dim1 << 1) + 1] = xi1;
x[(x_dim1 << 1) + 2] = xi2;
}
d__1 = abs(xr1) + abs(xi1), d__2 = abs(xr2) + abs(xi2);
*xnorm = max(d__1, d__2);
if (*xnorm > 1. && cmax > 1.) {
if (*xnorm > bignum / cmax) {
temp = cmax / bignum;
x[x_dim1 + 1] = temp * x[x_dim1 + 1];
x[x_dim1 + 2] = temp * x[x_dim1 + 2];
x[(x_dim1 << 1) + 1] = temp * x[(x_dim1 << 1) + 1];
x[(x_dim1 << 1) + 2] = temp * x[(x_dim1 << 1) + 2];
*xnorm = temp * *xnorm;
*scale = temp * *scale;
}
}
}
}
return 0;
}
#undef crv
#undef civ
#undef cr
#undef ci
#ifdef __cplusplus
}
#endif

106
lib/linalg/dlanv2.cpp Normal file
View File

@ -0,0 +1,106 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static doublereal c_b3 = 1.;
int dlanv2_(doublereal *a, doublereal *b, doublereal *c__, doublereal *d__, doublereal *rt1r,
doublereal *rt1i, doublereal *rt2r, doublereal *rt2i, doublereal *cs, doublereal *sn)
{
doublereal d__1, d__2;
double d_lmp_sign(doublereal *, doublereal *), sqrt(doublereal);
doublereal p, z__, aa, bb, cc, dd, cs1, sn1, sab, sac, eps, tau, temp, scale, bcmax, bcmis,
sigma;
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, ftnlen);
eps = dlamch_((char *)"P", (ftnlen)1);
if (*c__ == 0.) {
*cs = 1.;
*sn = 0.;
} else if (*b == 0.) {
*cs = 0.;
*sn = 1.;
temp = *d__;
*d__ = *a;
*a = temp;
*b = -(*c__);
*c__ = 0.;
} else if (*a - *d__ == 0. && d_lmp_sign(&c_b3, b) != d_lmp_sign(&c_b3, c__)) {
*cs = 1.;
*sn = 0.;
} else {
temp = *a - *d__;
p = temp * .5;
d__1 = abs(*b), d__2 = abs(*c__);
bcmax = max(d__1, d__2);
d__1 = abs(*b), d__2 = abs(*c__);
bcmis = min(d__1, d__2) * d_lmp_sign(&c_b3, b) * d_lmp_sign(&c_b3, c__);
d__1 = abs(p);
scale = max(d__1, bcmax);
z__ = p / scale * p + bcmax / scale * bcmis;
if (z__ >= eps * 4.) {
d__1 = sqrt(scale) * sqrt(z__);
z__ = p + d_lmp_sign(&d__1, &p);
*a = *d__ + z__;
*d__ -= bcmax / z__ * bcmis;
tau = dlapy2_(c__, &z__);
*cs = z__ / tau;
*sn = *c__ / tau;
*b -= *c__;
*c__ = 0.;
} else {
sigma = *b + *c__;
tau = dlapy2_(&sigma, &temp);
*cs = sqrt((abs(sigma) / tau + 1.) * .5);
*sn = -(p / (tau * *cs)) * d_lmp_sign(&c_b3, &sigma);
aa = *a * *cs + *b * *sn;
bb = -(*a) * *sn + *b * *cs;
cc = *c__ * *cs + *d__ * *sn;
dd = -(*c__) * *sn + *d__ * *cs;
*a = aa * *cs + cc * *sn;
*b = bb * *cs + dd * *sn;
*c__ = -aa * *sn + cc * *cs;
*d__ = -bb * *sn + dd * *cs;
temp = (*a + *d__) * .5;
*a = temp;
*d__ = temp;
if (*c__ != 0.) {
if (*b != 0.) {
if (d_lmp_sign(&c_b3, b) == d_lmp_sign(&c_b3, c__)) {
sab = sqrt((abs(*b)));
sac = sqrt((abs(*c__)));
d__1 = sab * sac;
p = d_lmp_sign(&d__1, c__);
tau = 1. / sqrt((d__1 = *b + *c__, abs(d__1)));
*a = temp + p;
*d__ = temp - p;
*b -= *c__;
*c__ = 0.;
cs1 = sab * tau;
sn1 = sac * tau;
temp = *cs * cs1 - *sn * sn1;
*sn = *cs * sn1 + *sn * cs1;
*cs = temp;
}
} else {
*b = -(*c__);
*c__ = 0.;
temp = *cs;
*cs = -(*sn);
*sn = temp;
}
}
}
}
*rt1r = *a;
*rt2r = *d__;
if (*c__ == 0.) {
*rt1i = 0.;
*rt2i = 0.;
} else {
*rt1i = sqrt((abs(*b))) * sqrt((abs(*c__)));
*rt2i = -(*rt1i);
}
return 0;
}
#ifdef __cplusplus
}
#endif

306
lib/linalg/dlaqr0.cpp Normal file
View File

@ -0,0 +1,306 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static integer c__13 = 13;
static integer c__15 = 15;
static integer c_n1 = -1;
static integer c__12 = 12;
static integer c__14 = 14;
static integer c__16 = 16;
static logical c_false = FALSE_;
static integer c__1 = 1;
static integer c__3 = 3;
int dlaqr0_(logical *wantt, logical *wantz, integer *n, integer *ilo, integer *ihi, doublereal *h__,
integer *ldh, doublereal *wr, doublereal *wi, integer *iloz, integer *ihiz,
doublereal *z__, integer *ldz, doublereal *work, integer *lwork, integer *info)
{
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
integer i__, k;
doublereal aa, bb, cc, dd;
integer ld;
doublereal cs;
integer nh, it, ks, kt;
doublereal sn;
integer ku, kv, ls, ns;
doublereal ss;
integer nw, inf, kdu, nho, nve, kwh, nsr, nwr, kwv, ndec, ndfl, kbot, nmin;
doublereal swap;
integer ktop;
doublereal zdum[1];
integer kacc22, itmax, nsmax, nwmax, kwtop;
extern int dlanv2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, doublereal *),
dlaqr3_(logical *, logical *, integer *, integer *, integer *, integer *, doublereal *,
integer *, integer *, integer *, doublereal *, integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *, doublereal *, integer *, doublereal *, integer *),
dlaqr4_(logical *, logical *, integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, integer *),
dlaqr5_(logical *, logical *, integer *, integer *, integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *, doublereal *, integer *);
integer nibble;
extern int dlahqr_(logical *, logical *, integer *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *),
dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *,
ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
char jbcmpz[2];
integer nwupbd;
logical sorted;
integer lwkopt;
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--wr;
--wi;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
*info = 0;
if (*n == 0) {
work[1] = 1.;
return 0;
}
if (*n <= 11) {
lwkopt = 1;
if (*lwork != -1) {
dlahqr_(wantt, wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &wi[1], iloz, ihiz,
&z__[z_offset], ldz, info);
}
} else {
*info = 0;
if (*wantt) {
*(unsigned char *)jbcmpz = 'S';
} else {
*(unsigned char *)jbcmpz = 'E';
}
if (*wantz) {
*(unsigned char *)&jbcmpz[1] = 'V';
} else {
*(unsigned char *)&jbcmpz[1] = 'N';
}
nwr = ilaenv_(&c__13, (char *)"DLAQR0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, (ftnlen)2);
nwr = max(2, nwr);
i__1 = *ihi - *ilo + 1, i__2 = (*n - 1) / 3, i__1 = min(i__1, i__2);
nwr = min(i__1, nwr);
nsr = ilaenv_(&c__15, (char *)"DLAQR0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, (ftnlen)2);
i__1 = nsr, i__2 = (*n + 6) / 9, i__1 = min(i__1, i__2), i__2 = *ihi - *ilo;
nsr = min(i__1, i__2);
i__1 = 2, i__2 = nsr - nsr % 2;
nsr = max(i__1, i__2);
i__1 = nwr + 1;
dlaqr3_(wantt, wantz, n, ilo, ihi, &i__1, &h__[h_offset], ldh, iloz, ihiz, &z__[z_offset],
ldz, &ls, &ld, &wr[1], &wi[1], &h__[h_offset], ldh, n, &h__[h_offset], ldh, n,
&h__[h_offset], ldh, &work[1], &c_n1);
i__1 = nsr * 3 / 2, i__2 = (integer)work[1];
lwkopt = max(i__1, i__2);
if (*lwork == -1) {
work[1] = (doublereal)lwkopt;
return 0;
}
nmin = ilaenv_(&c__12, (char *)"DLAQR0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, (ftnlen)2);
nmin = max(11, nmin);
nibble = ilaenv_(&c__14, (char *)"DLAQR0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, (ftnlen)2);
nibble = max(0, nibble);
kacc22 = ilaenv_(&c__16, (char *)"DLAQR0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, (ftnlen)2);
kacc22 = max(0, kacc22);
kacc22 = min(2, kacc22);
i__1 = (*n - 1) / 3, i__2 = *lwork / 2;
nwmax = min(i__1, i__2);
nw = nwmax;
i__1 = (*n + 6) / 9, i__2 = (*lwork << 1) / 3;
nsmax = min(i__1, i__2);
nsmax -= nsmax % 2;
ndfl = 1;
i__1 = 10, i__2 = *ihi - *ilo + 1;
itmax = max(i__1, i__2) * 30;
kbot = *ihi;
i__1 = itmax;
for (it = 1; it <= i__1; ++it) {
if (kbot < *ilo) {
goto L90;
}
i__2 = *ilo + 1;
for (k = kbot; k >= i__2; --k) {
if (h__[k + (k - 1) * h_dim1] == 0.) {
goto L20;
}
}
k = *ilo;
L20:
ktop = k;
nh = kbot - ktop + 1;
nwupbd = min(nh, nwmax);
if (ndfl < 5) {
nw = min(nwupbd, nwr);
} else {
i__2 = nwupbd, i__3 = nw << 1;
nw = min(i__2, i__3);
}
if (nw < nwmax) {
if (nw >= nh - 1) {
nw = nh;
} else {
kwtop = kbot - nw + 1;
if ((d__1 = h__[kwtop + (kwtop - 1) * h_dim1], abs(d__1)) >
(d__2 = h__[kwtop - 1 + (kwtop - 2) * h_dim1], abs(d__2))) {
++nw;
}
}
}
if (ndfl < 5) {
ndec = -1;
} else if (ndec >= 0 || nw >= nwupbd) {
++ndec;
if (nw - ndec < 2) {
ndec = 0;
}
nw -= ndec;
}
kv = *n - nw + 1;
kt = nw + 1;
nho = *n - nw - 1 - kt + 1;
kwv = nw + 2;
nve = *n - nw - kwv + 1;
dlaqr3_(wantt, wantz, n, &ktop, &kbot, &nw, &h__[h_offset], ldh, iloz, ihiz,
&z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], &h__[kv + h_dim1], ldh, &nho,
&h__[kv + kt * h_dim1], ldh, &nve, &h__[kwv + h_dim1], ldh, &work[1], lwork);
kbot -= ld;
ks = kbot - ls + 1;
if (ld == 0 || ld * 100 <= nw * nibble && kbot - ktop + 1 > min(nmin, nwmax)) {
i__4 = 2, i__5 = kbot - ktop;
i__2 = min(nsmax, nsr), i__3 = max(i__4, i__5);
ns = min(i__2, i__3);
ns -= ns % 2;
if (ndfl % 6 == 0) {
ks = kbot - ns + 1;
i__3 = ks + 1, i__4 = ktop + 2;
i__2 = max(i__3, i__4);
for (i__ = kbot; i__ >= i__2; i__ += -2) {
ss = (d__1 = h__[i__ + (i__ - 1) * h_dim1], abs(d__1)) +
(d__2 = h__[i__ - 1 + (i__ - 2) * h_dim1], abs(d__2));
aa = ss * .75 + h__[i__ + i__ * h_dim1];
bb = ss;
cc = ss * -.4375;
dd = aa;
dlanv2_(&aa, &bb, &cc, &dd, &wr[i__ - 1], &wi[i__ - 1], &wr[i__], &wi[i__],
&cs, &sn);
}
if (ks == ktop) {
wr[ks + 1] = h__[ks + 1 + (ks + 1) * h_dim1];
wi[ks + 1] = 0.;
wr[ks] = wr[ks + 1];
wi[ks] = wi[ks + 1];
}
} else {
if (kbot - ks + 1 <= ns / 2) {
ks = kbot - ns + 1;
kt = *n - ns + 1;
dlacpy_((char *)"A", &ns, &ns, &h__[ks + ks * h_dim1], ldh, &h__[kt + h_dim1], ldh,
(ftnlen)1);
if (ns > nmin) {
dlaqr4_(&c_false, &c_false, &ns, &c__1, &ns, &h__[kt + h_dim1], ldh,
&wr[ks], &wi[ks], &c__1, &c__1, zdum, &c__1, &work[1], lwork,
&inf);
} else {
dlahqr_(&c_false, &c_false, &ns, &c__1, &ns, &h__[kt + h_dim1], ldh,
&wr[ks], &wi[ks], &c__1, &c__1, zdum, &c__1, &inf);
}
ks += inf;
if (ks >= kbot) {
aa = h__[kbot - 1 + (kbot - 1) * h_dim1];
cc = h__[kbot + (kbot - 1) * h_dim1];
bb = h__[kbot - 1 + kbot * h_dim1];
dd = h__[kbot + kbot * h_dim1];
dlanv2_(&aa, &bb, &cc, &dd, &wr[kbot - 1], &wi[kbot - 1], &wr[kbot],
&wi[kbot], &cs, &sn);
ks = kbot - 1;
}
}
if (kbot - ks + 1 > ns) {
sorted = FALSE_;
i__2 = ks + 1;
for (k = kbot; k >= i__2; --k) {
if (sorted) {
goto L60;
}
sorted = TRUE_;
i__3 = k - 1;
for (i__ = ks; i__ <= i__3; ++i__) {
if ((d__1 = wr[i__], abs(d__1)) + (d__2 = wi[i__], abs(d__2)) <
(d__3 = wr[i__ + 1], abs(d__3)) +
(d__4 = wi[i__ + 1], abs(d__4))) {
sorted = FALSE_;
swap = wr[i__];
wr[i__] = wr[i__ + 1];
wr[i__ + 1] = swap;
swap = wi[i__];
wi[i__] = wi[i__ + 1];
wi[i__ + 1] = swap;
}
}
}
L60:;
}
i__2 = ks + 2;
for (i__ = kbot; i__ >= i__2; i__ += -2) {
if (wi[i__] != -wi[i__ - 1]) {
swap = wr[i__];
wr[i__] = wr[i__ - 1];
wr[i__ - 1] = wr[i__ - 2];
wr[i__ - 2] = swap;
swap = wi[i__];
wi[i__] = wi[i__ - 1];
wi[i__ - 1] = wi[i__ - 2];
wi[i__ - 2] = swap;
}
}
}
if (kbot - ks + 1 == 2) {
if (wi[kbot] == 0.) {
if ((d__1 = wr[kbot] - h__[kbot + kbot * h_dim1], abs(d__1)) <
(d__2 = wr[kbot - 1] - h__[kbot + kbot * h_dim1], abs(d__2))) {
wr[kbot - 1] = wr[kbot];
} else {
wr[kbot] = wr[kbot - 1];
}
}
}
i__2 = ns, i__3 = kbot - ks + 1;
ns = min(i__2, i__3);
ns -= ns % 2;
ks = kbot - ns + 1;
kdu = ns * 3 - 3;
ku = *n - kdu + 1;
kwh = kdu + 1;
nho = *n - kdu - 3 - (kdu + 1) + 1;
kwv = kdu + 4;
nve = *n - kdu - kwv + 1;
dlaqr5_(wantt, wantz, &kacc22, n, &ktop, &kbot, &ns, &wr[ks], &wi[ks],
&h__[h_offset], ldh, iloz, ihiz, &z__[z_offset], ldz, &work[1], &c__3,
&h__[ku + h_dim1], ldh, &nve, &h__[kwv + h_dim1], ldh, &nho,
&h__[ku + kwh * h_dim1], ldh);
}
if (ld > 0) {
ndfl = 1;
} else {
++ndfl;
}
}
*info = kbot;
L90:;
}
work[1] = (doublereal)lwkopt;
return 0;
}
#ifdef __cplusplus
}
#endif

52
lib/linalg/dlaqr1.cpp Normal file
View File

@ -0,0 +1,52 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
int dlaqr1_(integer *n, doublereal *h__, integer *ldh, doublereal *sr1, doublereal *si1,
doublereal *sr2, doublereal *si2, doublereal *v)
{
integer h_dim1, h_offset;
doublereal d__1, d__2, d__3;
doublereal s, h21s, h31s;
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--v;
if (*n != 2 && *n != 3) {
return 0;
}
if (*n == 2) {
s = (d__1 = h__[h_dim1 + 1] - *sr2, abs(d__1)) + abs(*si2) +
(d__2 = h__[h_dim1 + 2], abs(d__2));
if (s == 0.) {
v[1] = 0.;
v[2] = 0.;
} else {
h21s = h__[h_dim1 + 2] / s;
v[1] = h21s * h__[(h_dim1 << 1) + 1] +
(h__[h_dim1 + 1] - *sr1) * ((h__[h_dim1 + 1] - *sr2) / s) - *si1 * (*si2 / s);
v[2] = h21s * (h__[h_dim1 + 1] + h__[(h_dim1 << 1) + 2] - *sr1 - *sr2);
}
} else {
s = (d__1 = h__[h_dim1 + 1] - *sr2, abs(d__1)) + abs(*si2) +
(d__2 = h__[h_dim1 + 2], abs(d__2)) + (d__3 = h__[h_dim1 + 3], abs(d__3));
if (s == 0.) {
v[1] = 0.;
v[2] = 0.;
v[3] = 0.;
} else {
h21s = h__[h_dim1 + 2] / s;
h31s = h__[h_dim1 + 3] / s;
v[1] = (h__[h_dim1 + 1] - *sr1) * ((h__[h_dim1 + 1] - *sr2) / s) - *si1 * (*si2 / s) +
h__[(h_dim1 << 1) + 1] * h21s + h__[h_dim1 * 3 + 1] * h31s;
v[2] = h21s * (h__[h_dim1 + 1] + h__[(h_dim1 << 1) + 2] - *sr1 - *sr2) +
h__[h_dim1 * 3 + 2] * h31s;
v[3] = h31s * (h__[h_dim1 + 1] + h__[h_dim1 * 3 + 3] - *sr1 - *sr2) +
h21s * h__[(h_dim1 << 1) + 3];
}
}
return 0;
}
#ifdef __cplusplus
}
#endif

359
lib/linalg/dlaqr2.cpp Normal file
View File

@ -0,0 +1,359 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static integer c__1 = 1;
static integer c_n1 = -1;
static doublereal c_b12 = 0.;
static doublereal c_b13 = 1.;
static logical c_true = TRUE_;
int dlaqr2_(logical *wantt, logical *wantz, integer *n, integer *ktop, integer *kbot, integer *nw,
doublereal *h__, integer *ldh, integer *iloz, integer *ihiz, doublereal *z__,
integer *ldz, integer *ns, integer *nd, doublereal *sr, doublereal *si, doublereal *v,
integer *ldv, integer *nh, doublereal *t, integer *ldt, integer *nv, doublereal *wv,
integer *ldwv, doublereal *work, integer *lwork)
{
integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1, wv_offset, z_dim1,
z_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
double sqrt(doublereal);
integer i__, j, k;
doublereal s, aa, bb, cc, dd, cs, sn;
integer jw;
doublereal evi, evk, foo;
integer kln;
doublereal tau, ulp;
integer lwk1, lwk2;
doublereal beta;
integer kend, kcol, info, ifst, ilst, ltop, krow;
extern int dlarf_(char *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, ftnlen),
dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, ftnlen,
ftnlen);
logical bulge;
extern int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *);
integer infqr, kwtop;
extern int dlanv2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, doublereal *),
dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *, ftnlen);
extern int dgehrd_(integer *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, integer *),
dlarfg_(integer *, doublereal *, doublereal *, integer *, doublereal *),
dlahqr_(logical *, logical *, integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *, integer *,
integer *),
dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *,
ftnlen);
doublereal safmin;
extern int dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, ftnlen);
doublereal safmax;
extern int dtrexc_(char *, integer *, doublereal *, integer *, doublereal *, integer *,
integer *, integer *, doublereal *, integer *, ftnlen),
dormhr_(char *, char *, integer *, integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *, integer *, ftnlen,
ftnlen);
logical sorted;
doublereal smlnum;
integer lwkopt;
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--sr;
--si;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
wv_dim1 = *ldwv;
wv_offset = 1 + wv_dim1;
wv -= wv_offset;
--work;
i__1 = *nw, i__2 = *kbot - *ktop + 1;
jw = min(i__1, i__2);
if (jw <= 2) {
lwkopt = 1;
} else {
i__1 = jw - 1;
dgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], &c_n1, &info);
lwk1 = (integer)work[1];
i__1 = jw - 1;
dormhr_((char *)"R", (char *)"N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &v[v_offset], ldv,
&work[1], &c_n1, &info, (ftnlen)1, (ftnlen)1);
lwk2 = (integer)work[1];
lwkopt = jw + max(lwk1, lwk2);
}
if (*lwork == -1) {
work[1] = (doublereal)lwkopt;
return 0;
}
*ns = 0;
*nd = 0;
work[1] = 1.;
if (*ktop > *kbot) {
return 0;
}
if (*nw < 1) {
return 0;
}
safmin = dlamch_((char *)"SAFE MINIMUM", (ftnlen)12);
safmax = 1. / safmin;
dlabad_(&safmin, &safmax);
ulp = dlamch_((char *)"PRECISION", (ftnlen)9);
smlnum = safmin * ((doublereal)(*n) / ulp);
i__1 = *nw, i__2 = *kbot - *ktop + 1;
jw = min(i__1, i__2);
kwtop = *kbot - jw + 1;
if (kwtop == *ktop) {
s = 0.;
} else {
s = h__[kwtop + (kwtop - 1) * h_dim1];
}
if (*kbot == kwtop) {
sr[kwtop] = h__[kwtop + kwtop * h_dim1];
si[kwtop] = 0.;
*ns = 1;
*nd = 0;
d__2 = smlnum, d__3 = ulp * (d__1 = h__[kwtop + kwtop * h_dim1], abs(d__1));
if (abs(s) <= max(d__2, d__3)) {
*ns = 0;
*nd = 1;
if (kwtop > *ktop) {
h__[kwtop + (kwtop - 1) * h_dim1] = 0.;
}
}
work[1] = 1.;
return 0;
}
dlacpy_((char *)"U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset], ldt, (ftnlen)1);
i__1 = jw - 1;
i__2 = *ldh + 1;
i__3 = *ldt + 1;
dcopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], &i__3);
dlaset_((char *)"A", &jw, &jw, &c_b12, &c_b13, &v[v_offset], ldv, (ftnlen)1);
dlahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[kwtop], &si[kwtop], &c__1,
&jw, &v[v_offset], ldv, &infqr);
i__1 = jw - 3;
for (j = 1; j <= i__1; ++j) {
t[j + 2 + j * t_dim1] = 0.;
t[j + 3 + j * t_dim1] = 0.;
}
if (jw > 2) {
t[jw + (jw - 2) * t_dim1] = 0.;
}
*ns = jw;
ilst = infqr + 1;
L20:
if (ilst <= *ns) {
if (*ns == 1) {
bulge = FALSE_;
} else {
bulge = t[*ns + (*ns - 1) * t_dim1] != 0.;
}
if (!bulge) {
foo = (d__1 = t[*ns + *ns * t_dim1], abs(d__1));
if (foo == 0.) {
foo = abs(s);
}
d__2 = smlnum, d__3 = ulp * foo;
if ((d__1 = s * v[*ns * v_dim1 + 1], abs(d__1)) <= max(d__2, d__3)) {
--(*ns);
} else {
ifst = *ns;
dtrexc_((char *)"V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &ilst, &work[1],
&info, (ftnlen)1);
++ilst;
}
} else {
foo = (d__3 = t[*ns + *ns * t_dim1], abs(d__3)) +
sqrt((d__1 = t[*ns + (*ns - 1) * t_dim1], abs(d__1))) *
sqrt((d__2 = t[*ns - 1 + *ns * t_dim1], abs(d__2)));
if (foo == 0.) {
foo = abs(s);
}
d__3 = (d__1 = s * v[*ns * v_dim1 + 1], abs(d__1)),
d__4 = (d__2 = s * v[(*ns - 1) * v_dim1 + 1], abs(d__2));
d__5 = smlnum, d__6 = ulp * foo;
if (max(d__3, d__4) <= max(d__5, d__6)) {
*ns += -2;
} else {
ifst = *ns;
dtrexc_((char *)"V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &ilst, &work[1],
&info, (ftnlen)1);
ilst += 2;
}
}
goto L20;
}
if (*ns == 0) {
s = 0.;
}
if (*ns < jw) {
sorted = FALSE_;
i__ = *ns + 1;
L30:
if (sorted) {
goto L50;
}
sorted = TRUE_;
kend = i__ - 1;
i__ = infqr + 1;
if (i__ == *ns) {
k = i__ + 1;
} else if (t[i__ + 1 + i__ * t_dim1] == 0.) {
k = i__ + 1;
} else {
k = i__ + 2;
}
L40:
if (k <= kend) {
if (k == i__ + 1) {
evi = (d__1 = t[i__ + i__ * t_dim1], abs(d__1));
} else {
evi = (d__3 = t[i__ + i__ * t_dim1], abs(d__3)) +
sqrt((d__1 = t[i__ + 1 + i__ * t_dim1], abs(d__1))) *
sqrt((d__2 = t[i__ + (i__ + 1) * t_dim1], abs(d__2)));
}
if (k == kend) {
evk = (d__1 = t[k + k * t_dim1], abs(d__1));
} else if (t[k + 1 + k * t_dim1] == 0.) {
evk = (d__1 = t[k + k * t_dim1], abs(d__1));
} else {
evk = (d__3 = t[k + k * t_dim1], abs(d__3)) +
sqrt((d__1 = t[k + 1 + k * t_dim1], abs(d__1))) *
sqrt((d__2 = t[k + (k + 1) * t_dim1], abs(d__2)));
}
if (evi >= evk) {
i__ = k;
} else {
sorted = FALSE_;
ifst = i__;
ilst = k;
dtrexc_((char *)"V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &ilst, &work[1],
&info, (ftnlen)1);
if (info == 0) {
i__ = ilst;
} else {
i__ = k;
}
}
if (i__ == kend) {
k = i__ + 1;
} else if (t[i__ + 1 + i__ * t_dim1] == 0.) {
k = i__ + 1;
} else {
k = i__ + 2;
}
goto L40;
}
goto L30;
L50:;
}
i__ = jw;
L60:
if (i__ >= infqr + 1) {
if (i__ == infqr + 1) {
sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1];
si[kwtop + i__ - 1] = 0.;
--i__;
} else if (t[i__ + (i__ - 1) * t_dim1] == 0.) {
sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1];
si[kwtop + i__ - 1] = 0.;
--i__;
} else {
aa = t[i__ - 1 + (i__ - 1) * t_dim1];
cc = t[i__ + (i__ - 1) * t_dim1];
bb = t[i__ - 1 + i__ * t_dim1];
dd = t[i__ + i__ * t_dim1];
dlanv2_(&aa, &bb, &cc, &dd, &sr[kwtop + i__ - 2], &si[kwtop + i__ - 2],
&sr[kwtop + i__ - 1], &si[kwtop + i__ - 1], &cs, &sn);
i__ += -2;
}
goto L60;
}
if (*ns < jw || s == 0.) {
if (*ns > 1 && s != 0.) {
dcopy_(ns, &v[v_offset], ldv, &work[1], &c__1);
beta = work[1];
dlarfg_(ns, &beta, &work[2], &c__1, &tau);
work[1] = 1.;
i__1 = jw - 2;
i__2 = jw - 2;
dlaset_((char *)"L", &i__1, &i__2, &c_b12, &c_b12, &t[t_dim1 + 3], ldt, (ftnlen)1);
dlarf_((char *)"L", ns, &jw, &work[1], &c__1, &tau, &t[t_offset], ldt, &work[jw + 1],
(ftnlen)1);
dlarf_((char *)"R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, &work[jw + 1], (ftnlen)1);
dlarf_((char *)"R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, &work[jw + 1],
(ftnlen)1);
i__1 = *lwork - jw;
dgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1], &i__1, &info);
}
if (kwtop > 1) {
h__[kwtop + (kwtop - 1) * h_dim1] = s * v[v_dim1 + 1];
}
dlacpy_((char *)"U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1], ldh, (ftnlen)1);
i__1 = jw - 1;
i__2 = *ldt + 1;
i__3 = *ldh + 1;
dcopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1], &i__3);
if (*ns > 1 && s != 0.) {
i__1 = *lwork - jw;
dormhr_((char *)"R", (char *)"N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1], &v[v_offset], ldv,
&work[jw + 1], &i__1, &info, (ftnlen)1, (ftnlen)1);
}
if (*wantt) {
ltop = 1;
} else {
ltop = *ktop;
}
i__1 = kwtop - 1;
i__2 = *nv;
for (krow = ltop; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow += i__2) {
i__3 = *nv, i__4 = kwtop - krow;
kln = min(i__3, i__4);
dgemm_((char *)"N", (char *)"N", &kln, &jw, &jw, &c_b13, &h__[krow + kwtop * h_dim1], ldh, &v[v_offset],
ldv, &c_b12, &wv[wv_offset], ldwv, (ftnlen)1, (ftnlen)1);
dlacpy_((char *)"A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop * h_dim1], ldh,
(ftnlen)1);
}
if (*wantt) {
i__2 = *n;
i__1 = *nh;
for (kcol = *kbot + 1; i__1 < 0 ? kcol >= i__2 : kcol <= i__2; kcol += i__1) {
i__3 = *nh, i__4 = *n - kcol + 1;
kln = min(i__3, i__4);
dgemm_((char *)"C", (char *)"N", &jw, &kln, &jw, &c_b13, &v[v_offset], ldv,
&h__[kwtop + kcol * h_dim1], ldh, &c_b12, &t[t_offset], ldt, (ftnlen)1,
(ftnlen)1);
dlacpy_((char *)"A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol * h_dim1], ldh,
(ftnlen)1);
}
}
if (*wantz) {
i__1 = *ihiz;
i__2 = *nv;
for (krow = *iloz; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow += i__2) {
i__3 = *nv, i__4 = *ihiz - krow + 1;
kln = min(i__3, i__4);
dgemm_((char *)"N", (char *)"N", &kln, &jw, &jw, &c_b13, &z__[krow + kwtop * z_dim1], ldz,
&v[v_offset], ldv, &c_b12, &wv[wv_offset], ldwv, (ftnlen)1, (ftnlen)1);
dlacpy_((char *)"A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow + kwtop * z_dim1], ldz,
(ftnlen)1);
}
}
}
*nd = jw - *ns;
*ns -= infqr;
work[1] = (doublereal)lwkopt;
return 0;
}
#ifdef __cplusplus
}
#endif

375
lib/linalg/dlaqr3.cpp Normal file
View File

@ -0,0 +1,375 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static integer c__1 = 1;
static integer c_n1 = -1;
static logical c_true = TRUE_;
static doublereal c_b17 = 0.;
static doublereal c_b18 = 1.;
static integer c__12 = 12;
int dlaqr3_(logical *wantt, logical *wantz, integer *n, integer *ktop, integer *kbot, integer *nw,
doublereal *h__, integer *ldh, integer *iloz, integer *ihiz, doublereal *z__,
integer *ldz, integer *ns, integer *nd, doublereal *sr, doublereal *si, doublereal *v,
integer *ldv, integer *nh, doublereal *t, integer *ldt, integer *nv, doublereal *wv,
integer *ldwv, doublereal *work, integer *lwork)
{
integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1, wv_offset, z_dim1,
z_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
double sqrt(doublereal);
integer i__, j, k;
doublereal s, aa, bb, cc, dd, cs, sn;
integer jw;
doublereal evi, evk, foo;
integer kln;
doublereal tau, ulp;
integer lwk1, lwk2, lwk3;
doublereal beta;
integer kend, kcol, info, nmin, ifst, ilst, ltop, krow;
extern int dlarf_(char *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, ftnlen),
dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, ftnlen,
ftnlen);
logical bulge;
extern int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *);
integer infqr, kwtop;
extern int dlanv2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, doublereal *),
dlaqr4_(logical *, logical *, integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, integer *),
dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *, ftnlen);
extern int dgehrd_(integer *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, integer *),
dlarfg_(integer *, doublereal *, doublereal *, integer *, doublereal *),
dlahqr_(logical *, logical *, integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *, integer *,
integer *),
dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *,
ftnlen);
doublereal safmin;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
doublereal safmax;
extern int dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, ftnlen),
dtrexc_(char *, integer *, doublereal *, integer *, doublereal *, integer *, integer *,
integer *, doublereal *, integer *, ftnlen),
dormhr_(char *, char *, integer *, integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *, integer *, ftnlen,
ftnlen);
logical sorted;
doublereal smlnum;
integer lwkopt;
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--sr;
--si;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
wv_dim1 = *ldwv;
wv_offset = 1 + wv_dim1;
wv -= wv_offset;
--work;
i__1 = *nw, i__2 = *kbot - *ktop + 1;
jw = min(i__1, i__2);
if (jw <= 2) {
lwkopt = 1;
} else {
i__1 = jw - 1;
dgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], &c_n1, &info);
lwk1 = (integer)work[1];
i__1 = jw - 1;
dormhr_((char *)"R", (char *)"N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &v[v_offset], ldv,
&work[1], &c_n1, &info, (ftnlen)1, (ftnlen)1);
lwk2 = (integer)work[1];
dlaqr4_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[1], &si[1], &c__1, &jw,
&v[v_offset], ldv, &work[1], &c_n1, &infqr);
lwk3 = (integer)work[1];
i__1 = jw + max(lwk1, lwk2);
lwkopt = max(i__1, lwk3);
}
if (*lwork == -1) {
work[1] = (doublereal)lwkopt;
return 0;
}
*ns = 0;
*nd = 0;
work[1] = 1.;
if (*ktop > *kbot) {
return 0;
}
if (*nw < 1) {
return 0;
}
safmin = dlamch_((char *)"SAFE MINIMUM", (ftnlen)12);
safmax = 1. / safmin;
dlabad_(&safmin, &safmax);
ulp = dlamch_((char *)"PRECISION", (ftnlen)9);
smlnum = safmin * ((doublereal)(*n) / ulp);
i__1 = *nw, i__2 = *kbot - *ktop + 1;
jw = min(i__1, i__2);
kwtop = *kbot - jw + 1;
if (kwtop == *ktop) {
s = 0.;
} else {
s = h__[kwtop + (kwtop - 1) * h_dim1];
}
if (*kbot == kwtop) {
sr[kwtop] = h__[kwtop + kwtop * h_dim1];
si[kwtop] = 0.;
*ns = 1;
*nd = 0;
d__2 = smlnum, d__3 = ulp * (d__1 = h__[kwtop + kwtop * h_dim1], abs(d__1));
if (abs(s) <= max(d__2, d__3)) {
*ns = 0;
*nd = 1;
if (kwtop > *ktop) {
h__[kwtop + (kwtop - 1) * h_dim1] = 0.;
}
}
work[1] = 1.;
return 0;
}
dlacpy_((char *)"U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset], ldt, (ftnlen)1);
i__1 = jw - 1;
i__2 = *ldh + 1;
i__3 = *ldt + 1;
dcopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], &i__3);
dlaset_((char *)"A", &jw, &jw, &c_b17, &c_b18, &v[v_offset], ldv, (ftnlen)1);
nmin = ilaenv_(&c__12, (char *)"DLAQR3", (char *)"SV", &jw, &c__1, &jw, lwork, (ftnlen)6, (ftnlen)2);
if (jw > nmin) {
dlaqr4_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[kwtop], &si[kwtop], &c__1,
&jw, &v[v_offset], ldv, &work[1], lwork, &infqr);
} else {
dlahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[kwtop], &si[kwtop], &c__1,
&jw, &v[v_offset], ldv, &infqr);
}
i__1 = jw - 3;
for (j = 1; j <= i__1; ++j) {
t[j + 2 + j * t_dim1] = 0.;
t[j + 3 + j * t_dim1] = 0.;
}
if (jw > 2) {
t[jw + (jw - 2) * t_dim1] = 0.;
}
*ns = jw;
ilst = infqr + 1;
L20:
if (ilst <= *ns) {
if (*ns == 1) {
bulge = FALSE_;
} else {
bulge = t[*ns + (*ns - 1) * t_dim1] != 0.;
}
if (!bulge) {
foo = (d__1 = t[*ns + *ns * t_dim1], abs(d__1));
if (foo == 0.) {
foo = abs(s);
}
d__2 = smlnum, d__3 = ulp * foo;
if ((d__1 = s * v[*ns * v_dim1 + 1], abs(d__1)) <= max(d__2, d__3)) {
--(*ns);
} else {
ifst = *ns;
dtrexc_((char *)"V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &ilst, &work[1],
&info, (ftnlen)1);
++ilst;
}
} else {
foo = (d__3 = t[*ns + *ns * t_dim1], abs(d__3)) +
sqrt((d__1 = t[*ns + (*ns - 1) * t_dim1], abs(d__1))) *
sqrt((d__2 = t[*ns - 1 + *ns * t_dim1], abs(d__2)));
if (foo == 0.) {
foo = abs(s);
}
d__3 = (d__1 = s * v[*ns * v_dim1 + 1], abs(d__1)),
d__4 = (d__2 = s * v[(*ns - 1) * v_dim1 + 1], abs(d__2));
d__5 = smlnum, d__6 = ulp * foo;
if (max(d__3, d__4) <= max(d__5, d__6)) {
*ns += -2;
} else {
ifst = *ns;
dtrexc_((char *)"V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &ilst, &work[1],
&info, (ftnlen)1);
ilst += 2;
}
}
goto L20;
}
if (*ns == 0) {
s = 0.;
}
if (*ns < jw) {
sorted = FALSE_;
i__ = *ns + 1;
L30:
if (sorted) {
goto L50;
}
sorted = TRUE_;
kend = i__ - 1;
i__ = infqr + 1;
if (i__ == *ns) {
k = i__ + 1;
} else if (t[i__ + 1 + i__ * t_dim1] == 0.) {
k = i__ + 1;
} else {
k = i__ + 2;
}
L40:
if (k <= kend) {
if (k == i__ + 1) {
evi = (d__1 = t[i__ + i__ * t_dim1], abs(d__1));
} else {
evi = (d__3 = t[i__ + i__ * t_dim1], abs(d__3)) +
sqrt((d__1 = t[i__ + 1 + i__ * t_dim1], abs(d__1))) *
sqrt((d__2 = t[i__ + (i__ + 1) * t_dim1], abs(d__2)));
}
if (k == kend) {
evk = (d__1 = t[k + k * t_dim1], abs(d__1));
} else if (t[k + 1 + k * t_dim1] == 0.) {
evk = (d__1 = t[k + k * t_dim1], abs(d__1));
} else {
evk = (d__3 = t[k + k * t_dim1], abs(d__3)) +
sqrt((d__1 = t[k + 1 + k * t_dim1], abs(d__1))) *
sqrt((d__2 = t[k + (k + 1) * t_dim1], abs(d__2)));
}
if (evi >= evk) {
i__ = k;
} else {
sorted = FALSE_;
ifst = i__;
ilst = k;
dtrexc_((char *)"V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &ilst, &work[1],
&info, (ftnlen)1);
if (info == 0) {
i__ = ilst;
} else {
i__ = k;
}
}
if (i__ == kend) {
k = i__ + 1;
} else if (t[i__ + 1 + i__ * t_dim1] == 0.) {
k = i__ + 1;
} else {
k = i__ + 2;
}
goto L40;
}
goto L30;
L50:;
}
i__ = jw;
L60:
if (i__ >= infqr + 1) {
if (i__ == infqr + 1) {
sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1];
si[kwtop + i__ - 1] = 0.;
--i__;
} else if (t[i__ + (i__ - 1) * t_dim1] == 0.) {
sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1];
si[kwtop + i__ - 1] = 0.;
--i__;
} else {
aa = t[i__ - 1 + (i__ - 1) * t_dim1];
cc = t[i__ + (i__ - 1) * t_dim1];
bb = t[i__ - 1 + i__ * t_dim1];
dd = t[i__ + i__ * t_dim1];
dlanv2_(&aa, &bb, &cc, &dd, &sr[kwtop + i__ - 2], &si[kwtop + i__ - 2],
&sr[kwtop + i__ - 1], &si[kwtop + i__ - 1], &cs, &sn);
i__ += -2;
}
goto L60;
}
if (*ns < jw || s == 0.) {
if (*ns > 1 && s != 0.) {
dcopy_(ns, &v[v_offset], ldv, &work[1], &c__1);
beta = work[1];
dlarfg_(ns, &beta, &work[2], &c__1, &tau);
work[1] = 1.;
i__1 = jw - 2;
i__2 = jw - 2;
dlaset_((char *)"L", &i__1, &i__2, &c_b17, &c_b17, &t[t_dim1 + 3], ldt, (ftnlen)1);
dlarf_((char *)"L", ns, &jw, &work[1], &c__1, &tau, &t[t_offset], ldt, &work[jw + 1],
(ftnlen)1);
dlarf_((char *)"R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, &work[jw + 1], (ftnlen)1);
dlarf_((char *)"R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, &work[jw + 1],
(ftnlen)1);
i__1 = *lwork - jw;
dgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1], &i__1, &info);
}
if (kwtop > 1) {
h__[kwtop + (kwtop - 1) * h_dim1] = s * v[v_dim1 + 1];
}
dlacpy_((char *)"U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1], ldh, (ftnlen)1);
i__1 = jw - 1;
i__2 = *ldt + 1;
i__3 = *ldh + 1;
dcopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1], &i__3);
if (*ns > 1 && s != 0.) {
i__1 = *lwork - jw;
dormhr_((char *)"R", (char *)"N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1], &v[v_offset], ldv,
&work[jw + 1], &i__1, &info, (ftnlen)1, (ftnlen)1);
}
if (*wantt) {
ltop = 1;
} else {
ltop = *ktop;
}
i__1 = kwtop - 1;
i__2 = *nv;
for (krow = ltop; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow += i__2) {
i__3 = *nv, i__4 = kwtop - krow;
kln = min(i__3, i__4);
dgemm_((char *)"N", (char *)"N", &kln, &jw, &jw, &c_b18, &h__[krow + kwtop * h_dim1], ldh, &v[v_offset],
ldv, &c_b17, &wv[wv_offset], ldwv, (ftnlen)1, (ftnlen)1);
dlacpy_((char *)"A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop * h_dim1], ldh,
(ftnlen)1);
}
if (*wantt) {
i__2 = *n;
i__1 = *nh;
for (kcol = *kbot + 1; i__1 < 0 ? kcol >= i__2 : kcol <= i__2; kcol += i__1) {
i__3 = *nh, i__4 = *n - kcol + 1;
kln = min(i__3, i__4);
dgemm_((char *)"C", (char *)"N", &jw, &kln, &jw, &c_b18, &v[v_offset], ldv,
&h__[kwtop + kcol * h_dim1], ldh, &c_b17, &t[t_offset], ldt, (ftnlen)1,
(ftnlen)1);
dlacpy_((char *)"A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol * h_dim1], ldh,
(ftnlen)1);
}
}
if (*wantz) {
i__1 = *ihiz;
i__2 = *nv;
for (krow = *iloz; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow += i__2) {
i__3 = *nv, i__4 = *ihiz - krow + 1;
kln = min(i__3, i__4);
dgemm_((char *)"N", (char *)"N", &kln, &jw, &jw, &c_b18, &z__[krow + kwtop * z_dim1], ldz,
&v[v_offset], ldv, &c_b17, &wv[wv_offset], ldwv, (ftnlen)1, (ftnlen)1);
dlacpy_((char *)"A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow + kwtop * z_dim1], ldz,
(ftnlen)1);
}
}
}
*nd = jw - *ns;
*ns -= infqr;
work[1] = (doublereal)lwkopt;
return 0;
}
#ifdef __cplusplus
}
#endif

298
lib/linalg/dlaqr4.cpp Normal file
View File

@ -0,0 +1,298 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static integer c__13 = 13;
static integer c__15 = 15;
static integer c_n1 = -1;
static integer c__12 = 12;
static integer c__14 = 14;
static integer c__16 = 16;
static logical c_false = FALSE_;
static integer c__1 = 1;
static integer c__3 = 3;
int dlaqr4_(logical *wantt, logical *wantz, integer *n, integer *ilo, integer *ihi, doublereal *h__,
integer *ldh, doublereal *wr, doublereal *wi, integer *iloz, integer *ihiz,
doublereal *z__, integer *ldz, doublereal *work, integer *lwork, integer *info)
{
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
integer i__, k;
doublereal aa, bb, cc, dd;
integer ld;
doublereal cs;
integer nh, it, ks, kt;
doublereal sn;
integer ku, kv, ls, ns;
doublereal ss;
integer nw, inf, kdu, nho, nve, kwh, nsr, nwr, kwv, ndec, ndfl, kbot, nmin;
doublereal swap;
integer ktop;
doublereal zdum[1];
integer kacc22, itmax, nsmax, nwmax, kwtop;
extern int dlaqr2_(logical *, logical *, integer *, integer *, integer *, integer *,
doublereal *, integer *, integer *, integer *, doublereal *, integer *,
integer *, integer *, doublereal *, doublereal *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *),
dlanv2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *),
dlaqr5_(logical *, logical *, integer *, integer *, integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *, doublereal *, integer *);
integer nibble;
extern int dlahqr_(logical *, logical *, integer *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *),
dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *,
ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
char jbcmpz[2];
integer nwupbd;
logical sorted;
integer lwkopt;
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--wr;
--wi;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
*info = 0;
if (*n == 0) {
work[1] = 1.;
return 0;
}
if (*n <= 11) {
lwkopt = 1;
if (*lwork != -1) {
dlahqr_(wantt, wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &wi[1], iloz, ihiz,
&z__[z_offset], ldz, info);
}
} else {
*info = 0;
if (*wantt) {
*(unsigned char *)jbcmpz = 'S';
} else {
*(unsigned char *)jbcmpz = 'E';
}
if (*wantz) {
*(unsigned char *)&jbcmpz[1] = 'V';
} else {
*(unsigned char *)&jbcmpz[1] = 'N';
}
nwr = ilaenv_(&c__13, (char *)"DLAQR4", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, (ftnlen)2);
nwr = max(2, nwr);
i__1 = *ihi - *ilo + 1, i__2 = (*n - 1) / 3, i__1 = min(i__1, i__2);
nwr = min(i__1, nwr);
nsr = ilaenv_(&c__15, (char *)"DLAQR4", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, (ftnlen)2);
i__1 = nsr, i__2 = (*n + 6) / 9, i__1 = min(i__1, i__2), i__2 = *ihi - *ilo;
nsr = min(i__1, i__2);
i__1 = 2, i__2 = nsr - nsr % 2;
nsr = max(i__1, i__2);
i__1 = nwr + 1;
dlaqr2_(wantt, wantz, n, ilo, ihi, &i__1, &h__[h_offset], ldh, iloz, ihiz, &z__[z_offset],
ldz, &ls, &ld, &wr[1], &wi[1], &h__[h_offset], ldh, n, &h__[h_offset], ldh, n,
&h__[h_offset], ldh, &work[1], &c_n1);
i__1 = nsr * 3 / 2, i__2 = (integer)work[1];
lwkopt = max(i__1, i__2);
if (*lwork == -1) {
work[1] = (doublereal)lwkopt;
return 0;
}
nmin = ilaenv_(&c__12, (char *)"DLAQR4", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, (ftnlen)2);
nmin = max(11, nmin);
nibble = ilaenv_(&c__14, (char *)"DLAQR4", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, (ftnlen)2);
nibble = max(0, nibble);
kacc22 = ilaenv_(&c__16, (char *)"DLAQR4", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, (ftnlen)2);
kacc22 = max(0, kacc22);
kacc22 = min(2, kacc22);
i__1 = (*n - 1) / 3, i__2 = *lwork / 2;
nwmax = min(i__1, i__2);
nw = nwmax;
i__1 = (*n + 6) / 9, i__2 = (*lwork << 1) / 3;
nsmax = min(i__1, i__2);
nsmax -= nsmax % 2;
ndfl = 1;
i__1 = 10, i__2 = *ihi - *ilo + 1;
itmax = max(i__1, i__2) * 30;
kbot = *ihi;
i__1 = itmax;
for (it = 1; it <= i__1; ++it) {
if (kbot < *ilo) {
goto L90;
}
i__2 = *ilo + 1;
for (k = kbot; k >= i__2; --k) {
if (h__[k + (k - 1) * h_dim1] == 0.) {
goto L20;
}
}
k = *ilo;
L20:
ktop = k;
nh = kbot - ktop + 1;
nwupbd = min(nh, nwmax);
if (ndfl < 5) {
nw = min(nwupbd, nwr);
} else {
i__2 = nwupbd, i__3 = nw << 1;
nw = min(i__2, i__3);
}
if (nw < nwmax) {
if (nw >= nh - 1) {
nw = nh;
} else {
kwtop = kbot - nw + 1;
if ((d__1 = h__[kwtop + (kwtop - 1) * h_dim1], abs(d__1)) >
(d__2 = h__[kwtop - 1 + (kwtop - 2) * h_dim1], abs(d__2))) {
++nw;
}
}
}
if (ndfl < 5) {
ndec = -1;
} else if (ndec >= 0 || nw >= nwupbd) {
++ndec;
if (nw - ndec < 2) {
ndec = 0;
}
nw -= ndec;
}
kv = *n - nw + 1;
kt = nw + 1;
nho = *n - nw - 1 - kt + 1;
kwv = nw + 2;
nve = *n - nw - kwv + 1;
dlaqr2_(wantt, wantz, n, &ktop, &kbot, &nw, &h__[h_offset], ldh, iloz, ihiz,
&z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], &h__[kv + h_dim1], ldh, &nho,
&h__[kv + kt * h_dim1], ldh, &nve, &h__[kwv + h_dim1], ldh, &work[1], lwork);
kbot -= ld;
ks = kbot - ls + 1;
if (ld == 0 || ld * 100 <= nw * nibble && kbot - ktop + 1 > min(nmin, nwmax)) {
i__4 = 2, i__5 = kbot - ktop;
i__2 = min(nsmax, nsr), i__3 = max(i__4, i__5);
ns = min(i__2, i__3);
ns -= ns % 2;
if (ndfl % 6 == 0) {
ks = kbot - ns + 1;
i__3 = ks + 1, i__4 = ktop + 2;
i__2 = max(i__3, i__4);
for (i__ = kbot; i__ >= i__2; i__ += -2) {
ss = (d__1 = h__[i__ + (i__ - 1) * h_dim1], abs(d__1)) +
(d__2 = h__[i__ - 1 + (i__ - 2) * h_dim1], abs(d__2));
aa = ss * .75 + h__[i__ + i__ * h_dim1];
bb = ss;
cc = ss * -.4375;
dd = aa;
dlanv2_(&aa, &bb, &cc, &dd, &wr[i__ - 1], &wi[i__ - 1], &wr[i__], &wi[i__],
&cs, &sn);
}
if (ks == ktop) {
wr[ks + 1] = h__[ks + 1 + (ks + 1) * h_dim1];
wi[ks + 1] = 0.;
wr[ks] = wr[ks + 1];
wi[ks] = wi[ks + 1];
}
} else {
if (kbot - ks + 1 <= ns / 2) {
ks = kbot - ns + 1;
kt = *n - ns + 1;
dlacpy_((char *)"A", &ns, &ns, &h__[ks + ks * h_dim1], ldh, &h__[kt + h_dim1], ldh,
(ftnlen)1);
dlahqr_(&c_false, &c_false, &ns, &c__1, &ns, &h__[kt + h_dim1], ldh,
&wr[ks], &wi[ks], &c__1, &c__1, zdum, &c__1, &inf);
ks += inf;
if (ks >= kbot) {
aa = h__[kbot - 1 + (kbot - 1) * h_dim1];
cc = h__[kbot + (kbot - 1) * h_dim1];
bb = h__[kbot - 1 + kbot * h_dim1];
dd = h__[kbot + kbot * h_dim1];
dlanv2_(&aa, &bb, &cc, &dd, &wr[kbot - 1], &wi[kbot - 1], &wr[kbot],
&wi[kbot], &cs, &sn);
ks = kbot - 1;
}
}
if (kbot - ks + 1 > ns) {
sorted = FALSE_;
i__2 = ks + 1;
for (k = kbot; k >= i__2; --k) {
if (sorted) {
goto L60;
}
sorted = TRUE_;
i__3 = k - 1;
for (i__ = ks; i__ <= i__3; ++i__) {
if ((d__1 = wr[i__], abs(d__1)) + (d__2 = wi[i__], abs(d__2)) <
(d__3 = wr[i__ + 1], abs(d__3)) +
(d__4 = wi[i__ + 1], abs(d__4))) {
sorted = FALSE_;
swap = wr[i__];
wr[i__] = wr[i__ + 1];
wr[i__ + 1] = swap;
swap = wi[i__];
wi[i__] = wi[i__ + 1];
wi[i__ + 1] = swap;
}
}
}
L60:;
}
i__2 = ks + 2;
for (i__ = kbot; i__ >= i__2; i__ += -2) {
if (wi[i__] != -wi[i__ - 1]) {
swap = wr[i__];
wr[i__] = wr[i__ - 1];
wr[i__ - 1] = wr[i__ - 2];
wr[i__ - 2] = swap;
swap = wi[i__];
wi[i__] = wi[i__ - 1];
wi[i__ - 1] = wi[i__ - 2];
wi[i__ - 2] = swap;
}
}
}
if (kbot - ks + 1 == 2) {
if (wi[kbot] == 0.) {
if ((d__1 = wr[kbot] - h__[kbot + kbot * h_dim1], abs(d__1)) <
(d__2 = wr[kbot - 1] - h__[kbot + kbot * h_dim1], abs(d__2))) {
wr[kbot - 1] = wr[kbot];
} else {
wr[kbot] = wr[kbot - 1];
}
}
}
i__2 = ns, i__3 = kbot - ks + 1;
ns = min(i__2, i__3);
ns -= ns % 2;
ks = kbot - ns + 1;
kdu = ns * 3 - 3;
ku = *n - kdu + 1;
kwh = kdu + 1;
nho = *n - kdu - 3 - (kdu + 1) + 1;
kwv = kdu + 4;
nve = *n - kdu - kwv + 1;
dlaqr5_(wantt, wantz, &kacc22, n, &ktop, &kbot, &ns, &wr[ks], &wi[ks],
&h__[h_offset], ldh, iloz, ihiz, &z__[z_offset], ldz, &work[1], &c__3,
&h__[ku + h_dim1], ldh, &nve, &h__[kwv + h_dim1], ldh, &nho,
&h__[ku + kwh * h_dim1], ldh);
}
if (ld > 0) {
ndfl = 1;
} else {
++ndfl;
}
}
*info = kbot;
L90:;
}
work[1] = (doublereal)lwkopt;
return 0;
}
#ifdef __cplusplus
}
#endif

521
lib/linalg/dlaqr5.cpp Normal file
View File

@ -0,0 +1,521 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static doublereal c_b7 = 0.;
static doublereal c_b8 = 1.;
static integer c__3 = 3;
static integer c__1 = 1;
static integer c__2 = 2;
int dlaqr5_(logical *wantt, logical *wantz, integer *kacc22, integer *n, integer *ktop,
integer *kbot, integer *nshfts, doublereal *sr, doublereal *si, doublereal *h__,
integer *ldh, integer *iloz, integer *ihiz, doublereal *z__, integer *ldz,
doublereal *v, integer *ldv, doublereal *u, integer *ldu, integer *nv, doublereal *wv,
integer *ldwv, integer *nh, doublereal *wh, integer *ldwh)
{
integer h_dim1, h_offset, u_dim1, u_offset, v_dim1, v_offset, wh_dim1, wh_offset, wv_dim1,
wv_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
doublereal d__1, d__2, d__3, d__4, d__5;
integer i__, j, k, m, i2, j2, i4, j4, k1;
doublereal h11, h12, h21, h22;
integer m22, ns, nu;
doublereal vt[3], scl;
integer kdu, kms;
doublereal ulp;
integer knz, kzs;
doublereal tst1, tst2, beta;
logical blk22, bmp22;
integer mend, jcol, jlen, jbot, mbot;
doublereal swap;
integer jtop, jrow, mtop;
doublereal alpha;
logical accum;
extern int dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *, integer *,
ftnlen, ftnlen);
integer ndcol, incol, krcol, nbmps;
extern int dtrmm_(char *, char *, char *, char *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen,
ftnlen),
dlaqr1_(integer *, doublereal *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *),
dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *, ftnlen);
extern int dlarfg_(integer *, doublereal *, doublereal *, integer *, doublereal *),
dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *,
ftnlen);
doublereal safmin;
extern int dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, ftnlen);
doublereal safmax, refsum;
integer mstart;
doublereal smlnum;
--sr;
--si;
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
wv_dim1 = *ldwv;
wv_offset = 1 + wv_dim1;
wv -= wv_offset;
wh_dim1 = *ldwh;
wh_offset = 1 + wh_dim1;
wh -= wh_offset;
if (*nshfts < 2) {
return 0;
}
if (*ktop >= *kbot) {
return 0;
}
i__1 = *nshfts - 2;
for (i__ = 1; i__ <= i__1; i__ += 2) {
if (si[i__] != -si[i__ + 1]) {
swap = sr[i__];
sr[i__] = sr[i__ + 1];
sr[i__ + 1] = sr[i__ + 2];
sr[i__ + 2] = swap;
swap = si[i__];
si[i__] = si[i__ + 1];
si[i__ + 1] = si[i__ + 2];
si[i__ + 2] = swap;
}
}
ns = *nshfts - *nshfts % 2;
safmin = dlamch_((char *)"SAFE MINIMUM", (ftnlen)12);
safmax = 1. / safmin;
dlabad_(&safmin, &safmax);
ulp = dlamch_((char *)"PRECISION", (ftnlen)9);
smlnum = safmin * ((doublereal)(*n) / ulp);
accum = *kacc22 == 1 || *kacc22 == 2;
blk22 = ns > 2 && *kacc22 == 2;
if (*ktop + 2 <= *kbot) {
h__[*ktop + 2 + *ktop * h_dim1] = 0.;
}
nbmps = ns / 2;
kdu = nbmps * 6 - 3;
i__1 = *kbot - 2;
i__2 = nbmps * 3 - 2;
for (incol = (1 - nbmps) * 3 + *ktop - 1; i__2 < 0 ? incol >= i__1 : incol <= i__1;
incol += i__2) {
ndcol = incol + kdu;
if (accum) {
dlaset_((char *)"ALL", &kdu, &kdu, &c_b7, &c_b8, &u[u_offset], ldu, (ftnlen)3);
}
i__4 = incol + nbmps * 3 - 3, i__5 = *kbot - 2;
i__3 = min(i__4, i__5);
for (krcol = incol; krcol <= i__3; ++krcol) {
i__4 = 1, i__5 = (*ktop - 1 - krcol + 2) / 3 + 1;
mtop = max(i__4, i__5);
i__4 = nbmps, i__5 = (*kbot - krcol) / 3;
mbot = min(i__4, i__5);
m22 = mbot + 1;
bmp22 = mbot < nbmps && krcol + (m22 - 1) * 3 == *kbot - 2;
i__4 = mbot;
for (m = mtop; m <= i__4; ++m) {
k = krcol + (m - 1) * 3;
if (k == *ktop - 1) {
dlaqr1_(&c__3, &h__[*ktop + *ktop * h_dim1], ldh, &sr[(m << 1) - 1],
&si[(m << 1) - 1], &sr[m * 2], &si[m * 2], &v[m * v_dim1 + 1]);
alpha = v[m * v_dim1 + 1];
dlarfg_(&c__3, &alpha, &v[m * v_dim1 + 2], &c__1, &v[m * v_dim1 + 1]);
} else {
beta = h__[k + 1 + k * h_dim1];
v[m * v_dim1 + 2] = h__[k + 2 + k * h_dim1];
v[m * v_dim1 + 3] = h__[k + 3 + k * h_dim1];
dlarfg_(&c__3, &beta, &v[m * v_dim1 + 2], &c__1, &v[m * v_dim1 + 1]);
if (h__[k + 3 + k * h_dim1] != 0. || h__[k + 3 + (k + 1) * h_dim1] != 0. ||
h__[k + 3 + (k + 2) * h_dim1] == 0.) {
h__[k + 1 + k * h_dim1] = beta;
h__[k + 2 + k * h_dim1] = 0.;
h__[k + 3 + k * h_dim1] = 0.;
} else {
dlaqr1_(&c__3, &h__[k + 1 + (k + 1) * h_dim1], ldh, &sr[(m << 1) - 1],
&si[(m << 1) - 1], &sr[m * 2], &si[m * 2], vt);
alpha = vt[0];
dlarfg_(&c__3, &alpha, &vt[1], &c__1, vt);
refsum =
vt[0] * (h__[k + 1 + k * h_dim1] + vt[1] * h__[k + 2 + k * h_dim1]);
if ((d__1 = h__[k + 2 + k * h_dim1] - refsum * vt[1], abs(d__1)) +
(d__2 = refsum * vt[2], abs(d__2)) >
ulp * ((d__3 = h__[k + k * h_dim1], abs(d__3)) +
(d__4 = h__[k + 1 + (k + 1) * h_dim1], abs(d__4)) +
(d__5 = h__[k + 2 + (k + 2) * h_dim1], abs(d__5)))) {
h__[k + 1 + k * h_dim1] = beta;
h__[k + 2 + k * h_dim1] = 0.;
h__[k + 3 + k * h_dim1] = 0.;
} else {
h__[k + 1 + k * h_dim1] -= refsum;
h__[k + 2 + k * h_dim1] = 0.;
h__[k + 3 + k * h_dim1] = 0.;
v[m * v_dim1 + 1] = vt[0];
v[m * v_dim1 + 2] = vt[1];
v[m * v_dim1 + 3] = vt[2];
}
}
}
}
k = krcol + (m22 - 1) * 3;
if (bmp22) {
if (k == *ktop - 1) {
dlaqr1_(&c__2, &h__[k + 1 + (k + 1) * h_dim1], ldh, &sr[(m22 << 1) - 1],
&si[(m22 << 1) - 1], &sr[m22 * 2], &si[m22 * 2], &v[m22 * v_dim1 + 1]);
beta = v[m22 * v_dim1 + 1];
dlarfg_(&c__2, &beta, &v[m22 * v_dim1 + 2], &c__1, &v[m22 * v_dim1 + 1]);
} else {
beta = h__[k + 1 + k * h_dim1];
v[m22 * v_dim1 + 2] = h__[k + 2 + k * h_dim1];
dlarfg_(&c__2, &beta, &v[m22 * v_dim1 + 2], &c__1, &v[m22 * v_dim1 + 1]);
h__[k + 1 + k * h_dim1] = beta;
h__[k + 2 + k * h_dim1] = 0.;
}
}
if (accum) {
jbot = min(ndcol, *kbot);
} else if (*wantt) {
jbot = *n;
} else {
jbot = *kbot;
}
i__4 = jbot;
for (j = max(*ktop, krcol); j <= i__4; ++j) {
i__5 = mbot, i__6 = (j - krcol + 2) / 3;
mend = min(i__5, i__6);
i__5 = mend;
for (m = mtop; m <= i__5; ++m) {
k = krcol + (m - 1) * 3;
refsum = v[m * v_dim1 + 1] * (h__[k + 1 + j * h_dim1] +
v[m * v_dim1 + 2] * h__[k + 2 + j * h_dim1] +
v[m * v_dim1 + 3] * h__[k + 3 + j * h_dim1]);
h__[k + 1 + j * h_dim1] -= refsum;
h__[k + 2 + j * h_dim1] -= refsum * v[m * v_dim1 + 2];
h__[k + 3 + j * h_dim1] -= refsum * v[m * v_dim1 + 3];
}
}
if (bmp22) {
k = krcol + (m22 - 1) * 3;
i__4 = k + 1;
i__5 = jbot;
for (j = max(i__4, *ktop); j <= i__5; ++j) {
refsum = v[m22 * v_dim1 + 1] * (h__[k + 1 + j * h_dim1] +
v[m22 * v_dim1 + 2] * h__[k + 2 + j * h_dim1]);
h__[k + 1 + j * h_dim1] -= refsum;
h__[k + 2 + j * h_dim1] -= refsum * v[m22 * v_dim1 + 2];
}
}
if (accum) {
jtop = max(*ktop, incol);
} else if (*wantt) {
jtop = 1;
} else {
jtop = *ktop;
}
i__5 = mbot;
for (m = mtop; m <= i__5; ++m) {
if (v[m * v_dim1 + 1] != 0.) {
k = krcol + (m - 1) * 3;
i__6 = *kbot, i__7 = k + 3;
i__4 = min(i__6, i__7);
for (j = jtop; j <= i__4; ++j) {
refsum =
v[m * v_dim1 + 1] * (h__[j + (k + 1) * h_dim1] +
v[m * v_dim1 + 2] * h__[j + (k + 2) * h_dim1] +
v[m * v_dim1 + 3] * h__[j + (k + 3) * h_dim1]);
h__[j + (k + 1) * h_dim1] -= refsum;
h__[j + (k + 2) * h_dim1] -= refsum * v[m * v_dim1 + 2];
h__[j + (k + 3) * h_dim1] -= refsum * v[m * v_dim1 + 3];
}
if (accum) {
kms = k - incol;
i__4 = 1, i__6 = *ktop - incol;
i__7 = kdu;
for (j = max(i__4, i__6); j <= i__7; ++j) {
refsum =
v[m * v_dim1 + 1] * (u[j + (kms + 1) * u_dim1] +
v[m * v_dim1 + 2] * u[j + (kms + 2) * u_dim1] +
v[m * v_dim1 + 3] * u[j + (kms + 3) * u_dim1]);
u[j + (kms + 1) * u_dim1] -= refsum;
u[j + (kms + 2) * u_dim1] -= refsum * v[m * v_dim1 + 2];
u[j + (kms + 3) * u_dim1] -= refsum * v[m * v_dim1 + 3];
}
} else if (*wantz) {
i__7 = *ihiz;
for (j = *iloz; j <= i__7; ++j) {
refsum =
v[m * v_dim1 + 1] * (z__[j + (k + 1) * z_dim1] +
v[m * v_dim1 + 2] * z__[j + (k + 2) * z_dim1] +
v[m * v_dim1 + 3] * z__[j + (k + 3) * z_dim1]);
z__[j + (k + 1) * z_dim1] -= refsum;
z__[j + (k + 2) * z_dim1] -= refsum * v[m * v_dim1 + 2];
z__[j + (k + 3) * z_dim1] -= refsum * v[m * v_dim1 + 3];
}
}
}
}
k = krcol + (m22 - 1) * 3;
if (bmp22) {
if (v[m22 * v_dim1 + 1] != 0.) {
i__7 = *kbot, i__4 = k + 3;
i__5 = min(i__7, i__4);
for (j = jtop; j <= i__5; ++j) {
refsum =
v[m22 * v_dim1 + 1] * (h__[j + (k + 1) * h_dim1] +
v[m22 * v_dim1 + 2] * h__[j + (k + 2) * h_dim1]);
h__[j + (k + 1) * h_dim1] -= refsum;
h__[j + (k + 2) * h_dim1] -= refsum * v[m22 * v_dim1 + 2];
}
if (accum) {
kms = k - incol;
i__5 = 1, i__7 = *ktop - incol;
i__4 = kdu;
for (j = max(i__5, i__7); j <= i__4; ++j) {
refsum = v[m22 * v_dim1 + 1] *
(u[j + (kms + 1) * u_dim1] +
v[m22 * v_dim1 + 2] * u[j + (kms + 2) * u_dim1]);
u[j + (kms + 1) * u_dim1] -= refsum;
u[j + (kms + 2) * u_dim1] -= refsum * v[m22 * v_dim1 + 2];
}
} else if (*wantz) {
i__4 = *ihiz;
for (j = *iloz; j <= i__4; ++j) {
refsum = v[m22 * v_dim1 + 1] *
(z__[j + (k + 1) * z_dim1] +
v[m22 * v_dim1 + 2] * z__[j + (k + 2) * z_dim1]);
z__[j + (k + 1) * z_dim1] -= refsum;
z__[j + (k + 2) * z_dim1] -= refsum * v[m22 * v_dim1 + 2];
}
}
}
}
mstart = mtop;
if (krcol + (mstart - 1) * 3 < *ktop) {
++mstart;
}
mend = mbot;
if (bmp22) {
++mend;
}
if (krcol == *kbot - 2) {
++mend;
}
i__4 = mend;
for (m = mstart; m <= i__4; ++m) {
i__5 = *kbot - 1, i__7 = krcol + (m - 1) * 3;
k = min(i__5, i__7);
if (h__[k + 1 + k * h_dim1] != 0.) {
tst1 = (d__1 = h__[k + k * h_dim1], abs(d__1)) +
(d__2 = h__[k + 1 + (k + 1) * h_dim1], abs(d__2));
if (tst1 == 0.) {
if (k >= *ktop + 1) {
tst1 += (d__1 = h__[k + (k - 1) * h_dim1], abs(d__1));
}
if (k >= *ktop + 2) {
tst1 += (d__1 = h__[k + (k - 2) * h_dim1], abs(d__1));
}
if (k >= *ktop + 3) {
tst1 += (d__1 = h__[k + (k - 3) * h_dim1], abs(d__1));
}
if (k <= *kbot - 2) {
tst1 += (d__1 = h__[k + 2 + (k + 1) * h_dim1], abs(d__1));
}
if (k <= *kbot - 3) {
tst1 += (d__1 = h__[k + 3 + (k + 1) * h_dim1], abs(d__1));
}
if (k <= *kbot - 4) {
tst1 += (d__1 = h__[k + 4 + (k + 1) * h_dim1], abs(d__1));
}
}
d__2 = smlnum, d__3 = ulp * tst1;
if ((d__1 = h__[k + 1 + k * h_dim1], abs(d__1)) <= max(d__2, d__3)) {
d__3 = (d__1 = h__[k + 1 + k * h_dim1], abs(d__1)),
d__4 = (d__2 = h__[k + (k + 1) * h_dim1], abs(d__2));
h12 = max(d__3, d__4);
d__3 = (d__1 = h__[k + 1 + k * h_dim1], abs(d__1)),
d__4 = (d__2 = h__[k + (k + 1) * h_dim1], abs(d__2));
h21 = min(d__3, d__4);
d__3 = (d__1 = h__[k + 1 + (k + 1) * h_dim1], abs(d__1)),
d__4 =
(d__2 = h__[k + k * h_dim1] - h__[k + 1 + (k + 1) * h_dim1], abs(d__2));
h11 = max(d__3, d__4);
d__3 = (d__1 = h__[k + 1 + (k + 1) * h_dim1], abs(d__1)),
d__4 =
(d__2 = h__[k + k * h_dim1] - h__[k + 1 + (k + 1) * h_dim1], abs(d__2));
h22 = min(d__3, d__4);
scl = h11 + h12;
tst2 = h22 * (h11 / scl);
d__1 = smlnum, d__2 = ulp * tst2;
if (tst2 == 0. || h21 * (h12 / scl) <= max(d__1, d__2)) {
h__[k + 1 + k * h_dim1] = 0.;
}
}
}
}
i__4 = nbmps, i__5 = (*kbot - krcol - 1) / 3;
mend = min(i__4, i__5);
i__4 = mend;
for (m = mtop; m <= i__4; ++m) {
k = krcol + (m - 1) * 3;
refsum = v[m * v_dim1 + 1] * v[m * v_dim1 + 3] * h__[k + 4 + (k + 3) * h_dim1];
h__[k + 4 + (k + 1) * h_dim1] = -refsum;
h__[k + 4 + (k + 2) * h_dim1] = -refsum * v[m * v_dim1 + 2];
h__[k + 4 + (k + 3) * h_dim1] -= refsum * v[m * v_dim1 + 3];
}
}
if (accum) {
if (*wantt) {
jtop = 1;
jbot = *n;
} else {
jtop = *ktop;
jbot = *kbot;
}
if (!blk22 || incol < *ktop || ndcol > *kbot || ns <= 2) {
i__3 = 1, i__4 = *ktop - incol;
k1 = max(i__3, i__4);
i__3 = 0, i__4 = ndcol - *kbot;
nu = kdu - max(i__3, i__4) - k1 + 1;
i__3 = jbot;
i__4 = *nh;
for (jcol = min(ndcol, *kbot) + 1; i__4 < 0 ? jcol >= i__3 : jcol <= i__3;
jcol += i__4) {
i__5 = *nh, i__7 = jbot - jcol + 1;
jlen = min(i__5, i__7);
dgemm_((char *)"C", (char *)"N", &nu, &jlen, &nu, &c_b8, &u[k1 + k1 * u_dim1], ldu,
&h__[incol + k1 + jcol * h_dim1], ldh, &c_b7, &wh[wh_offset], ldwh,
(ftnlen)1, (ftnlen)1);
dlacpy_((char *)"ALL", &nu, &jlen, &wh[wh_offset], ldwh,
&h__[incol + k1 + jcol * h_dim1], ldh, (ftnlen)3);
}
i__4 = max(*ktop, incol) - 1;
i__3 = *nv;
for (jrow = jtop; i__3 < 0 ? jrow >= i__4 : jrow <= i__4; jrow += i__3) {
i__5 = *nv, i__7 = max(*ktop, incol) - jrow;
jlen = min(i__5, i__7);
dgemm_((char *)"N", (char *)"N", &jlen, &nu, &nu, &c_b8, &h__[jrow + (incol + k1) * h_dim1],
ldh, &u[k1 + k1 * u_dim1], ldu, &c_b7, &wv[wv_offset], ldwv, (ftnlen)1,
(ftnlen)1);
dlacpy_((char *)"ALL", &jlen, &nu, &wv[wv_offset], ldwv,
&h__[jrow + (incol + k1) * h_dim1], ldh, (ftnlen)3);
}
if (*wantz) {
i__3 = *ihiz;
i__4 = *nv;
for (jrow = *iloz; i__4 < 0 ? jrow >= i__3 : jrow <= i__3; jrow += i__4) {
i__5 = *nv, i__7 = *ihiz - jrow + 1;
jlen = min(i__5, i__7);
dgemm_((char *)"N", (char *)"N", &jlen, &nu, &nu, &c_b8, &z__[jrow + (incol + k1) * z_dim1],
ldz, &u[k1 + k1 * u_dim1], ldu, &c_b7, &wv[wv_offset], ldwv,
(ftnlen)1, (ftnlen)1);
dlacpy_((char *)"ALL", &jlen, &nu, &wv[wv_offset], ldwv,
&z__[jrow + (incol + k1) * z_dim1], ldz, (ftnlen)3);
}
}
} else {
i2 = (kdu + 1) / 2;
i4 = kdu;
j2 = i4 - i2;
j4 = kdu;
kzs = j4 - j2 - (ns + 1);
knz = ns + 1;
i__4 = jbot;
i__3 = *nh;
for (jcol = min(ndcol, *kbot) + 1; i__3 < 0 ? jcol >= i__4 : jcol <= i__4;
jcol += i__3) {
i__5 = *nh, i__7 = jbot - jcol + 1;
jlen = min(i__5, i__7);
dlacpy_((char *)"ALL", &knz, &jlen, &h__[incol + 1 + j2 + jcol * h_dim1], ldh,
&wh[kzs + 1 + wh_dim1], ldwh, (ftnlen)3);
dlaset_((char *)"ALL", &kzs, &jlen, &c_b7, &c_b7, &wh[wh_offset], ldwh, (ftnlen)3);
dtrmm_((char *)"L", (char *)"U", (char *)"C", (char *)"N", &knz, &jlen, &c_b8, &u[j2 + 1 + (kzs + 1) * u_dim1],
ldu, &wh[kzs + 1 + wh_dim1], ldwh, (ftnlen)1, (ftnlen)1, (ftnlen)1,
(ftnlen)1);
dgemm_((char *)"C", (char *)"N", &i2, &jlen, &j2, &c_b8, &u[u_offset], ldu,
&h__[incol + 1 + jcol * h_dim1], ldh, &c_b8, &wh[wh_offset], ldwh,
(ftnlen)1, (ftnlen)1);
dlacpy_((char *)"ALL", &j2, &jlen, &h__[incol + 1 + jcol * h_dim1], ldh,
&wh[i2 + 1 + wh_dim1], ldwh, (ftnlen)3);
dtrmm_((char *)"L", (char *)"L", (char *)"C", (char *)"N", &j2, &jlen, &c_b8, &u[(i2 + 1) * u_dim1 + 1], ldu,
&wh[i2 + 1 + wh_dim1], ldwh, (ftnlen)1, (ftnlen)1, (ftnlen)1, (ftnlen)1);
i__5 = i4 - i2;
i__7 = j4 - j2;
dgemm_((char *)"C", (char *)"N", &i__5, &jlen, &i__7, &c_b8, &u[j2 + 1 + (i2 + 1) * u_dim1],
ldu, &h__[incol + 1 + j2 + jcol * h_dim1], ldh, &c_b8,
&wh[i2 + 1 + wh_dim1], ldwh, (ftnlen)1, (ftnlen)1);
dlacpy_((char *)"ALL", &kdu, &jlen, &wh[wh_offset], ldwh,
&h__[incol + 1 + jcol * h_dim1], ldh, (ftnlen)3);
}
i__3 = max(incol, *ktop) - 1;
i__4 = *nv;
for (jrow = jtop; i__4 < 0 ? jrow >= i__3 : jrow <= i__3; jrow += i__4) {
i__5 = *nv, i__7 = max(incol, *ktop) - jrow;
jlen = min(i__5, i__7);
dlacpy_((char *)"ALL", &jlen, &knz, &h__[jrow + (incol + 1 + j2) * h_dim1], ldh,
&wv[(kzs + 1) * wv_dim1 + 1], ldwv, (ftnlen)3);
dlaset_((char *)"ALL", &jlen, &kzs, &c_b7, &c_b7, &wv[wv_offset], ldwv, (ftnlen)3);
dtrmm_((char *)"R", (char *)"U", (char *)"N", (char *)"N", &jlen, &knz, &c_b8, &u[j2 + 1 + (kzs + 1) * u_dim1],
ldu, &wv[(kzs + 1) * wv_dim1 + 1], ldwv, (ftnlen)1, (ftnlen)1, (ftnlen)1,
(ftnlen)1);
dgemm_((char *)"N", (char *)"N", &jlen, &i2, &j2, &c_b8, &h__[jrow + (incol + 1) * h_dim1], ldh,
&u[u_offset], ldu, &c_b8, &wv[wv_offset], ldwv, (ftnlen)1, (ftnlen)1);
dlacpy_((char *)"ALL", &jlen, &j2, &h__[jrow + (incol + 1) * h_dim1], ldh,
&wv[(i2 + 1) * wv_dim1 + 1], ldwv, (ftnlen)3);
i__5 = i4 - i2;
dtrmm_((char *)"R", (char *)"L", (char *)"N", (char *)"N", &jlen, &i__5, &c_b8, &u[(i2 + 1) * u_dim1 + 1], ldu,
&wv[(i2 + 1) * wv_dim1 + 1], ldwv, (ftnlen)1, (ftnlen)1, (ftnlen)1,
(ftnlen)1);
i__5 = i4 - i2;
i__7 = j4 - j2;
dgemm_((char *)"N", (char *)"N", &jlen, &i__5, &i__7, &c_b8,
&h__[jrow + (incol + 1 + j2) * h_dim1], ldh,
&u[j2 + 1 + (i2 + 1) * u_dim1], ldu, &c_b8, &wv[(i2 + 1) * wv_dim1 + 1],
ldwv, (ftnlen)1, (ftnlen)1);
dlacpy_((char *)"ALL", &jlen, &kdu, &wv[wv_offset], ldwv,
&h__[jrow + (incol + 1) * h_dim1], ldh, (ftnlen)3);
}
if (*wantz) {
i__4 = *ihiz;
i__3 = *nv;
for (jrow = *iloz; i__3 < 0 ? jrow >= i__4 : jrow <= i__4; jrow += i__3) {
i__5 = *nv, i__7 = *ihiz - jrow + 1;
jlen = min(i__5, i__7);
dlacpy_((char *)"ALL", &jlen, &knz, &z__[jrow + (incol + 1 + j2) * z_dim1], ldz,
&wv[(kzs + 1) * wv_dim1 + 1], ldwv, (ftnlen)3);
dlaset_((char *)"ALL", &jlen, &kzs, &c_b7, &c_b7, &wv[wv_offset], ldwv, (ftnlen)3);
dtrmm_((char *)"R", (char *)"U", (char *)"N", (char *)"N", &jlen, &knz, &c_b8,
&u[j2 + 1 + (kzs + 1) * u_dim1], ldu, &wv[(kzs + 1) * wv_dim1 + 1],
ldwv, (ftnlen)1, (ftnlen)1, (ftnlen)1, (ftnlen)1);
dgemm_((char *)"N", (char *)"N", &jlen, &i2, &j2, &c_b8, &z__[jrow + (incol + 1) * z_dim1],
ldz, &u[u_offset], ldu, &c_b8, &wv[wv_offset], ldwv, (ftnlen)1,
(ftnlen)1);
dlacpy_((char *)"ALL", &jlen, &j2, &z__[jrow + (incol + 1) * z_dim1], ldz,
&wv[(i2 + 1) * wv_dim1 + 1], ldwv, (ftnlen)3);
i__5 = i4 - i2;
dtrmm_((char *)"R", (char *)"L", (char *)"N", (char *)"N", &jlen, &i__5, &c_b8, &u[(i2 + 1) * u_dim1 + 1],
ldu, &wv[(i2 + 1) * wv_dim1 + 1], ldwv, (ftnlen)1, (ftnlen)1,
(ftnlen)1, (ftnlen)1);
i__5 = i4 - i2;
i__7 = j4 - j2;
dgemm_((char *)"N", (char *)"N", &jlen, &i__5, &i__7, &c_b8,
&z__[jrow + (incol + 1 + j2) * z_dim1], ldz,
&u[j2 + 1 + (i2 + 1) * u_dim1], ldu, &c_b8,
&wv[(i2 + 1) * wv_dim1 + 1], ldwv, (ftnlen)1, (ftnlen)1);
dlacpy_((char *)"ALL", &jlen, &kdu, &wv[wv_offset], ldwv,
&z__[jrow + (incol + 1) * z_dim1], ldz, (ftnlen)3);
}
}
}
}
}
return 0;
}
#ifdef __cplusplus
}
#endif

552
lib/linalg/dlarfx.cpp Normal file
View File

@ -0,0 +1,552 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static integer c__1 = 1;
int dlarfx_(char *side, integer *m, integer *n, doublereal *v, doublereal *tau, doublereal *c__,
integer *ldc, doublereal *work, ftnlen side_len)
{
integer c_dim1, c_offset, i__1;
integer j;
doublereal t1, t2, t3, t4, t5, t6, t7, t8, t9, v1, v2, v3, v4, v5, v6, v7, v8, v9, t10, v10,
sum;
extern int dlarf_(char *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, ftnlen);
extern logical lsame_(char *, char *, ftnlen, ftnlen);
--v;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
if (*tau == 0.) {
return 0;
}
if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) {
switch (*m) {
case 1:
goto L10;
case 2:
goto L30;
case 3:
goto L50;
case 4:
goto L70;
case 5:
goto L90;
case 6:
goto L110;
case 7:
goto L130;
case 8:
goto L150;
case 9:
goto L170;
case 10:
goto L190;
}
dlarf_(side, m, n, &v[1], &c__1, tau, &c__[c_offset], ldc, &work[1], (ftnlen)1);
goto L410;
L10:
t1 = 1. - *tau * v[1] * v[1];
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
c__[j * c_dim1 + 1] = t1 * c__[j * c_dim1 + 1];
}
goto L410;
L30:
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
}
goto L410;
L50:
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * c__[j * c_dim1 + 3];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
c__[j * c_dim1 + 3] -= sum * t3;
}
goto L410;
L70:
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * c__[j * c_dim1 + 3] +
v4 * c__[j * c_dim1 + 4];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
c__[j * c_dim1 + 3] -= sum * t3;
c__[j * c_dim1 + 4] -= sum * t4;
}
goto L410;
L90:
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * c__[j * c_dim1 + 3] +
v4 * c__[j * c_dim1 + 4] + v5 * c__[j * c_dim1 + 5];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
c__[j * c_dim1 + 3] -= sum * t3;
c__[j * c_dim1 + 4] -= sum * t4;
c__[j * c_dim1 + 5] -= sum * t5;
}
goto L410;
L110:
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * c__[j * c_dim1 + 3] +
v4 * c__[j * c_dim1 + 4] + v5 * c__[j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
c__[j * c_dim1 + 3] -= sum * t3;
c__[j * c_dim1 + 4] -= sum * t4;
c__[j * c_dim1 + 5] -= sum * t5;
c__[j * c_dim1 + 6] -= sum * t6;
}
goto L410;
L130:
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
v7 = v[7];
t7 = *tau * v7;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * c__[j * c_dim1 + 3] +
v4 * c__[j * c_dim1 + 4] + v5 * c__[j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] +
v7 * c__[j * c_dim1 + 7];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
c__[j * c_dim1 + 3] -= sum * t3;
c__[j * c_dim1 + 4] -= sum * t4;
c__[j * c_dim1 + 5] -= sum * t5;
c__[j * c_dim1 + 6] -= sum * t6;
c__[j * c_dim1 + 7] -= sum * t7;
}
goto L410;
L150:
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
v7 = v[7];
t7 = *tau * v7;
v8 = v[8];
t8 = *tau * v8;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * c__[j * c_dim1 + 3] +
v4 * c__[j * c_dim1 + 4] + v5 * c__[j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] +
v7 * c__[j * c_dim1 + 7] + v8 * c__[j * c_dim1 + 8];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
c__[j * c_dim1 + 3] -= sum * t3;
c__[j * c_dim1 + 4] -= sum * t4;
c__[j * c_dim1 + 5] -= sum * t5;
c__[j * c_dim1 + 6] -= sum * t6;
c__[j * c_dim1 + 7] -= sum * t7;
c__[j * c_dim1 + 8] -= sum * t8;
}
goto L410;
L170:
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
v7 = v[7];
t7 = *tau * v7;
v8 = v[8];
t8 = *tau * v8;
v9 = v[9];
t9 = *tau * v9;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * c__[j * c_dim1 + 3] +
v4 * c__[j * c_dim1 + 4] + v5 * c__[j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] +
v7 * c__[j * c_dim1 + 7] + v8 * c__[j * c_dim1 + 8] + v9 * c__[j * c_dim1 + 9];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
c__[j * c_dim1 + 3] -= sum * t3;
c__[j * c_dim1 + 4] -= sum * t4;
c__[j * c_dim1 + 5] -= sum * t5;
c__[j * c_dim1 + 6] -= sum * t6;
c__[j * c_dim1 + 7] -= sum * t7;
c__[j * c_dim1 + 8] -= sum * t8;
c__[j * c_dim1 + 9] -= sum * t9;
}
goto L410;
L190:
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
v7 = v[7];
t7 = *tau * v7;
v8 = v[8];
t8 = *tau * v8;
v9 = v[9];
t9 = *tau * v9;
v10 = v[10];
t10 = *tau * v10;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * c__[j * c_dim1 + 3] +
v4 * c__[j * c_dim1 + 4] + v5 * c__[j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] +
v7 * c__[j * c_dim1 + 7] + v8 * c__[j * c_dim1 + 8] + v9 * c__[j * c_dim1 + 9] +
v10 * c__[j * c_dim1 + 10];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
c__[j * c_dim1 + 3] -= sum * t3;
c__[j * c_dim1 + 4] -= sum * t4;
c__[j * c_dim1 + 5] -= sum * t5;
c__[j * c_dim1 + 6] -= sum * t6;
c__[j * c_dim1 + 7] -= sum * t7;
c__[j * c_dim1 + 8] -= sum * t8;
c__[j * c_dim1 + 9] -= sum * t9;
c__[j * c_dim1 + 10] -= sum * t10;
}
goto L410;
} else {
switch (*n) {
case 1:
goto L210;
case 2:
goto L230;
case 3:
goto L250;
case 4:
goto L270;
case 5:
goto L290;
case 6:
goto L310;
case 7:
goto L330;
case 8:
goto L350;
case 9:
goto L370;
case 10:
goto L390;
}
dlarf_(side, m, n, &v[1], &c__1, tau, &c__[c_offset], ldc, &work[1], (ftnlen)1);
goto L410;
L210:
t1 = 1. - *tau * v[1] * v[1];
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
c__[j + c_dim1] = t1 * c__[j + c_dim1];
}
goto L410;
L230:
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
}
goto L410;
L250:
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * c__[j + c_dim1 * 3];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
c__[j + c_dim1 * 3] -= sum * t3;
}
goto L410;
L270:
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * c__[j + c_dim1 * 3] +
v4 * c__[j + (c_dim1 << 2)];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
c__[j + c_dim1 * 3] -= sum * t3;
c__[j + (c_dim1 << 2)] -= sum * t4;
}
goto L410;
L290:
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * c__[j + c_dim1 * 3] +
v4 * c__[j + (c_dim1 << 2)] + v5 * c__[j + c_dim1 * 5];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
c__[j + c_dim1 * 3] -= sum * t3;
c__[j + (c_dim1 << 2)] -= sum * t4;
c__[j + c_dim1 * 5] -= sum * t5;
}
goto L410;
L310:
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * c__[j + c_dim1 * 3] +
v4 * c__[j + (c_dim1 << 2)] + v5 * c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
c__[j + c_dim1 * 3] -= sum * t3;
c__[j + (c_dim1 << 2)] -= sum * t4;
c__[j + c_dim1 * 5] -= sum * t5;
c__[j + c_dim1 * 6] -= sum * t6;
}
goto L410;
L330:
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
v7 = v[7];
t7 = *tau * v7;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * c__[j + c_dim1 * 3] +
v4 * c__[j + (c_dim1 << 2)] + v5 * c__[j + c_dim1 * 5] +
v6 * c__[j + c_dim1 * 6] + v7 * c__[j + c_dim1 * 7];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
c__[j + c_dim1 * 3] -= sum * t3;
c__[j + (c_dim1 << 2)] -= sum * t4;
c__[j + c_dim1 * 5] -= sum * t5;
c__[j + c_dim1 * 6] -= sum * t6;
c__[j + c_dim1 * 7] -= sum * t7;
}
goto L410;
L350:
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
v7 = v[7];
t7 = *tau * v7;
v8 = v[8];
t8 = *tau * v8;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * c__[j + c_dim1 * 3] +
v4 * c__[j + (c_dim1 << 2)] + v5 * c__[j + c_dim1 * 5] +
v6 * c__[j + c_dim1 * 6] + v7 * c__[j + c_dim1 * 7] + v8 * c__[j + (c_dim1 << 3)];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
c__[j + c_dim1 * 3] -= sum * t3;
c__[j + (c_dim1 << 2)] -= sum * t4;
c__[j + c_dim1 * 5] -= sum * t5;
c__[j + c_dim1 * 6] -= sum * t6;
c__[j + c_dim1 * 7] -= sum * t7;
c__[j + (c_dim1 << 3)] -= sum * t8;
}
goto L410;
L370:
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
v7 = v[7];
t7 = *tau * v7;
v8 = v[8];
t8 = *tau * v8;
v9 = v[9];
t9 = *tau * v9;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * c__[j + c_dim1 * 3] +
v4 * c__[j + (c_dim1 << 2)] + v5 * c__[j + c_dim1 * 5] +
v6 * c__[j + c_dim1 * 6] + v7 * c__[j + c_dim1 * 7] +
v8 * c__[j + (c_dim1 << 3)] + v9 * c__[j + c_dim1 * 9];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
c__[j + c_dim1 * 3] -= sum * t3;
c__[j + (c_dim1 << 2)] -= sum * t4;
c__[j + c_dim1 * 5] -= sum * t5;
c__[j + c_dim1 * 6] -= sum * t6;
c__[j + c_dim1 * 7] -= sum * t7;
c__[j + (c_dim1 << 3)] -= sum * t8;
c__[j + c_dim1 * 9] -= sum * t9;
}
goto L410;
L390:
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
v7 = v[7];
t7 = *tau * v7;
v8 = v[8];
t8 = *tau * v8;
v9 = v[9];
t9 = *tau * v9;
v10 = v[10];
t10 = *tau * v10;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * c__[j + c_dim1 * 3] +
v4 * c__[j + (c_dim1 << 2)] + v5 * c__[j + c_dim1 * 5] +
v6 * c__[j + c_dim1 * 6] + v7 * c__[j + c_dim1 * 7] +
v8 * c__[j + (c_dim1 << 3)] + v9 * c__[j + c_dim1 * 9] +
v10 * c__[j + c_dim1 * 10];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
c__[j + c_dim1 * 3] -= sum * t3;
c__[j + (c_dim1 << 2)] -= sum * t4;
c__[j + c_dim1 * 5] -= sum * t5;
c__[j + c_dim1 * 6] -= sum * t6;
c__[j + c_dim1 * 7] -= sum * t7;
c__[j + (c_dim1 << 3)] -= sum * t8;
c__[j + c_dim1 * 9] -= sum * t9;
c__[j + c_dim1 * 10] -= sum * t10;
}
goto L410;
}
L410:
return 0;
}
#ifdef __cplusplus
}
#endif

143
lib/linalg/dlasd0.cpp Normal file
View File

@ -0,0 +1,143 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static integer c__0 = 0;
static integer c__2 = 2;
int dlasd0_(integer *n, integer *sqre, doublereal *d__, doublereal *e, doublereal *u, integer *ldu,
doublereal *vt, integer *ldvt, integer *smlsiz, integer *iwork, doublereal *work,
integer *info)
{
integer u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2;
integer pow_lmp_ii(integer *, integer *);
integer i__, j, m, i1, ic, lf, nd, ll, nl, nr, im1, ncc, nlf, nrf, iwk, lvl, ndb1, nlp1, nrp1;
doublereal beta;
integer idxq, nlvl;
doublereal alpha;
integer inode, ndiml, idxqc, ndimr, itemp, sqrei;
extern int dlasd1_(integer *, integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, integer *, integer *,
doublereal *, integer *),
dlasdq_(char *, integer *, integer *, integer *, integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, ftnlen),
dlasdt_(integer *, integer *, integer *, integer *, integer *, integer *, integer *),
xerbla_(char *, integer *, ftnlen);
--d__;
--e;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1;
vt -= vt_offset;
--iwork;
--work;
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*sqre < 0 || *sqre > 1) {
*info = -2;
}
m = *n + *sqre;
if (*ldu < *n) {
*info = -6;
} else if (*ldvt < m) {
*info = -8;
} else if (*smlsiz < 3) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"DLASD0", &i__1, (ftnlen)6);
return 0;
}
if (*n <= *smlsiz) {
dlasdq_((char *)"U", sqre, n, &m, n, &c__0, &d__[1], &e[1], &vt[vt_offset], ldvt, &u[u_offset], ldu,
&u[u_offset], ldu, &work[1], info, (ftnlen)1);
return 0;
}
inode = 1;
ndiml = inode + *n;
ndimr = ndiml + *n;
idxq = ndimr + *n;
iwk = idxq + *n;
dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr], smlsiz);
ndb1 = (nd + 1) / 2;
ncc = 0;
i__1 = nd;
for (i__ = ndb1; i__ <= i__1; ++i__) {
i1 = i__ - 1;
ic = iwork[inode + i1];
nl = iwork[ndiml + i1];
nlp1 = nl + 1;
nr = iwork[ndimr + i1];
nrp1 = nr + 1;
nlf = ic - nl;
nrf = ic + 1;
sqrei = 1;
dlasdq_((char *)"U", &sqrei, &nl, &nlp1, &nl, &ncc, &d__[nlf], &e[nlf], &vt[nlf + nlf * vt_dim1],
ldvt, &u[nlf + nlf * u_dim1], ldu, &u[nlf + nlf * u_dim1], ldu, &work[1], info,
(ftnlen)1);
if (*info != 0) {
return 0;
}
itemp = idxq + nlf - 2;
i__2 = nl;
for (j = 1; j <= i__2; ++j) {
iwork[itemp + j] = j;
}
if (i__ == nd) {
sqrei = *sqre;
} else {
sqrei = 1;
}
nrp1 = nr + sqrei;
dlasdq_((char *)"U", &sqrei, &nr, &nrp1, &nr, &ncc, &d__[nrf], &e[nrf], &vt[nrf + nrf * vt_dim1],
ldvt, &u[nrf + nrf * u_dim1], ldu, &u[nrf + nrf * u_dim1], ldu, &work[1], info,
(ftnlen)1);
if (*info != 0) {
return 0;
}
itemp = idxq + ic;
i__2 = nr;
for (j = 1; j <= i__2; ++j) {
iwork[itemp + j - 1] = j;
}
}
for (lvl = nlvl; lvl >= 1; --lvl) {
if (lvl == 1) {
lf = 1;
ll = 1;
} else {
i__1 = lvl - 1;
lf = pow_lmp_ii(&c__2, &i__1);
ll = (lf << 1) - 1;
}
i__1 = ll;
for (i__ = lf; i__ <= i__1; ++i__) {
im1 = i__ - 1;
ic = iwork[inode + im1];
nl = iwork[ndiml + im1];
nr = iwork[ndimr + im1];
nlf = ic - nl;
if (*sqre == 0 && i__ == ll) {
sqrei = *sqre;
} else {
sqrei = 1;
}
idxqc = idxq + nlf - 1;
alpha = d__[ic];
beta = e[ic];
dlasd1_(&nl, &nr, &sqrei, &d__[nlf], &alpha, &beta, &u[nlf + nlf * u_dim1], ldu,
&vt[nlf + nlf * vt_dim1], ldvt, &iwork[idxqc], &iwork[iwk], &work[1], info);
if (*info != 0) {
return 0;
}
}
}
return 0;
}
#ifdef __cplusplus
}
#endif

96
lib/linalg/dlasd1.cpp Normal file
View File

@ -0,0 +1,96 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static integer c__0 = 0;
static doublereal c_b7 = 1.;
static integer c__1 = 1;
static integer c_n1 = -1;
int dlasd1_(integer *nl, integer *nr, integer *sqre, doublereal *d__, doublereal *alpha,
doublereal *beta, doublereal *u, integer *ldu, doublereal *vt, integer *ldvt,
integer *idxq, integer *iwork, doublereal *work, integer *info)
{
integer u_dim1, u_offset, vt_dim1, vt_offset, i__1;
doublereal d__1, d__2;
integer i__, k, m, n, n1, n2, iq, iz, iu2, ldq, idx, ldu2, ivt2, idxc, idxp, ldvt2;
extern int dlasd2_(integer *, integer *, integer *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *),
dlasd3_(integer *, integer *, integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *, integer *, doublereal *, integer *),
dlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, integer *,
doublereal *, integer *, integer *, ftnlen),
dlamrg_(integer *, integer *, doublereal *, integer *, integer *, integer *);
integer isigma;
extern int xerbla_(char *, integer *, ftnlen);
doublereal orgnrm;
integer coltyp;
--d__;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1;
vt -= vt_offset;
--idxq;
--iwork;
--work;
*info = 0;
if (*nl < 1) {
*info = -1;
} else if (*nr < 1) {
*info = -2;
} else if (*sqre < 0 || *sqre > 1) {
*info = -3;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"DLASD1", &i__1, (ftnlen)6);
return 0;
}
n = *nl + *nr + 1;
m = n + *sqre;
ldu2 = n;
ldvt2 = m;
iz = 1;
isigma = iz + m;
iu2 = isigma + n;
ivt2 = iu2 + ldu2 * n;
iq = ivt2 + ldvt2 * m;
idx = 1;
idxc = idx + n;
coltyp = idxc + n;
idxp = coltyp + n;
d__1 = abs(*alpha), d__2 = abs(*beta);
orgnrm = max(d__1, d__2);
d__[*nl + 1] = 0.;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = d__[i__], abs(d__1)) > orgnrm) {
orgnrm = (d__1 = d__[i__], abs(d__1));
}
}
dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b7, &n, &c__1, &d__[1], &n, info, (ftnlen)1);
*alpha /= orgnrm;
*beta /= orgnrm;
dlasd2_(nl, nr, sqre, &k, &d__[1], &work[iz], alpha, beta, &u[u_offset], ldu, &vt[vt_offset],
ldvt, &work[isigma], &work[iu2], &ldu2, &work[ivt2], &ldvt2, &iwork[idxp], &iwork[idx],
&iwork[idxc], &idxq[1], &iwork[coltyp], info);
ldq = k;
dlasd3_(nl, nr, sqre, &k, &d__[1], &work[iq], &ldq, &work[isigma], &u[u_offset], ldu,
&work[iu2], &ldu2, &vt[vt_offset], ldvt, &work[ivt2], &ldvt2, &iwork[idxc],
&iwork[coltyp], &work[iz], info);
if (*info != 0) {
return 0;
}
dlascl_((char *)"G", &c__0, &c__0, &c_b7, &orgnrm, &n, &c__1, &d__[1], &n, info, (ftnlen)1);
n1 = k;
n2 = n - k;
dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &idxq[1]);
return 0;
}
#ifdef __cplusplus
}
#endif

282
lib/linalg/dlasd2.cpp Normal file
View File

@ -0,0 +1,282 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static integer c__1 = 1;
static doublereal c_b30 = 0.;
int dlasd2_(integer *nl, integer *nr, integer *sqre, integer *k, doublereal *d__, doublereal *z__,
doublereal *alpha, doublereal *beta, doublereal *u, integer *ldu, doublereal *vt,
integer *ldvt, doublereal *dsigma, doublereal *u2, integer *ldu2, doublereal *vt2,
integer *ldvt2, integer *idxp, integer *idx, integer *idxc, integer *idxq,
integer *coltyp, integer *info)
{
integer u_dim1, u_offset, u2_dim1, u2_offset, vt_dim1, vt_offset, vt2_dim1, vt2_offset, i__1;
doublereal d__1, d__2;
doublereal c__;
integer i__, j, m, n;
doublereal s;
integer k2;
doublereal z1;
integer ct, jp;
doublereal eps, tau, tol;
integer psm[4], nlp1, nlp2, idxi, idxj;
extern int drot_(integer *, doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *);
integer ctot[4], idxjp;
extern int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *);
integer jprev;
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, ftnlen);
extern int dlamrg_(integer *, integer *, doublereal *, integer *, integer *, integer *),
dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *,
ftnlen),
dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *,
ftnlen),
xerbla_(char *, integer *, ftnlen);
doublereal hlftol;
--d__;
--z__;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1;
vt -= vt_offset;
--dsigma;
u2_dim1 = *ldu2;
u2_offset = 1 + u2_dim1;
u2 -= u2_offset;
vt2_dim1 = *ldvt2;
vt2_offset = 1 + vt2_dim1;
vt2 -= vt2_offset;
--idxp;
--idx;
--idxc;
--idxq;
--coltyp;
*info = 0;
if (*nl < 1) {
*info = -1;
} else if (*nr < 1) {
*info = -2;
} else if (*sqre != 1 && *sqre != 0) {
*info = -3;
}
n = *nl + *nr + 1;
m = n + *sqre;
if (*ldu < n) {
*info = -10;
} else if (*ldvt < m) {
*info = -12;
} else if (*ldu2 < n) {
*info = -15;
} else if (*ldvt2 < m) {
*info = -17;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"DLASD2", &i__1, (ftnlen)6);
return 0;
}
nlp1 = *nl + 1;
nlp2 = *nl + 2;
z1 = *alpha * vt[nlp1 + nlp1 * vt_dim1];
z__[1] = z1;
for (i__ = *nl; i__ >= 1; --i__) {
z__[i__ + 1] = *alpha * vt[i__ + nlp1 * vt_dim1];
d__[i__ + 1] = d__[i__];
idxq[i__ + 1] = idxq[i__] + 1;
}
i__1 = m;
for (i__ = nlp2; i__ <= i__1; ++i__) {
z__[i__] = *beta * vt[i__ + nlp2 * vt_dim1];
}
i__1 = nlp1;
for (i__ = 2; i__ <= i__1; ++i__) {
coltyp[i__] = 1;
}
i__1 = n;
for (i__ = nlp2; i__ <= i__1; ++i__) {
coltyp[i__] = 2;
}
i__1 = n;
for (i__ = nlp2; i__ <= i__1; ++i__) {
idxq[i__] += nlp1;
}
i__1 = n;
for (i__ = 2; i__ <= i__1; ++i__) {
dsigma[i__] = d__[idxq[i__]];
u2[i__ + u2_dim1] = z__[idxq[i__]];
idxc[i__] = coltyp[idxq[i__]];
}
dlamrg_(nl, nr, &dsigma[2], &c__1, &c__1, &idx[2]);
i__1 = n;
for (i__ = 2; i__ <= i__1; ++i__) {
idxi = idx[i__] + 1;
d__[i__] = dsigma[idxi];
z__[i__] = u2[idxi + u2_dim1];
coltyp[i__] = idxc[idxi];
}
eps = dlamch_((char *)"Epsilon", (ftnlen)7);
d__1 = abs(*alpha), d__2 = abs(*beta);
tol = max(d__1, d__2);
d__2 = (d__1 = d__[n], abs(d__1));
tol = eps * 8. * max(d__2, tol);
*k = 1;
k2 = n + 1;
i__1 = n;
for (j = 2; j <= i__1; ++j) {
if ((d__1 = z__[j], abs(d__1)) <= tol) {
--k2;
idxp[k2] = j;
coltyp[j] = 4;
if (j == n) {
goto L120;
}
} else {
jprev = j;
goto L90;
}
}
L90:
j = jprev;
L100:
++j;
if (j > n) {
goto L110;
}
if ((d__1 = z__[j], abs(d__1)) <= tol) {
--k2;
idxp[k2] = j;
coltyp[j] = 4;
} else {
if ((d__1 = d__[j] - d__[jprev], abs(d__1)) <= tol) {
s = z__[jprev];
c__ = z__[j];
tau = dlapy2_(&c__, &s);
c__ /= tau;
s = -s / tau;
z__[j] = tau;
z__[jprev] = 0.;
idxjp = idxq[idx[jprev] + 1];
idxj = idxq[idx[j] + 1];
if (idxjp <= nlp1) {
--idxjp;
}
if (idxj <= nlp1) {
--idxj;
}
drot_(&n, &u[idxjp * u_dim1 + 1], &c__1, &u[idxj * u_dim1 + 1], &c__1, &c__, &s);
drot_(&m, &vt[idxjp + vt_dim1], ldvt, &vt[idxj + vt_dim1], ldvt, &c__, &s);
if (coltyp[j] != coltyp[jprev]) {
coltyp[j] = 3;
}
coltyp[jprev] = 4;
--k2;
idxp[k2] = jprev;
jprev = j;
} else {
++(*k);
u2[*k + u2_dim1] = z__[jprev];
dsigma[*k] = d__[jprev];
idxp[*k] = jprev;
jprev = j;
}
}
goto L100;
L110:
++(*k);
u2[*k + u2_dim1] = z__[jprev];
dsigma[*k] = d__[jprev];
idxp[*k] = jprev;
L120:
for (j = 1; j <= 4; ++j) {
ctot[j - 1] = 0;
}
i__1 = n;
for (j = 2; j <= i__1; ++j) {
ct = coltyp[j];
++ctot[ct - 1];
}
psm[0] = 2;
psm[1] = ctot[0] + 2;
psm[2] = psm[1] + ctot[1];
psm[3] = psm[2] + ctot[2];
i__1 = n;
for (j = 2; j <= i__1; ++j) {
jp = idxp[j];
ct = coltyp[jp];
idxc[psm[ct - 1]] = j;
++psm[ct - 1];
}
i__1 = n;
for (j = 2; j <= i__1; ++j) {
jp = idxp[j];
dsigma[j] = d__[jp];
idxj = idxq[idx[idxp[idxc[j]]] + 1];
if (idxj <= nlp1) {
--idxj;
}
dcopy_(&n, &u[idxj * u_dim1 + 1], &c__1, &u2[j * u2_dim1 + 1], &c__1);
dcopy_(&m, &vt[idxj + vt_dim1], ldvt, &vt2[j + vt2_dim1], ldvt2);
}
dsigma[1] = 0.;
hlftol = tol / 2.;
if (abs(dsigma[2]) <= hlftol) {
dsigma[2] = hlftol;
}
if (m > n) {
z__[1] = dlapy2_(&z1, &z__[m]);
if (z__[1] <= tol) {
c__ = 1.;
s = 0.;
z__[1] = tol;
} else {
c__ = z1 / z__[1];
s = z__[m] / z__[1];
}
} else {
if (abs(z1) <= tol) {
z__[1] = tol;
} else {
z__[1] = z1;
}
}
i__1 = *k - 1;
dcopy_(&i__1, &u2[u2_dim1 + 2], &c__1, &z__[2], &c__1);
dlaset_((char *)"A", &n, &c__1, &c_b30, &c_b30, &u2[u2_offset], ldu2, (ftnlen)1);
u2[nlp1 + u2_dim1] = 1.;
if (m > n) {
i__1 = nlp1;
for (i__ = 1; i__ <= i__1; ++i__) {
vt[m + i__ * vt_dim1] = -s * vt[nlp1 + i__ * vt_dim1];
vt2[i__ * vt2_dim1 + 1] = c__ * vt[nlp1 + i__ * vt_dim1];
}
i__1 = m;
for (i__ = nlp2; i__ <= i__1; ++i__) {
vt2[i__ * vt2_dim1 + 1] = s * vt[m + i__ * vt_dim1];
vt[m + i__ * vt_dim1] = c__ * vt[m + i__ * vt_dim1];
}
} else {
dcopy_(&m, &vt[nlp1 + vt_dim1], ldvt, &vt2[vt2_dim1 + 1], ldvt2);
}
if (m > n) {
dcopy_(&m, &vt[m + vt_dim1], ldvt, &vt2[m + vt2_dim1], ldvt2);
}
if (n > *k) {
i__1 = n - *k;
dcopy_(&i__1, &dsigma[*k + 1], &c__1, &d__[*k + 1], &c__1);
i__1 = n - *k;
dlacpy_((char *)"A", &n, &i__1, &u2[(*k + 1) * u2_dim1 + 1], ldu2, &u[(*k + 1) * u_dim1 + 1], ldu,
(ftnlen)1);
i__1 = n - *k;
dlacpy_((char *)"A", &i__1, &m, &vt2[*k + 1 + vt2_dim1], ldvt2, &vt[*k + 1 + vt_dim1], ldvt,
(ftnlen)1);
}
for (j = 1; j <= 4; ++j) {
coltyp[j] = ctot[j - 1];
}
return 0;
}
#ifdef __cplusplus
}
#endif

218
lib/linalg/dlasd3.cpp Normal file
View File

@ -0,0 +1,218 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static integer c__1 = 1;
static integer c__0 = 0;
static doublereal c_b13 = 1.;
static doublereal c_b26 = 0.;
int dlasd3_(integer *nl, integer *nr, integer *sqre, integer *k, doublereal *d__, doublereal *q,
integer *ldq, doublereal *dsigma, doublereal *u, integer *ldu, doublereal *u2,
integer *ldu2, doublereal *vt, integer *ldvt, doublereal *vt2, integer *ldvt2,
integer *idxc, integer *ctot, doublereal *z__, integer *info)
{
integer q_dim1, q_offset, u_dim1, u_offset, u2_dim1, u2_offset, vt_dim1, vt_offset, vt2_dim1,
vt2_offset, i__1, i__2;
doublereal d__1, d__2;
double sqrt(doublereal), d_lmp_sign(doublereal *, doublereal *);
integer i__, j, m, n, jc;
doublereal rho;
integer nlp1, nlp2, nrp1;
doublereal temp;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
extern int dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *, integer *,
ftnlen, ftnlen);
integer ctemp;
extern int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *);
integer ktemp;
extern doublereal dlamc3_(doublereal *, doublereal *);
extern int dlasd4_(integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *),
dlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, integer *,
doublereal *, integer *, integer *, ftnlen),
dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *,
ftnlen),
xerbla_(char *, integer *, ftnlen);
--d__;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--dsigma;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
u2_dim1 = *ldu2;
u2_offset = 1 + u2_dim1;
u2 -= u2_offset;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1;
vt -= vt_offset;
vt2_dim1 = *ldvt2;
vt2_offset = 1 + vt2_dim1;
vt2 -= vt2_offset;
--idxc;
--ctot;
--z__;
*info = 0;
if (*nl < 1) {
*info = -1;
} else if (*nr < 1) {
*info = -2;
} else if (*sqre != 1 && *sqre != 0) {
*info = -3;
}
n = *nl + *nr + 1;
m = n + *sqre;
nlp1 = *nl + 1;
nlp2 = *nl + 2;
if (*k < 1 || *k > n) {
*info = -4;
} else if (*ldq < *k) {
*info = -7;
} else if (*ldu < n) {
*info = -10;
} else if (*ldu2 < n) {
*info = -12;
} else if (*ldvt < m) {
*info = -14;
} else if (*ldvt2 < m) {
*info = -16;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"DLASD3", &i__1, (ftnlen)6);
return 0;
}
if (*k == 1) {
d__[1] = abs(z__[1]);
dcopy_(&m, &vt2[vt2_dim1 + 1], ldvt2, &vt[vt_dim1 + 1], ldvt);
if (z__[1] > 0.) {
dcopy_(&n, &u2[u2_dim1 + 1], &c__1, &u[u_dim1 + 1], &c__1);
} else {
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
u[i__ + u_dim1] = -u2[i__ + u2_dim1];
}
}
return 0;
}
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
dsigma[i__] = dlamc3_(&dsigma[i__], &dsigma[i__]) - dsigma[i__];
}
dcopy_(k, &z__[1], &c__1, &q[q_offset], &c__1);
rho = dnrm2_(k, &z__[1], &c__1);
dlascl_((char *)"G", &c__0, &c__0, &rho, &c_b13, k, &c__1, &z__[1], k, info, (ftnlen)1);
rho *= rho;
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
dlasd4_(k, &j, &dsigma[1], &z__[1], &u[j * u_dim1 + 1], &rho, &d__[j], &vt[j * vt_dim1 + 1],
info);
if (*info != 0) {
return 0;
}
}
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
z__[i__] = u[i__ + *k * u_dim1] * vt[i__ + *k * vt_dim1];
i__2 = i__ - 1;
for (j = 1; j <= i__2; ++j) {
z__[i__] *= u[i__ + j * u_dim1] * vt[i__ + j * vt_dim1] / (dsigma[i__] - dsigma[j]) /
(dsigma[i__] + dsigma[j]);
}
i__2 = *k - 1;
for (j = i__; j <= i__2; ++j) {
z__[i__] *= u[i__ + j * u_dim1] * vt[i__ + j * vt_dim1] /
(dsigma[i__] - dsigma[j + 1]) / (dsigma[i__] + dsigma[j + 1]);
}
d__2 = sqrt((d__1 = z__[i__], abs(d__1)));
z__[i__] = d_lmp_sign(&d__2, &q[i__ + q_dim1]);
}
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
vt[i__ * vt_dim1 + 1] = z__[1] / u[i__ * u_dim1 + 1] / vt[i__ * vt_dim1 + 1];
u[i__ * u_dim1 + 1] = -1.;
i__2 = *k;
for (j = 2; j <= i__2; ++j) {
vt[j + i__ * vt_dim1] = z__[j] / u[j + i__ * u_dim1] / vt[j + i__ * vt_dim1];
u[j + i__ * u_dim1] = dsigma[j] * vt[j + i__ * vt_dim1];
}
temp = dnrm2_(k, &u[i__ * u_dim1 + 1], &c__1);
q[i__ * q_dim1 + 1] = u[i__ * u_dim1 + 1] / temp;
i__2 = *k;
for (j = 2; j <= i__2; ++j) {
jc = idxc[j];
q[j + i__ * q_dim1] = u[jc + i__ * u_dim1] / temp;
}
}
if (*k == 2) {
dgemm_((char *)"N", (char *)"N", &n, k, k, &c_b13, &u2[u2_offset], ldu2, &q[q_offset], ldq, &c_b26,
&u[u_offset], ldu, (ftnlen)1, (ftnlen)1);
goto L100;
}
if (ctot[1] > 0) {
dgemm_((char *)"N", (char *)"N", nl, k, &ctot[1], &c_b13, &u2[(u2_dim1 << 1) + 1], ldu2, &q[q_dim1 + 2],
ldq, &c_b26, &u[u_dim1 + 1], ldu, (ftnlen)1, (ftnlen)1);
if (ctot[3] > 0) {
ktemp = ctot[1] + 2 + ctot[2];
dgemm_((char *)"N", (char *)"N", nl, k, &ctot[3], &c_b13, &u2[ktemp * u2_dim1 + 1], ldu2,
&q[ktemp + q_dim1], ldq, &c_b13, &u[u_dim1 + 1], ldu, (ftnlen)1, (ftnlen)1);
}
} else if (ctot[3] > 0) {
ktemp = ctot[1] + 2 + ctot[2];
dgemm_((char *)"N", (char *)"N", nl, k, &ctot[3], &c_b13, &u2[ktemp * u2_dim1 + 1], ldu2,
&q[ktemp + q_dim1], ldq, &c_b26, &u[u_dim1 + 1], ldu, (ftnlen)1, (ftnlen)1);
} else {
dlacpy_((char *)"F", nl, k, &u2[u2_offset], ldu2, &u[u_offset], ldu, (ftnlen)1);
}
dcopy_(k, &q[q_dim1 + 1], ldq, &u[nlp1 + u_dim1], ldu);
ktemp = ctot[1] + 2;
ctemp = ctot[2] + ctot[3];
dgemm_((char *)"N", (char *)"N", nr, k, &ctemp, &c_b13, &u2[nlp2 + ktemp * u2_dim1], ldu2, &q[ktemp + q_dim1],
ldq, &c_b26, &u[nlp2 + u_dim1], ldu, (ftnlen)1, (ftnlen)1);
L100:
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = dnrm2_(k, &vt[i__ * vt_dim1 + 1], &c__1);
q[i__ + q_dim1] = vt[i__ * vt_dim1 + 1] / temp;
i__2 = *k;
for (j = 2; j <= i__2; ++j) {
jc = idxc[j];
q[i__ + j * q_dim1] = vt[jc + i__ * vt_dim1] / temp;
}
}
if (*k == 2) {
dgemm_((char *)"N", (char *)"N", k, &m, k, &c_b13, &q[q_offset], ldq, &vt2[vt2_offset], ldvt2, &c_b26,
&vt[vt_offset], ldvt, (ftnlen)1, (ftnlen)1);
return 0;
}
ktemp = ctot[1] + 1;
dgemm_((char *)"N", (char *)"N", k, &nlp1, &ktemp, &c_b13, &q[q_dim1 + 1], ldq, &vt2[vt2_dim1 + 1], ldvt2,
&c_b26, &vt[vt_dim1 + 1], ldvt, (ftnlen)1, (ftnlen)1);
ktemp = ctot[1] + 2 + ctot[2];
if (ktemp <= *ldvt2) {
dgemm_((char *)"N", (char *)"N", k, &nlp1, &ctot[3], &c_b13, &q[ktemp * q_dim1 + 1], ldq,
&vt2[ktemp + vt2_dim1], ldvt2, &c_b13, &vt[vt_dim1 + 1], ldvt, (ftnlen)1, (ftnlen)1);
}
ktemp = ctot[1] + 1;
nrp1 = *nr + *sqre;
if (ktemp > 1) {
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
q[i__ + ktemp * q_dim1] = q[i__ + q_dim1];
}
i__1 = m;
for (i__ = nlp2; i__ <= i__1; ++i__) {
vt2[ktemp + i__ * vt2_dim1] = vt2[i__ * vt2_dim1 + 1];
}
}
ctemp = ctot[2] + 1 + ctot[3];
dgemm_((char *)"N", (char *)"N", k, &nrp1, &ctemp, &c_b13, &q[ktemp * q_dim1 + 1], ldq,
&vt2[ktemp + nlp2 * vt2_dim1], ldvt2, &c_b26, &vt[nlp2 * vt_dim1 + 1], ldvt, (ftnlen)1,
(ftnlen)1);
return 0;
}
#ifdef __cplusplus
}
#endif

284
lib/linalg/dlasy2.cpp Normal file
View File

@ -0,0 +1,284 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static integer c__4 = 4;
static integer c__1 = 1;
static integer c__16 = 16;
static integer c__0 = 0;
int dlasy2_(logical *ltranl, logical *ltranr, integer *isgn, integer *n1, integer *n2,
doublereal *tl, integer *ldtl, doublereal *tr, integer *ldtr, doublereal *b,
integer *ldb, doublereal *scale, doublereal *x, integer *ldx, doublereal *xnorm,
integer *info)
{
static integer locu12[4] = {3, 4, 1, 2};
static integer locl21[4] = {2, 1, 4, 3};
static integer locu22[4] = {4, 3, 2, 1};
static logical xswpiv[4] = {FALSE_, FALSE_, TRUE_, TRUE_};
static logical bswpiv[4] = {FALSE_, TRUE_, FALSE_, TRUE_};
integer b_dim1, b_offset, tl_dim1, tl_offset, tr_dim1, tr_offset, x_dim1, x_offset;
doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8;
integer i__, j, k;
doublereal x2[2], l21, u11, u12;
integer ip, jp;
doublereal u22, t16[16], gam, bet, eps, sgn, tmp[4], tau1, btmp[4], smin;
integer ipiv;
doublereal temp;
integer jpiv[4];
doublereal xmax;
integer ipsv, jpsv;
logical bswap;
extern int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *),
dswap_(integer *, doublereal *, integer *, doublereal *, integer *);
logical xswap;
extern doublereal dlamch_(char *, ftnlen);
extern integer idamax_(integer *, doublereal *, integer *);
doublereal smlnum;
tl_dim1 = *ldtl;
tl_offset = 1 + tl_dim1;
tl -= tl_offset;
tr_dim1 = *ldtr;
tr_offset = 1 + tr_dim1;
tr -= tr_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
*info = 0;
if (*n1 == 0 || *n2 == 0) {
return 0;
}
eps = dlamch_((char *)"P", (ftnlen)1);
smlnum = dlamch_((char *)"S", (ftnlen)1) / eps;
sgn = (doublereal)(*isgn);
k = *n1 + *n1 + *n2 - 2;
switch (k) {
case 1:
goto L10;
case 2:
goto L20;
case 3:
goto L30;
case 4:
goto L50;
}
L10:
tau1 = tl[tl_dim1 + 1] + sgn * tr[tr_dim1 + 1];
bet = abs(tau1);
if (bet <= smlnum) {
tau1 = smlnum;
bet = smlnum;
*info = 1;
}
*scale = 1.;
gam = (d__1 = b[b_dim1 + 1], abs(d__1));
if (smlnum * gam > bet) {
*scale = 1. / gam;
}
x[x_dim1 + 1] = b[b_dim1 + 1] * *scale / tau1;
*xnorm = (d__1 = x[x_dim1 + 1], abs(d__1));
return 0;
L20:
d__7 = (d__1 = tl[tl_dim1 + 1], abs(d__1)), d__8 = (d__2 = tr[tr_dim1 + 1], abs(d__2)),
d__7 = max(d__7, d__8), d__8 = (d__3 = tr[(tr_dim1 << 1) + 1], abs(d__3)),
d__7 = max(d__7, d__8), d__8 = (d__4 = tr[tr_dim1 + 2], abs(d__4)), d__7 = max(d__7, d__8),
d__8 = (d__5 = tr[(tr_dim1 << 1) + 2], abs(d__5));
d__6 = eps * max(d__7, d__8);
smin = max(d__6, smlnum);
tmp[0] = tl[tl_dim1 + 1] + sgn * tr[tr_dim1 + 1];
tmp[3] = tl[tl_dim1 + 1] + sgn * tr[(tr_dim1 << 1) + 2];
if (*ltranr) {
tmp[1] = sgn * tr[tr_dim1 + 2];
tmp[2] = sgn * tr[(tr_dim1 << 1) + 1];
} else {
tmp[1] = sgn * tr[(tr_dim1 << 1) + 1];
tmp[2] = sgn * tr[tr_dim1 + 2];
}
btmp[0] = b[b_dim1 + 1];
btmp[1] = b[(b_dim1 << 1) + 1];
goto L40;
L30:
d__7 = (d__1 = tr[tr_dim1 + 1], abs(d__1)), d__8 = (d__2 = tl[tl_dim1 + 1], abs(d__2)),
d__7 = max(d__7, d__8), d__8 = (d__3 = tl[(tl_dim1 << 1) + 1], abs(d__3)),
d__7 = max(d__7, d__8), d__8 = (d__4 = tl[tl_dim1 + 2], abs(d__4)), d__7 = max(d__7, d__8),
d__8 = (d__5 = tl[(tl_dim1 << 1) + 2], abs(d__5));
d__6 = eps * max(d__7, d__8);
smin = max(d__6, smlnum);
tmp[0] = tl[tl_dim1 + 1] + sgn * tr[tr_dim1 + 1];
tmp[3] = tl[(tl_dim1 << 1) + 2] + sgn * tr[tr_dim1 + 1];
if (*ltranl) {
tmp[1] = tl[(tl_dim1 << 1) + 1];
tmp[2] = tl[tl_dim1 + 2];
} else {
tmp[1] = tl[tl_dim1 + 2];
tmp[2] = tl[(tl_dim1 << 1) + 1];
}
btmp[0] = b[b_dim1 + 1];
btmp[1] = b[b_dim1 + 2];
L40:
ipiv = idamax_(&c__4, tmp, &c__1);
u11 = tmp[ipiv - 1];
if (abs(u11) <= smin) {
*info = 1;
u11 = smin;
}
u12 = tmp[locu12[ipiv - 1] - 1];
l21 = tmp[locl21[ipiv - 1] - 1] / u11;
u22 = tmp[locu22[ipiv - 1] - 1] - u12 * l21;
xswap = xswpiv[ipiv - 1];
bswap = bswpiv[ipiv - 1];
if (abs(u22) <= smin) {
*info = 1;
u22 = smin;
}
if (bswap) {
temp = btmp[1];
btmp[1] = btmp[0] - l21 * temp;
btmp[0] = temp;
} else {
btmp[1] -= l21 * btmp[0];
}
*scale = 1.;
if (smlnum * 2. * abs(btmp[1]) > abs(u22) || smlnum * 2. * abs(btmp[0]) > abs(u11)) {
d__1 = abs(btmp[0]), d__2 = abs(btmp[1]);
*scale = .5 / max(d__1, d__2);
btmp[0] *= *scale;
btmp[1] *= *scale;
}
x2[1] = btmp[1] / u22;
x2[0] = btmp[0] / u11 - u12 / u11 * x2[1];
if (xswap) {
temp = x2[1];
x2[1] = x2[0];
x2[0] = temp;
}
x[x_dim1 + 1] = x2[0];
if (*n1 == 1) {
x[(x_dim1 << 1) + 1] = x2[1];
*xnorm = (d__1 = x[x_dim1 + 1], abs(d__1)) + (d__2 = x[(x_dim1 << 1) + 1], abs(d__2));
} else {
x[x_dim1 + 2] = x2[1];
d__3 = (d__1 = x[x_dim1 + 1], abs(d__1)), d__4 = (d__2 = x[x_dim1 + 2], abs(d__2));
*xnorm = max(d__3, d__4);
}
return 0;
L50:
d__5 = (d__1 = tr[tr_dim1 + 1], abs(d__1)), d__6 = (d__2 = tr[(tr_dim1 << 1) + 1], abs(d__2)),
d__5 = max(d__5, d__6), d__6 = (d__3 = tr[tr_dim1 + 2], abs(d__3)), d__5 = max(d__5, d__6),
d__6 = (d__4 = tr[(tr_dim1 << 1) + 2], abs(d__4));
smin = max(d__5, d__6);
d__5 = smin, d__6 = (d__1 = tl[tl_dim1 + 1], abs(d__1)), d__5 = max(d__5, d__6),
d__6 = (d__2 = tl[(tl_dim1 << 1) + 1], abs(d__2)), d__5 = max(d__5, d__6),
d__6 = (d__3 = tl[tl_dim1 + 2], abs(d__3)), d__5 = max(d__5, d__6),
d__6 = (d__4 = tl[(tl_dim1 << 1) + 2], abs(d__4));
smin = max(d__5, d__6);
d__1 = eps * smin;
smin = max(d__1, smlnum);
btmp[0] = 0.;
dcopy_(&c__16, btmp, &c__0, t16, &c__1);
t16[0] = tl[tl_dim1 + 1] + sgn * tr[tr_dim1 + 1];
t16[5] = tl[(tl_dim1 << 1) + 2] + sgn * tr[tr_dim1 + 1];
t16[10] = tl[tl_dim1 + 1] + sgn * tr[(tr_dim1 << 1) + 2];
t16[15] = tl[(tl_dim1 << 1) + 2] + sgn * tr[(tr_dim1 << 1) + 2];
if (*ltranl) {
t16[4] = tl[tl_dim1 + 2];
t16[1] = tl[(tl_dim1 << 1) + 1];
t16[14] = tl[tl_dim1 + 2];
t16[11] = tl[(tl_dim1 << 1) + 1];
} else {
t16[4] = tl[(tl_dim1 << 1) + 1];
t16[1] = tl[tl_dim1 + 2];
t16[14] = tl[(tl_dim1 << 1) + 1];
t16[11] = tl[tl_dim1 + 2];
}
if (*ltranr) {
t16[8] = sgn * tr[(tr_dim1 << 1) + 1];
t16[13] = sgn * tr[(tr_dim1 << 1) + 1];
t16[2] = sgn * tr[tr_dim1 + 2];
t16[7] = sgn * tr[tr_dim1 + 2];
} else {
t16[8] = sgn * tr[tr_dim1 + 2];
t16[13] = sgn * tr[tr_dim1 + 2];
t16[2] = sgn * tr[(tr_dim1 << 1) + 1];
t16[7] = sgn * tr[(tr_dim1 << 1) + 1];
}
btmp[0] = b[b_dim1 + 1];
btmp[1] = b[b_dim1 + 2];
btmp[2] = b[(b_dim1 << 1) + 1];
btmp[3] = b[(b_dim1 << 1) + 2];
for (i__ = 1; i__ <= 3; ++i__) {
xmax = 0.;
for (ip = i__; ip <= 4; ++ip) {
for (jp = i__; jp <= 4; ++jp) {
if ((d__1 = t16[ip + (jp << 2) - 5], abs(d__1)) >= xmax) {
xmax = (d__1 = t16[ip + (jp << 2) - 5], abs(d__1));
ipsv = ip;
jpsv = jp;
}
}
}
if (ipsv != i__) {
dswap_(&c__4, &t16[ipsv - 1], &c__4, &t16[i__ - 1], &c__4);
temp = btmp[i__ - 1];
btmp[i__ - 1] = btmp[ipsv - 1];
btmp[ipsv - 1] = temp;
}
if (jpsv != i__) {
dswap_(&c__4, &t16[(jpsv << 2) - 4], &c__1, &t16[(i__ << 2) - 4], &c__1);
}
jpiv[i__ - 1] = jpsv;
if ((d__1 = t16[i__ + (i__ << 2) - 5], abs(d__1)) < smin) {
*info = 1;
t16[i__ + (i__ << 2) - 5] = smin;
}
for (j = i__ + 1; j <= 4; ++j) {
t16[j + (i__ << 2) - 5] /= t16[i__ + (i__ << 2) - 5];
btmp[j - 1] -= t16[j + (i__ << 2) - 5] * btmp[i__ - 1];
for (k = i__ + 1; k <= 4; ++k) {
t16[j + (k << 2) - 5] -= t16[j + (i__ << 2) - 5] * t16[i__ + (k << 2) - 5];
}
}
}
if (abs(t16[15]) < smin) {
*info = 1;
t16[15] = smin;
}
*scale = 1.;
if (smlnum * 8. * abs(btmp[0]) > abs(t16[0]) || smlnum * 8. * abs(btmp[1]) > abs(t16[5]) ||
smlnum * 8. * abs(btmp[2]) > abs(t16[10]) || smlnum * 8. * abs(btmp[3]) > abs(t16[15])) {
d__1 = abs(btmp[0]), d__2 = abs(btmp[1]), d__1 = max(d__1, d__2), d__2 = abs(btmp[2]),
d__1 = max(d__1, d__2), d__2 = abs(btmp[3]);
*scale = .125 / max(d__1, d__2);
btmp[0] *= *scale;
btmp[1] *= *scale;
btmp[2] *= *scale;
btmp[3] *= *scale;
}
for (i__ = 1; i__ <= 4; ++i__) {
k = 5 - i__;
temp = 1. / t16[k + (k << 2) - 5];
tmp[k - 1] = btmp[k - 1] * temp;
for (j = k + 1; j <= 4; ++j) {
tmp[k - 1] -= temp * t16[k + (j << 2) - 5] * tmp[j - 1];
}
}
for (i__ = 1; i__ <= 3; ++i__) {
if (jpiv[4 - i__ - 1] != 4 - i__) {
temp = tmp[4 - i__ - 1];
tmp[4 - i__ - 1] = tmp[jpiv[4 - i__ - 1] - 1];
tmp[jpiv[4 - i__ - 1] - 1] = temp;
}
}
x[x_dim1 + 1] = tmp[0];
x[x_dim1 + 2] = tmp[1];
x[(x_dim1 << 1) + 1] = tmp[2];
x[(x_dim1 << 1) + 2] = tmp[3];
d__1 = abs(tmp[0]) + abs(tmp[2]), d__2 = abs(tmp[1]) + abs(tmp[3]);
*xnorm = max(d__1, d__2);
return 0;
}
#ifdef __cplusplus
}
#endif

337
lib/linalg/dlasyf.cpp Normal file
View File

@ -0,0 +1,337 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static integer c__1 = 1;
static doublereal c_b8 = -1.;
static doublereal c_b9 = 1.;
int dlasyf_(char *uplo, integer *n, integer *nb, integer *kb, doublereal *a, integer *lda,
integer *ipiv, doublereal *w, integer *ldw, integer *info, ftnlen uplo_len)
{
integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3;
double sqrt(doublereal);
integer j, k;
doublereal t, r1, d11, d21, d22;
integer jb, jj, kk, jp, kp, kw, kkw, imax, jmax;
doublereal alpha;
extern int dscal_(integer *, doublereal *, doublereal *, integer *),
dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, ftnlen,
ftnlen);
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern int dgemv_(char *, integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *, ftnlen),
dcopy_(integer *, doublereal *, integer *, doublereal *, integer *),
dswap_(integer *, doublereal *, integer *, doublereal *, integer *);
integer kstep;
doublereal absakk;
extern integer idamax_(integer *, doublereal *, integer *);
doublereal colmax, rowmax;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
w_dim1 = *ldw;
w_offset = 1 + w_dim1;
w -= w_offset;
*info = 0;
alpha = (sqrt(17.) + 1.) / 8.;
if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) {
k = *n;
L10:
kw = *nb + k - *n;
if (k <= *n - *nb + 1 && *nb < *n || k < 1) {
goto L30;
}
dcopy_(&k, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1);
if (k < *n) {
i__1 = *n - k;
dgemv_((char *)"No transpose", &k, &i__1, &c_b8, &a[(k + 1) * a_dim1 + 1], lda,
&w[k + (kw + 1) * w_dim1], ldw, &c_b9, &w[kw * w_dim1 + 1], &c__1, (ftnlen)12);
}
kstep = 1;
absakk = (d__1 = w[k + kw * w_dim1], abs(d__1));
if (k > 1) {
i__1 = k - 1;
imax = idamax_(&i__1, &w[kw * w_dim1 + 1], &c__1);
colmax = (d__1 = w[imax + kw * w_dim1], abs(d__1));
} else {
colmax = 0.;
}
if (max(absakk, colmax) == 0.) {
if (*info == 0) {
*info = k;
}
kp = k;
} else {
if (absakk >= alpha * colmax) {
kp = k;
} else {
dcopy_(&imax, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) * w_dim1 + 1], &c__1);
i__1 = k - imax;
dcopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax + 1 + (kw - 1) * w_dim1],
&c__1);
if (k < *n) {
i__1 = *n - k;
dgemv_((char *)"No transpose", &k, &i__1, &c_b8, &a[(k + 1) * a_dim1 + 1], lda,
&w[imax + (kw + 1) * w_dim1], ldw, &c_b9, &w[(kw - 1) * w_dim1 + 1],
&c__1, (ftnlen)12);
}
i__1 = k - imax;
jmax = imax + idamax_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1], &c__1);
rowmax = (d__1 = w[jmax + (kw - 1) * w_dim1], abs(d__1));
if (imax > 1) {
i__1 = imax - 1;
jmax = idamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1);
d__2 = rowmax, d__3 = (d__1 = w[jmax + (kw - 1) * w_dim1], abs(d__1));
rowmax = max(d__2, d__3);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
kp = k;
} else if ((d__1 = w[imax + (kw - 1) * w_dim1], abs(d__1)) >= alpha * rowmax) {
kp = imax;
dcopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1);
} else {
kp = imax;
kstep = 2;
}
}
kk = k - kstep + 1;
kkw = *nb + kk - *n;
if (kp != kk) {
a[kp + kp * a_dim1] = a[kk + kk * a_dim1];
i__1 = kk - 1 - kp;
dcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + 1) * a_dim1], lda);
if (kp > 1) {
i__1 = kp - 1;
dcopy_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], &c__1);
}
if (k < *n) {
i__1 = *n - k;
dswap_(&i__1, &a[kk + (k + 1) * a_dim1], lda, &a[kp + (k + 1) * a_dim1], lda);
}
i__1 = *n - kk + 1;
dswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw * w_dim1], ldw);
}
if (kstep == 1) {
dcopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1);
r1 = 1. / a[k + k * a_dim1];
i__1 = k - 1;
dscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1);
} else {
if (k > 2) {
d21 = w[k - 1 + kw * w_dim1];
d11 = w[k + kw * w_dim1] / d21;
d22 = w[k - 1 + (kw - 1) * w_dim1] / d21;
t = 1. / (d11 * d22 - 1.);
d21 = t / d21;
i__1 = k - 2;
for (j = 1; j <= i__1; ++j) {
a[j + (k - 1) * a_dim1] =
d21 * (d11 * w[j + (kw - 1) * w_dim1] - w[j + kw * w_dim1]);
a[j + k * a_dim1] =
d21 * (d22 * w[j + kw * w_dim1] - w[j + (kw - 1) * w_dim1]);
}
}
a[k - 1 + (k - 1) * a_dim1] = w[k - 1 + (kw - 1) * w_dim1];
a[k - 1 + k * a_dim1] = w[k - 1 + kw * w_dim1];
a[k + k * a_dim1] = w[k + kw * w_dim1];
}
}
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k - 1] = -kp;
}
k -= kstep;
goto L10;
L30:
i__1 = -(*nb);
for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j += i__1) {
i__2 = *nb, i__3 = k - j + 1;
jb = min(i__2, i__3);
i__2 = j + jb - 1;
for (jj = j; jj <= i__2; ++jj) {
i__3 = jj - j + 1;
i__4 = *n - k;
dgemv_((char *)"No transpose", &i__3, &i__4, &c_b8, &a[j + (k + 1) * a_dim1], lda,
&w[jj + (kw + 1) * w_dim1], ldw, &c_b9, &a[j + jj * a_dim1], &c__1,
(ftnlen)12);
}
i__2 = j - 1;
i__3 = *n - k;
dgemm_((char *)"No transpose", (char *)"Transpose", &i__2, &jb, &i__3, &c_b8, &a[(k + 1) * a_dim1 + 1],
lda, &w[j + (kw + 1) * w_dim1], ldw, &c_b9, &a[j * a_dim1 + 1], lda, (ftnlen)12,
(ftnlen)9);
}
j = k + 1;
L60:
jj = j;
jp = ipiv[j];
if (jp < 0) {
jp = -jp;
++j;
}
++j;
if (jp != jj && j <= *n) {
i__1 = *n - j + 1;
dswap_(&i__1, &a[jp + j * a_dim1], lda, &a[jj + j * a_dim1], lda);
}
if (j < *n) {
goto L60;
}
*kb = *n - k;
} else {
k = 1;
L70:
if (k >= *nb && *nb < *n || k > *n) {
goto L90;
}
i__1 = *n - k + 1;
dcopy_(&i__1, &a[k + k * a_dim1], &c__1, &w[k + k * w_dim1], &c__1);
i__1 = *n - k + 1;
i__2 = k - 1;
dgemv_((char *)"No transpose", &i__1, &i__2, &c_b8, &a[k + a_dim1], lda, &w[k + w_dim1], ldw, &c_b9,
&w[k + k * w_dim1], &c__1, (ftnlen)12);
kstep = 1;
absakk = (d__1 = w[k + k * w_dim1], abs(d__1));
if (k < *n) {
i__1 = *n - k;
imax = k + idamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1);
colmax = (d__1 = w[imax + k * w_dim1], abs(d__1));
} else {
colmax = 0.;
}
if (max(absakk, colmax) == 0.) {
if (*info == 0) {
*info = k;
}
kp = k;
} else {
if (absakk >= alpha * colmax) {
kp = k;
} else {
i__1 = imax - k;
dcopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) * w_dim1], &c__1);
i__1 = *n - imax + 1;
dcopy_(&i__1, &a[imax + imax * a_dim1], &c__1, &w[imax + (k + 1) * w_dim1], &c__1);
i__1 = *n - k + 1;
i__2 = k - 1;
dgemv_((char *)"No transpose", &i__1, &i__2, &c_b8, &a[k + a_dim1], lda, &w[imax + w_dim1],
ldw, &c_b9, &w[k + (k + 1) * w_dim1], &c__1, (ftnlen)12);
i__1 = imax - k;
jmax = k - 1 + idamax_(&i__1, &w[k + (k + 1) * w_dim1], &c__1);
rowmax = (d__1 = w[jmax + (k + 1) * w_dim1], abs(d__1));
if (imax < *n) {
i__1 = *n - imax;
jmax = imax + idamax_(&i__1, &w[imax + 1 + (k + 1) * w_dim1], &c__1);
d__2 = rowmax, d__3 = (d__1 = w[jmax + (k + 1) * w_dim1], abs(d__1));
rowmax = max(d__2, d__3);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
kp = k;
} else if ((d__1 = w[imax + (k + 1) * w_dim1], abs(d__1)) >= alpha * rowmax) {
kp = imax;
i__1 = *n - k + 1;
dcopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * w_dim1], &c__1);
} else {
kp = imax;
kstep = 2;
}
}
kk = k + kstep - 1;
if (kp != kk) {
a[kp + kp * a_dim1] = a[kk + kk * a_dim1];
i__1 = kp - kk - 1;
dcopy_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk + 1) * a_dim1], lda);
if (kp < *n) {
i__1 = *n - kp;
dcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1 + kp * a_dim1], &c__1);
}
if (k > 1) {
i__1 = k - 1;
dswap_(&i__1, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda);
}
dswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw);
}
if (kstep == 1) {
i__1 = *n - k + 1;
dcopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], &c__1);
if (k < *n) {
r1 = 1. / a[k + k * a_dim1];
i__1 = *n - k;
dscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1);
}
} else {
if (k < *n - 1) {
d21 = w[k + 1 + k * w_dim1];
d11 = w[k + 1 + (k + 1) * w_dim1] / d21;
d22 = w[k + k * w_dim1] / d21;
t = 1. / (d11 * d22 - 1.);
d21 = t / d21;
i__1 = *n;
for (j = k + 2; j <= i__1; ++j) {
a[j + k * a_dim1] =
d21 * (d11 * w[j + k * w_dim1] - w[j + (k + 1) * w_dim1]);
a[j + (k + 1) * a_dim1] =
d21 * (d22 * w[j + (k + 1) * w_dim1] - w[j + k * w_dim1]);
}
}
a[k + k * a_dim1] = w[k + k * w_dim1];
a[k + 1 + k * a_dim1] = w[k + 1 + k * w_dim1];
a[k + 1 + (k + 1) * a_dim1] = w[k + 1 + (k + 1) * w_dim1];
}
}
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k + 1] = -kp;
}
k += kstep;
goto L70;
L90:
i__1 = *n;
i__2 = *nb;
for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
i__3 = *nb, i__4 = *n - j + 1;
jb = min(i__3, i__4);
i__3 = j + jb - 1;
for (jj = j; jj <= i__3; ++jj) {
i__4 = j + jb - jj;
i__5 = k - 1;
dgemv_((char *)"No transpose", &i__4, &i__5, &c_b8, &a[jj + a_dim1], lda, &w[jj + w_dim1],
ldw, &c_b9, &a[jj + jj * a_dim1], &c__1, (ftnlen)12);
}
if (j + jb <= *n) {
i__3 = *n - j - jb + 1;
i__4 = k - 1;
dgemm_((char *)"No transpose", (char *)"Transpose", &i__3, &jb, &i__4, &c_b8, &a[j + jb + a_dim1],
lda, &w[j + w_dim1], ldw, &c_b9, &a[j + jb + j * a_dim1], lda, (ftnlen)12,
(ftnlen)9);
}
}
j = k - 1;
L120:
jj = j;
jp = ipiv[j];
if (jp < 0) {
jp = -jp;
--j;
}
--j;
if (jp != jj && j >= 1) {
dswap_(&j, &a[jp + a_dim1], lda, &a[jj + a_dim1], lda);
}
if (j > 1) {
goto L120;
}
*kb = k - 1;
}
return 0;
}
#ifdef __cplusplus
}
#endif

94
lib/linalg/dorghr.cpp Normal file
View File

@ -0,0 +1,94 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static integer c__1 = 1;
static integer c_n1 = -1;
int dorghr_(integer *n, integer *ilo, integer *ihi, doublereal *a, integer *lda, doublereal *tau,
doublereal *work, integer *lwork, integer *info)
{
integer a_dim1, a_offset, i__1, i__2;
integer i__, j, nb, nh, iinfo;
extern int xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
extern int dorgqr_(integer *, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, integer *);
integer lwkopt;
logical lquery;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
*info = 0;
nh = *ihi - *ilo;
lquery = *lwork == -1;
if (*n < 0) {
*info = -1;
} else if (*ilo < 1 || *ilo > max(1, *n)) {
*info = -2;
} else if (*ihi < min(*ilo, *n) || *ihi > *n) {
*info = -3;
} else if (*lda < max(1, *n)) {
*info = -5;
} else if (*lwork < max(1, nh) && !lquery) {
*info = -8;
}
if (*info == 0) {
nb = ilaenv_(&c__1, (char *)"DORGQR", (char *)" ", &nh, &nh, &nh, &c_n1, (ftnlen)6, (ftnlen)1);
lwkopt = max(1, nh) * nb;
work[1] = (doublereal)lwkopt;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"DORGHR", &i__1, (ftnlen)6);
return 0;
} else if (lquery) {
return 0;
}
if (*n == 0) {
work[1] = 1.;
return 0;
}
i__1 = *ilo + 1;
for (j = *ihi; j >= i__1; --j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = 0.;
}
i__2 = *ihi;
for (i__ = j + 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1];
}
i__2 = *n;
for (i__ = *ihi + 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = 0.;
}
}
i__1 = *ilo;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = 0.;
}
a[j + j * a_dim1] = 1.;
}
i__1 = *n;
for (j = *ihi + 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = 0.;
}
a[j + j * a_dim1] = 1.;
}
if (nh > 0) {
dorgqr_(&nh, &nh, &nh, &a[*ilo + 1 + (*ilo + 1) * a_dim1], lda, &tau[*ilo], &work[1], lwork,
&iinfo);
}
work[1] = (doublereal)lwkopt;
return 0;
}
#ifdef __cplusplus
}
#endif

111
lib/linalg/dormhr.cpp Normal file
View File

@ -0,0 +1,111 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static integer c__1 = 1;
static integer c_n1 = -1;
static integer c__2 = 2;
int dormhr_(char *side, char *trans, integer *m, integer *n, integer *ilo, integer *ihi,
doublereal *a, integer *lda, doublereal *tau, doublereal *c__, integer *ldc,
doublereal *work, integer *lwork, integer *info, ftnlen side_len, ftnlen trans_len)
{
address a__1[2];
integer a_dim1, a_offset, c_dim1, c_offset, i__1[2], i__2;
char ch__1[2];
int s_lmp_cat(char *, char **, integer *, integer *, ftnlen);
integer i1, i2, nb, mi, nh, ni, nq, nw;
logical left;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
integer iinfo;
extern int xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
extern int dormqr_(char *, char *, integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *, integer *,
ftnlen, ftnlen);
integer lwkopt;
logical lquery;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
*info = 0;
nh = *ihi - *ilo;
left = lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1);
lquery = *lwork == -1;
if (left) {
nq = *m;
nw = *n;
} else {
nq = *n;
nw = *m;
}
if (!left && !lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (!lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1) &&
!lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) {
*info = -2;
} else if (*m < 0) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*ilo < 1 || *ilo > max(1, nq)) {
*info = -5;
} else if (*ihi < min(*ilo, nq) || *ihi > nq) {
*info = -6;
} else if (*lda < max(1, nq)) {
*info = -8;
} else if (*ldc < max(1, *m)) {
*info = -11;
} else if (*lwork < max(1, nw) && !lquery) {
*info = -13;
}
if (*info == 0) {
if (left) {
i__1[0] = 1, a__1[0] = side;
i__1[1] = 1, a__1[1] = trans;
s_lmp_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
nb = ilaenv_(&c__1, (char *)"DORMQR", ch__1, &nh, n, &nh, &c_n1, (ftnlen)6, (ftnlen)2);
} else {
i__1[0] = 1, a__1[0] = side;
i__1[1] = 1, a__1[1] = trans;
s_lmp_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
nb = ilaenv_(&c__1, (char *)"DORMQR", ch__1, m, &nh, &nh, &c_n1, (ftnlen)6, (ftnlen)2);
}
lwkopt = max(1, nw) * nb;
work[1] = (doublereal)lwkopt;
}
if (*info != 0) {
i__2 = -(*info);
xerbla_((char *)"DORMHR", &i__2, (ftnlen)6);
return 0;
} else if (lquery) {
return 0;
}
if (*m == 0 || *n == 0 || nh == 0) {
work[1] = 1.;
return 0;
}
if (left) {
mi = nh;
ni = *n;
i1 = *ilo + 1;
i2 = 1;
} else {
mi = *m;
ni = nh;
i1 = 1;
i2 = *ilo + 1;
}
dormqr_(side, trans, &mi, &ni, &nh, &a[*ilo + 1 + *ilo * a_dim1], lda, &tau[*ilo],
&c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo, (ftnlen)1, (ftnlen)1);
work[1] = (doublereal)lwkopt;
return 0;
}
#ifdef __cplusplus
}
#endif

199
lib/linalg/dsyconv.cpp Normal file
View File

@ -0,0 +1,199 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
int dsyconv_(char *uplo, char *way, integer *n, doublereal *a, integer *lda, integer *ipiv,
doublereal *e, integer *info, ftnlen uplo_len, ftnlen way_len)
{
integer a_dim1, a_offset, i__1;
integer i__, j, ip;
doublereal temp;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
logical upper;
extern int xerbla_(char *, integer *, ftnlen);
logical convert;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
--e;
*info = 0;
upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1);
convert = lsame_(way, (char *)"C", (ftnlen)1, (ftnlen)1);
if (!upper && !lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (!convert && !lsame_(way, (char *)"R", (ftnlen)1, (ftnlen)1)) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1, *n)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"DSYCONV", &i__1, (ftnlen)7);
return 0;
}
if (*n == 0) {
return 0;
}
if (upper) {
if (convert) {
i__ = *n;
e[1] = 0.;
while (i__ > 1) {
if (ipiv[i__] < 0) {
e[i__] = a[i__ - 1 + i__ * a_dim1];
e[i__ - 1] = 0.;
a[i__ - 1 + i__ * a_dim1] = 0.;
--i__;
} else {
e[i__] = 0.;
}
--i__;
}
i__ = *n;
while (i__ >= 1) {
if (ipiv[i__] > 0) {
ip = ipiv[i__];
if (i__ < *n) {
i__1 = *n;
for (j = i__ + 1; j <= i__1; ++j) {
temp = a[ip + j * a_dim1];
a[ip + j * a_dim1] = a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = temp;
}
}
} else {
ip = -ipiv[i__];
if (i__ < *n) {
i__1 = *n;
for (j = i__ + 1; j <= i__1; ++j) {
temp = a[ip + j * a_dim1];
a[ip + j * a_dim1] = a[i__ - 1 + j * a_dim1];
a[i__ - 1 + j * a_dim1] = temp;
}
}
--i__;
}
--i__;
}
} else {
i__ = 1;
while (i__ <= *n) {
if (ipiv[i__] > 0) {
ip = ipiv[i__];
if (i__ < *n) {
i__1 = *n;
for (j = i__ + 1; j <= i__1; ++j) {
temp = a[ip + j * a_dim1];
a[ip + j * a_dim1] = a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = temp;
}
}
} else {
ip = -ipiv[i__];
++i__;
if (i__ < *n) {
i__1 = *n;
for (j = i__ + 1; j <= i__1; ++j) {
temp = a[ip + j * a_dim1];
a[ip + j * a_dim1] = a[i__ - 1 + j * a_dim1];
a[i__ - 1 + j * a_dim1] = temp;
}
}
}
++i__;
}
i__ = *n;
while (i__ > 1) {
if (ipiv[i__] < 0) {
a[i__ - 1 + i__ * a_dim1] = e[i__];
--i__;
}
--i__;
}
}
} else {
if (convert) {
i__ = 1;
e[*n] = 0.;
while (i__ <= *n) {
if (i__ < *n && ipiv[i__] < 0) {
e[i__] = a[i__ + 1 + i__ * a_dim1];
e[i__ + 1] = 0.;
a[i__ + 1 + i__ * a_dim1] = 0.;
++i__;
} else {
e[i__] = 0.;
}
++i__;
}
i__ = 1;
while (i__ <= *n) {
if (ipiv[i__] > 0) {
ip = ipiv[i__];
if (i__ > 1) {
i__1 = i__ - 1;
for (j = 1; j <= i__1; ++j) {
temp = a[ip + j * a_dim1];
a[ip + j * a_dim1] = a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = temp;
}
}
} else {
ip = -ipiv[i__];
if (i__ > 1) {
i__1 = i__ - 1;
for (j = 1; j <= i__1; ++j) {
temp = a[ip + j * a_dim1];
a[ip + j * a_dim1] = a[i__ + 1 + j * a_dim1];
a[i__ + 1 + j * a_dim1] = temp;
}
}
++i__;
}
++i__;
}
} else {
i__ = *n;
while (i__ >= 1) {
if (ipiv[i__] > 0) {
ip = ipiv[i__];
if (i__ > 1) {
i__1 = i__ - 1;
for (j = 1; j <= i__1; ++j) {
temp = a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = a[ip + j * a_dim1];
a[ip + j * a_dim1] = temp;
}
}
} else {
ip = -ipiv[i__];
--i__;
if (i__ > 1) {
i__1 = i__ - 1;
for (j = 1; j <= i__1; ++j) {
temp = a[i__ + 1 + j * a_dim1];
a[i__ + 1 + j * a_dim1] = a[ip + j * a_dim1];
a[ip + j * a_dim1] = temp;
}
}
}
--i__;
}
i__ = 1;
while (i__ <= *n - 1) {
if (ipiv[i__] < 0) {
a[i__ + 1 + i__ * a_dim1] = e[i__];
++i__;
}
++i__;
}
}
}
return 0;
}
#ifdef __cplusplus
}
#endif

167
lib/linalg/dsyr.cpp Normal file
View File

@ -0,0 +1,167 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static integer c_n1 = -1;
int dsyr_(char *uplo, integer *n, doublereal *alpha, doublereal *x, integer *incx, doublereal *a,
integer *lda, ftnlen uplo_len)
{
integer a_dim1, a_offset, i__1, i__2;
integer i__, j, ix, jx, kx, info;
doublereal temp;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern int xerbla_(char *, integer *, ftnlen);
--x;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
info = 0;
if (!lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1) && !lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) {
info = 1;
} else if (*n < 0) {
info = 2;
} else if (*incx == 0) {
info = 5;
} else if (*lda < max(1, *n)) {
info = 7;
}
if (info != 0) {
xerbla_((char *)"DSYR ", &info, (ftnlen)6);
return 0;
}
if (*n == 0 || *alpha == 0.) {
return 0;
}
if (*incx <= 0) {
kx = 1 - (*n - 1) * *incx;
} else if (*incx != 1) {
kx = 1;
}
if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) {
if (*incx == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (x[j] != 0.) {
temp = *alpha * x[j];
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] += x[i__] * temp;
}
}
}
} else {
jx = kx;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (x[jx] != 0.) {
temp = *alpha * x[jx];
ix = kx;
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] += x[ix] * temp;
ix += *incx;
}
}
jx += *incx;
}
}
} else {
if (*incx == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (x[j] != 0.) {
temp = *alpha * x[j];
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] += x[i__] * temp;
}
}
}
} else {
jx = kx;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (x[jx] != 0.) {
temp = *alpha * x[jx];
ix = jx;
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] += x[ix] * temp;
ix += *incx;
}
}
jx += *incx;
}
}
}
return 0;
}
int dsysv_(char *uplo, integer *n, integer *nrhs, doublereal *a, integer *lda, integer *ipiv,
doublereal *b, integer *ldb, doublereal *work, integer *lwork, integer *info,
ftnlen uplo_len)
{
integer a_dim1, a_offset, b_dim1, b_offset, i__1;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern int xerbla_(char *, integer *, ftnlen),
dsytrf_(char *, integer *, doublereal *, integer *, integer *, doublereal *, integer *,
integer *, ftnlen);
integer lwkopt;
logical lquery;
extern int dsytrs_(char *, integer *, integer *, doublereal *, integer *, integer *,
doublereal *, integer *, integer *, ftnlen),
dsytrs2_(char *, integer *, integer *, doublereal *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, ftnlen);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--work;
*info = 0;
lquery = *lwork == -1;
if (!lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1) && !lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1, *n)) {
*info = -5;
} else if (*ldb < max(1, *n)) {
*info = -8;
} else if (*lwork < 1 && !lquery) {
*info = -10;
}
if (*info == 0) {
if (*n == 0) {
lwkopt = 1;
} else {
dsytrf_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], &c_n1, info, (ftnlen)1);
lwkopt = (integer)work[1];
}
work[1] = (doublereal)lwkopt;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"DSYSV ", &i__1, (ftnlen)6);
return 0;
} else if (lquery) {
return 0;
}
dsytrf_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], lwork, info, (ftnlen)1);
if (*info == 0) {
if (*lwork < *n) {
dsytrs_(uplo, n, nrhs, &a[a_offset], lda, &ipiv[1], &b[b_offset], ldb, info, (ftnlen)1);
} else {
dsytrs2_(uplo, n, nrhs, &a[a_offset], lda, &ipiv[1], &b[b_offset], ldb, &work[1], info,
(ftnlen)1);
}
}
work[1] = (doublereal)lwkopt;
return 0;
}
#ifdef __cplusplus
}
#endif

246
lib/linalg/dsytf2.cpp Normal file
View File

@ -0,0 +1,246 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static integer c__1 = 1;
int dsytf2_(char *uplo, integer *n, doublereal *a, integer *lda, integer *ipiv, integer *info,
ftnlen uplo_len)
{
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1, d__2, d__3;
double sqrt(doublereal);
integer i__, j, k;
doublereal t, r1, d11, d12, d21, d22;
integer kk, kp;
doublereal wk, wkm1, wkp1;
integer imax, jmax;
extern int dsyr_(char *, integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, ftnlen);
doublereal alpha;
extern int dscal_(integer *, doublereal *, doublereal *, integer *);
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern int dswap_(integer *, doublereal *, integer *, doublereal *, integer *);
integer kstep;
logical upper;
doublereal absakk;
extern integer idamax_(integer *, doublereal *, integer *);
extern logical disnan_(doublereal *);
extern int xerbla_(char *, integer *, ftnlen);
doublereal colmax, rowmax;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
*info = 0;
upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1);
if (!upper && !lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1, *n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"DSYTF2", &i__1, (ftnlen)6);
return 0;
}
alpha = (sqrt(17.) + 1.) / 8.;
if (upper) {
k = *n;
L10:
if (k < 1) {
goto L70;
}
kstep = 1;
absakk = (d__1 = a[k + k * a_dim1], abs(d__1));
if (k > 1) {
i__1 = k - 1;
imax = idamax_(&i__1, &a[k * a_dim1 + 1], &c__1);
colmax = (d__1 = a[imax + k * a_dim1], abs(d__1));
} else {
colmax = 0.;
}
if (max(absakk, colmax) == 0. || disnan_(&absakk)) {
if (*info == 0) {
*info = k;
}
kp = k;
} else {
if (absakk >= alpha * colmax) {
kp = k;
} else {
i__1 = k - imax;
jmax = imax + idamax_(&i__1, &a[imax + (imax + 1) * a_dim1], lda);
rowmax = (d__1 = a[imax + jmax * a_dim1], abs(d__1));
if (imax > 1) {
i__1 = imax - 1;
jmax = idamax_(&i__1, &a[imax * a_dim1 + 1], &c__1);
d__2 = rowmax, d__3 = (d__1 = a[jmax + imax * a_dim1], abs(d__1));
rowmax = max(d__2, d__3);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
kp = k;
} else if ((d__1 = a[imax + imax * a_dim1], abs(d__1)) >= alpha * rowmax) {
kp = imax;
} else {
kp = imax;
kstep = 2;
}
}
kk = k - kstep + 1;
if (kp != kk) {
i__1 = kp - 1;
dswap_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], &c__1);
i__1 = kk - kp - 1;
dswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + 1) * a_dim1], lda);
t = a[kk + kk * a_dim1];
a[kk + kk * a_dim1] = a[kp + kp * a_dim1];
a[kp + kp * a_dim1] = t;
if (kstep == 2) {
t = a[k - 1 + k * a_dim1];
a[k - 1 + k * a_dim1] = a[kp + k * a_dim1];
a[kp + k * a_dim1] = t;
}
}
if (kstep == 1) {
r1 = 1. / a[k + k * a_dim1];
i__1 = k - 1;
d__1 = -r1;
dsyr_(uplo, &i__1, &d__1, &a[k * a_dim1 + 1], &c__1, &a[a_offset], lda, (ftnlen)1);
i__1 = k - 1;
dscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1);
} else {
if (k > 2) {
d12 = a[k - 1 + k * a_dim1];
d22 = a[k - 1 + (k - 1) * a_dim1] / d12;
d11 = a[k + k * a_dim1] / d12;
t = 1. / (d11 * d22 - 1.);
d12 = t / d12;
for (j = k - 2; j >= 1; --j) {
wkm1 = d12 * (d11 * a[j + (k - 1) * a_dim1] - a[j + k * a_dim1]);
wk = d12 * (d22 * a[j + k * a_dim1] - a[j + (k - 1) * a_dim1]);
for (i__ = j; i__ >= 1; --i__) {
a[i__ + j * a_dim1] = a[i__ + j * a_dim1] - a[i__ + k * a_dim1] * wk -
a[i__ + (k - 1) * a_dim1] * wkm1;
}
a[j + k * a_dim1] = wk;
a[j + (k - 1) * a_dim1] = wkm1;
}
}
}
}
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k - 1] = -kp;
}
k -= kstep;
goto L10;
} else {
k = 1;
L40:
if (k > *n) {
goto L70;
}
kstep = 1;
absakk = (d__1 = a[k + k * a_dim1], abs(d__1));
if (k < *n) {
i__1 = *n - k;
imax = k + idamax_(&i__1, &a[k + 1 + k * a_dim1], &c__1);
colmax = (d__1 = a[imax + k * a_dim1], abs(d__1));
} else {
colmax = 0.;
}
if (max(absakk, colmax) == 0. || disnan_(&absakk)) {
if (*info == 0) {
*info = k;
}
kp = k;
} else {
if (absakk >= alpha * colmax) {
kp = k;
} else {
i__1 = imax - k;
jmax = k - 1 + idamax_(&i__1, &a[imax + k * a_dim1], lda);
rowmax = (d__1 = a[imax + jmax * a_dim1], abs(d__1));
if (imax < *n) {
i__1 = *n - imax;
jmax = imax + idamax_(&i__1, &a[imax + 1 + imax * a_dim1], &c__1);
d__2 = rowmax, d__3 = (d__1 = a[jmax + imax * a_dim1], abs(d__1));
rowmax = max(d__2, d__3);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
kp = k;
} else if ((d__1 = a[imax + imax * a_dim1], abs(d__1)) >= alpha * rowmax) {
kp = imax;
} else {
kp = imax;
kstep = 2;
}
}
kk = k + kstep - 1;
if (kp != kk) {
if (kp < *n) {
i__1 = *n - kp;
dswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1 + kp * a_dim1], &c__1);
}
i__1 = kp - kk - 1;
dswap_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk + 1) * a_dim1], lda);
t = a[kk + kk * a_dim1];
a[kk + kk * a_dim1] = a[kp + kp * a_dim1];
a[kp + kp * a_dim1] = t;
if (kstep == 2) {
t = a[k + 1 + k * a_dim1];
a[k + 1 + k * a_dim1] = a[kp + k * a_dim1];
a[kp + k * a_dim1] = t;
}
}
if (kstep == 1) {
if (k < *n) {
d11 = 1. / a[k + k * a_dim1];
i__1 = *n - k;
d__1 = -d11;
dsyr_(uplo, &i__1, &d__1, &a[k + 1 + k * a_dim1], &c__1,
&a[k + 1 + (k + 1) * a_dim1], lda, (ftnlen)1);
i__1 = *n - k;
dscal_(&i__1, &d11, &a[k + 1 + k * a_dim1], &c__1);
}
} else {
if (k < *n - 1) {
d21 = a[k + 1 + k * a_dim1];
d11 = a[k + 1 + (k + 1) * a_dim1] / d21;
d22 = a[k + k * a_dim1] / d21;
t = 1. / (d11 * d22 - 1.);
d21 = t / d21;
i__1 = *n;
for (j = k + 2; j <= i__1; ++j) {
wk = d21 * (d11 * a[j + k * a_dim1] - a[j + (k + 1) * a_dim1]);
wkp1 = d21 * (d22 * a[j + (k + 1) * a_dim1] - a[j + k * a_dim1]);
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = a[i__ + j * a_dim1] - a[i__ + k * a_dim1] * wk -
a[i__ + (k + 1) * a_dim1] * wkp1;
}
a[j + k * a_dim1] = wk;
a[j + (k + 1) * a_dim1] = wkp1;
}
}
}
}
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k + 1] = -kp;
}
k += kstep;
goto L40;
}
L70:
return 0;
}
#ifdef __cplusplus
}
#endif

123
lib/linalg/dsytrf.cpp Normal file
View File

@ -0,0 +1,123 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static integer c__1 = 1;
static integer c_n1 = -1;
static integer c__2 = 2;
int dsytrf_(char *uplo, integer *n, doublereal *a, integer *lda, integer *ipiv, doublereal *work,
integer *lwork, integer *info, ftnlen uplo_len)
{
integer a_dim1, a_offset, i__1, i__2;
integer j, k, kb, nb, iws;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
integer nbmin, iinfo;
logical upper;
extern int dsytf2_(char *, integer *, doublereal *, integer *, integer *, integer *, ftnlen),
xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
extern int dlasyf_(char *, integer *, integer *, integer *, doublereal *, integer *, integer *,
doublereal *, integer *, integer *, ftnlen);
integer ldwork, lwkopt;
logical lquery;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
--work;
*info = 0;
upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1);
lquery = *lwork == -1;
if (!upper && !lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1, *n)) {
*info = -4;
} else if (*lwork < 1 && !lquery) {
*info = -7;
}
if (*info == 0) {
nb = ilaenv_(&c__1, (char *)"DSYTRF", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
lwkopt = *n * nb;
work[1] = (doublereal)lwkopt;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"DSYTRF", &i__1, (ftnlen)6);
return 0;
} else if (lquery) {
return 0;
}
nbmin = 2;
ldwork = *n;
if (nb > 1 && nb < *n) {
iws = ldwork * nb;
if (*lwork < iws) {
i__1 = *lwork / ldwork;
nb = max(i__1, 1);
i__1 = 2,
i__2 = ilaenv_(&c__2, (char *)"DSYTRF", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
nbmin = max(i__1, i__2);
}
} else {
iws = 1;
}
if (nb < nbmin) {
nb = *n;
}
if (upper) {
k = *n;
L10:
if (k < 1) {
goto L40;
}
if (k > nb) {
dlasyf_(uplo, &k, &nb, &kb, &a[a_offset], lda, &ipiv[1], &work[1], &ldwork, &iinfo,
(ftnlen)1);
} else {
dsytf2_(uplo, &k, &a[a_offset], lda, &ipiv[1], &iinfo, (ftnlen)1);
kb = k;
}
if (*info == 0 && iinfo > 0) {
*info = iinfo;
}
k -= kb;
goto L10;
} else {
k = 1;
L20:
if (k > *n) {
goto L40;
}
if (k <= *n - nb) {
i__1 = *n - k + 1;
dlasyf_(uplo, &i__1, &nb, &kb, &a[k + k * a_dim1], lda, &ipiv[k], &work[1], &ldwork,
&iinfo, (ftnlen)1);
} else {
i__1 = *n - k + 1;
dsytf2_(uplo, &i__1, &a[k + k * a_dim1], lda, &ipiv[k], &iinfo, (ftnlen)1);
kb = *n - k + 1;
}
if (*info == 0 && iinfo > 0) {
*info = iinfo + k - 1;
}
i__1 = k + kb - 1;
for (j = k; j <= i__1; ++j) {
if (ipiv[j] > 0) {
ipiv[j] = ipiv[j] + k - 1;
} else {
ipiv[j] = ipiv[j] - k + 1;
}
}
k += kb;
goto L20;
}
L40:
work[1] = (doublereal)lwkopt;
return 0;
}
#ifdef __cplusplus
}
#endif

214
lib/linalg/dsytrs.cpp Normal file
View File

@ -0,0 +1,214 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static doublereal c_b7 = -1.;
static integer c__1 = 1;
static doublereal c_b19 = 1.;
int dsytrs_(char *uplo, integer *n, integer *nrhs, doublereal *a, integer *lda, integer *ipiv,
doublereal *b, integer *ldb, integer *info, ftnlen uplo_len)
{
integer a_dim1, a_offset, b_dim1, b_offset, i__1;
doublereal d__1;
integer j, k;
doublereal ak, bk;
integer kp;
doublereal akm1, bkm1;
extern int dger_(integer *, integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *);
doublereal akm1k;
extern int dscal_(integer *, doublereal *, doublereal *, integer *);
extern logical lsame_(char *, char *, ftnlen, ftnlen);
doublereal denom;
extern int dgemv_(char *, integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *, ftnlen),
dswap_(integer *, doublereal *, integer *, doublereal *, integer *);
logical upper;
extern int xerbla_(char *, integer *, ftnlen);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
*info = 0;
upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1);
if (!upper && !lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1, *n)) {
*info = -5;
} else if (*ldb < max(1, *n)) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"DSYTRS", &i__1, (ftnlen)6);
return 0;
}
if (*n == 0 || *nrhs == 0) {
return 0;
}
if (upper) {
k = *n;
L10:
if (k < 1) {
goto L30;
}
if (ipiv[k] > 0) {
kp = ipiv[k];
if (kp != k) {
dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
i__1 = k - 1;
dger_(&i__1, nrhs, &c_b7, &a[k * a_dim1 + 1], &c__1, &b[k + b_dim1], ldb,
&b[b_dim1 + 1], ldb);
d__1 = 1. / a[k + k * a_dim1];
dscal_(nrhs, &d__1, &b[k + b_dim1], ldb);
--k;
} else {
kp = -ipiv[k];
if (kp != k - 1) {
dswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
i__1 = k - 2;
dger_(&i__1, nrhs, &c_b7, &a[k * a_dim1 + 1], &c__1, &b[k + b_dim1], ldb,
&b[b_dim1 + 1], ldb);
i__1 = k - 2;
dger_(&i__1, nrhs, &c_b7, &a[(k - 1) * a_dim1 + 1], &c__1, &b[k - 1 + b_dim1], ldb,
&b[b_dim1 + 1], ldb);
akm1k = a[k - 1 + k * a_dim1];
akm1 = a[k - 1 + (k - 1) * a_dim1] / akm1k;
ak = a[k + k * a_dim1] / akm1k;
denom = akm1 * ak - 1.;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
bkm1 = b[k - 1 + j * b_dim1] / akm1k;
bk = b[k + j * b_dim1] / akm1k;
b[k - 1 + j * b_dim1] = (ak * bkm1 - bk) / denom;
b[k + j * b_dim1] = (akm1 * bk - bkm1) / denom;
}
k += -2;
}
goto L10;
L30:
k = 1;
L40:
if (k > *n) {
goto L50;
}
if (ipiv[k] > 0) {
i__1 = k - 1;
dgemv_((char *)"Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &a[k * a_dim1 + 1], &c__1,
&c_b19, &b[k + b_dim1], ldb, (ftnlen)9);
kp = ipiv[k];
if (kp != k) {
dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
++k;
} else {
i__1 = k - 1;
dgemv_((char *)"Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &a[k * a_dim1 + 1], &c__1,
&c_b19, &b[k + b_dim1], ldb, (ftnlen)9);
i__1 = k - 1;
dgemv_((char *)"Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &a[(k + 1) * a_dim1 + 1],
&c__1, &c_b19, &b[k + 1 + b_dim1], ldb, (ftnlen)9);
kp = -ipiv[k];
if (kp != k) {
dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
k += 2;
}
goto L40;
L50:;
} else {
k = 1;
L60:
if (k > *n) {
goto L80;
}
if (ipiv[k] > 0) {
kp = ipiv[k];
if (kp != k) {
dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
if (k < *n) {
i__1 = *n - k;
dger_(&i__1, nrhs, &c_b7, &a[k + 1 + k * a_dim1], &c__1, &b[k + b_dim1], ldb,
&b[k + 1 + b_dim1], ldb);
}
d__1 = 1. / a[k + k * a_dim1];
dscal_(nrhs, &d__1, &b[k + b_dim1], ldb);
++k;
} else {
kp = -ipiv[k];
if (kp != k + 1) {
dswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
if (k < *n - 1) {
i__1 = *n - k - 1;
dger_(&i__1, nrhs, &c_b7, &a[k + 2 + k * a_dim1], &c__1, &b[k + b_dim1], ldb,
&b[k + 2 + b_dim1], ldb);
i__1 = *n - k - 1;
dger_(&i__1, nrhs, &c_b7, &a[k + 2 + (k + 1) * a_dim1], &c__1, &b[k + 1 + b_dim1],
ldb, &b[k + 2 + b_dim1], ldb);
}
akm1k = a[k + 1 + k * a_dim1];
akm1 = a[k + k * a_dim1] / akm1k;
ak = a[k + 1 + (k + 1) * a_dim1] / akm1k;
denom = akm1 * ak - 1.;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
bkm1 = b[k + j * b_dim1] / akm1k;
bk = b[k + 1 + j * b_dim1] / akm1k;
b[k + j * b_dim1] = (ak * bkm1 - bk) / denom;
b[k + 1 + j * b_dim1] = (akm1 * bk - bkm1) / denom;
}
k += 2;
}
goto L60;
L80:
k = *n;
L90:
if (k < 1) {
goto L100;
}
if (ipiv[k] > 0) {
if (k < *n) {
i__1 = *n - k;
dgemv_((char *)"Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], ldb,
&a[k + 1 + k * a_dim1], &c__1, &c_b19, &b[k + b_dim1], ldb, (ftnlen)9);
}
kp = ipiv[k];
if (kp != k) {
dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
--k;
} else {
if (k < *n) {
i__1 = *n - k;
dgemv_((char *)"Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], ldb,
&a[k + 1 + k * a_dim1], &c__1, &c_b19, &b[k + b_dim1], ldb, (ftnlen)9);
i__1 = *n - k;
dgemv_((char *)"Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], ldb,
&a[k + 1 + (k - 1) * a_dim1], &c__1, &c_b19, &b[k - 1 + b_dim1], ldb,
(ftnlen)9);
}
kp = -ipiv[k];
if (kp != k) {
dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
k += -2;
}
goto L90;
L100:;
}
return 0;
}
#ifdef __cplusplus
}
#endif

180
lib/linalg/dsytrs2.cpp Normal file
View File

@ -0,0 +1,180 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static doublereal c_b10 = 1.;
int dsytrs2_(char *uplo, integer *n, integer *nrhs, doublereal *a, integer *lda, integer *ipiv,
doublereal *b, integer *ldb, doublereal *work, integer *info, ftnlen uplo_len)
{
integer a_dim1, a_offset, b_dim1, b_offset, i__1;
doublereal d__1;
integer i__, j, k;
doublereal ak, bk;
integer kp;
doublereal akm1, bkm1, akm1k;
extern int dscal_(integer *, doublereal *, doublereal *, integer *);
extern logical lsame_(char *, char *, ftnlen, ftnlen);
doublereal denom;
integer iinfo;
extern int dswap_(integer *, doublereal *, integer *, doublereal *, integer *),
dtrsm_(char *, char *, char *, char *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen);
logical upper;
extern int xerbla_(char *, integer *, ftnlen),
dsyconv_(char *, char *, integer *, doublereal *, integer *, integer *, doublereal *,
integer *, ftnlen, ftnlen);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--work;
*info = 0;
upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1);
if (!upper && !lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1, *n)) {
*info = -5;
} else if (*ldb < max(1, *n)) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"DSYTRS2", &i__1, (ftnlen)7);
return 0;
}
if (*n == 0 || *nrhs == 0) {
return 0;
}
dsyconv_(uplo, (char *)"C", n, &a[a_offset], lda, &ipiv[1], &work[1], &iinfo, (ftnlen)1, (ftnlen)1);
if (upper) {
k = *n;
while (k >= 1) {
if (ipiv[k] > 0) {
kp = ipiv[k];
if (kp != k) {
dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
--k;
} else {
kp = -ipiv[k];
if (kp == -ipiv[k - 1]) {
dswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
k += -2;
}
}
dtrsm_((char *)"L", (char *)"U", (char *)"N", (char *)"U", n, nrhs, &c_b10, &a[a_offset], lda, &b[b_offset], ldb, (ftnlen)1,
(ftnlen)1, (ftnlen)1, (ftnlen)1);
i__ = *n;
while (i__ >= 1) {
if (ipiv[i__] > 0) {
d__1 = 1. / a[i__ + i__ * a_dim1];
dscal_(nrhs, &d__1, &b[i__ + b_dim1], ldb);
} else if (i__ > 1) {
if (ipiv[i__ - 1] == ipiv[i__]) {
akm1k = work[i__];
akm1 = a[i__ - 1 + (i__ - 1) * a_dim1] / akm1k;
ak = a[i__ + i__ * a_dim1] / akm1k;
denom = akm1 * ak - 1.;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
bkm1 = b[i__ - 1 + j * b_dim1] / akm1k;
bk = b[i__ + j * b_dim1] / akm1k;
b[i__ - 1 + j * b_dim1] = (ak * bkm1 - bk) / denom;
b[i__ + j * b_dim1] = (akm1 * bk - bkm1) / denom;
}
--i__;
}
}
--i__;
}
dtrsm_((char *)"L", (char *)"U", (char *)"T", (char *)"U", n, nrhs, &c_b10, &a[a_offset], lda, &b[b_offset], ldb, (ftnlen)1,
(ftnlen)1, (ftnlen)1, (ftnlen)1);
k = 1;
while (k <= *n) {
if (ipiv[k] > 0) {
kp = ipiv[k];
if (kp != k) {
dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
++k;
} else {
kp = -ipiv[k];
if (k < *n && kp == -ipiv[k + 1]) {
dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
k += 2;
}
}
} else {
k = 1;
while (k <= *n) {
if (ipiv[k] > 0) {
kp = ipiv[k];
if (kp != k) {
dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
++k;
} else {
kp = -ipiv[k + 1];
if (kp == -ipiv[k]) {
dswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
k += 2;
}
}
dtrsm_((char *)"L", (char *)"L", (char *)"N", (char *)"U", n, nrhs, &c_b10, &a[a_offset], lda, &b[b_offset], ldb, (ftnlen)1,
(ftnlen)1, (ftnlen)1, (ftnlen)1);
i__ = 1;
while (i__ <= *n) {
if (ipiv[i__] > 0) {
d__1 = 1. / a[i__ + i__ * a_dim1];
dscal_(nrhs, &d__1, &b[i__ + b_dim1], ldb);
} else {
akm1k = work[i__];
akm1 = a[i__ + i__ * a_dim1] / akm1k;
ak = a[i__ + 1 + (i__ + 1) * a_dim1] / akm1k;
denom = akm1 * ak - 1.;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
bkm1 = b[i__ + j * b_dim1] / akm1k;
bk = b[i__ + 1 + j * b_dim1] / akm1k;
b[i__ + j * b_dim1] = (ak * bkm1 - bk) / denom;
b[i__ + 1 + j * b_dim1] = (akm1 * bk - bkm1) / denom;
}
++i__;
}
++i__;
}
dtrsm_((char *)"L", (char *)"L", (char *)"T", (char *)"U", n, nrhs, &c_b10, &a[a_offset], lda, &b[b_offset], ldb, (ftnlen)1,
(ftnlen)1, (ftnlen)1, (ftnlen)1);
k = *n;
while (k >= 1) {
if (ipiv[k] > 0) {
kp = ipiv[k];
if (kp != k) {
dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
--k;
} else {
kp = -ipiv[k];
if (k > 1 && kp == -ipiv[k - 1]) {
dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
k += -2;
}
}
}
dsyconv_(uplo, (char *)"R", n, &a[a_offset], lda, &ipiv[1], &work[1], &iinfo, (ftnlen)1, (ftnlen)1);
return 0;
}
#ifdef __cplusplus
}
#endif

858
lib/linalg/dtrevc3.cpp Normal file
View File

@ -0,0 +1,858 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static integer c__1 = 1;
static integer c_n1 = -1;
static integer c__2 = 2;
static doublereal c_b17 = 0.;
static logical c_false = FALSE_;
static doublereal c_b29 = 1.;
static logical c_true = TRUE_;
int dtrevc3_(char *side, char *howmny, logical *select, integer *n, doublereal *t, integer *ldt,
doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr, integer *mm, integer *m,
doublereal *work, integer *lwork, integer *info, ftnlen side_len, ftnlen howmny_len)
{
address a__1[2];
integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1[2], i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4;
char ch__1[2];
int s_lmp_cat(char *, char **, integer *, integer *, ftnlen);
double sqrt(doublereal);
integer i__, j, k;
doublereal x[4];
integer j1, j2, iscomplex[128], nb, ii, ki, ip, is, iv;
doublereal wi, wr;
integer ki2;
doublereal rec, ulp, beta, emax;
logical pair;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *);
logical allv;
integer ierr;
doublereal unfl, ovfl, smin;
logical over;
doublereal vmax;
integer jnxt;
extern int dscal_(integer *, doublereal *, doublereal *, integer *);
doublereal scale;
extern int dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *, integer *,
ftnlen, ftnlen);
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern int dgemv_(char *, integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *, ftnlen);
doublereal remax;
extern int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *);
logical leftv, bothv;
extern int daxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *);
doublereal vcrit;
logical somev;
doublereal xnorm;
extern int dlaln2_(logical *, integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
integer *),
dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *, ftnlen);
extern integer idamax_(integer *, doublereal *, integer *);
extern int dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, ftnlen),
xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
extern int dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *,
integer *, ftnlen);
doublereal bignum;
logical rightv;
integer maxwrk;
doublereal smlnum;
logical lquery;
--select;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--work;
bothv = lsame_(side, (char *)"B", (ftnlen)1, (ftnlen)1);
rightv = lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1) || bothv;
leftv = lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1) || bothv;
allv = lsame_(howmny, (char *)"A", (ftnlen)1, (ftnlen)1);
over = lsame_(howmny, (char *)"B", (ftnlen)1, (ftnlen)1);
somev = lsame_(howmny, (char *)"S", (ftnlen)1, (ftnlen)1);
*info = 0;
i__1[0] = 1, a__1[0] = side;
i__1[1] = 1, a__1[1] = howmny;
s_lmp_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
nb = ilaenv_(&c__1, (char *)"DTREVC", ch__1, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)2);
maxwrk = *n + (*n << 1) * nb;
work[1] = (doublereal)maxwrk;
lquery = *lwork == -1;
if (!rightv && !leftv) {
*info = -1;
} else if (!allv && !over && !somev) {
*info = -2;
} else if (*n < 0) {
*info = -4;
} else if (*ldt < max(1, *n)) {
*info = -6;
} else if (*ldvl < 1 || leftv && *ldvl < *n) {
*info = -8;
} else if (*ldvr < 1 || rightv && *ldvr < *n) {
*info = -10;
} else {
i__2 = 1, i__3 = *n * 3;
if (*lwork < max(i__2, i__3) && !lquery) {
*info = -14;
} else {
if (somev) {
*m = 0;
pair = FALSE_;
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
if (pair) {
pair = FALSE_;
select[j] = FALSE_;
} else {
if (j < *n) {
if (t[j + 1 + j * t_dim1] == 0.) {
if (select[j]) {
++(*m);
}
} else {
pair = TRUE_;
if (select[j] || select[j + 1]) {
select[j] = TRUE_;
*m += 2;
}
}
} else {
if (select[*n]) {
++(*m);
}
}
}
}
} else {
*m = *n;
}
if (*mm < *m) {
*info = -11;
}
}
}
if (*info != 0) {
i__2 = -(*info);
xerbla_((char *)"DTREVC3", &i__2, (ftnlen)7);
return 0;
} else if (lquery) {
return 0;
}
if (*n == 0) {
return 0;
}
if (over && *lwork >= *n + (*n << 4)) {
nb = (*lwork - *n) / (*n << 1);
nb = min(nb, 128);
i__2 = (nb << 1) + 1;
dlaset_((char *)"F", n, &i__2, &c_b17, &c_b17, &work[1], n, (ftnlen)1);
} else {
nb = 1;
}
unfl = dlamch_((char *)"Safe minimum", (ftnlen)12);
ovfl = 1. / unfl;
dlabad_(&unfl, &ovfl);
ulp = dlamch_((char *)"Precision", (ftnlen)9);
smlnum = unfl * (*n / ulp);
bignum = (1. - ulp) / smlnum;
work[1] = 0.;
i__2 = *n;
for (j = 2; j <= i__2; ++j) {
work[j] = 0.;
i__3 = j - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
work[j] += (d__1 = t[i__ + j * t_dim1], abs(d__1));
}
}
if (rightv) {
iv = 2;
if (nb > 2) {
iv = nb;
}
ip = 0;
is = *m;
for (ki = *n; ki >= 1; --ki) {
if (ip == -1) {
ip = 1;
goto L140;
} else if (ki == 1) {
ip = 0;
} else if (t[ki + (ki - 1) * t_dim1] == 0.) {
ip = 0;
} else {
ip = -1;
}
if (somev) {
if (ip == 0) {
if (!select[ki]) {
goto L140;
}
} else {
if (!select[ki - 1]) {
goto L140;
}
}
}
wr = t[ki + ki * t_dim1];
wi = 0.;
if (ip != 0) {
wi = sqrt((d__1 = t[ki + (ki - 1) * t_dim1], abs(d__1))) *
sqrt((d__2 = t[ki - 1 + ki * t_dim1], abs(d__2)));
}
d__1 = ulp * (abs(wr) + abs(wi));
smin = max(d__1, smlnum);
if (ip == 0) {
work[ki + iv * *n] = 1.;
i__2 = ki - 1;
for (k = 1; k <= i__2; ++k) {
work[k + iv * *n] = -t[k + ki * t_dim1];
}
jnxt = ki - 1;
for (j = ki - 1; j >= 1; --j) {
if (j > jnxt) {
goto L60;
}
j1 = j;
j2 = j;
jnxt = j - 1;
if (j > 1) {
if (t[j + (j - 1) * t_dim1] != 0.) {
j1 = j - 1;
jnxt = j - 2;
}
}
if (j1 == j2) {
dlaln2_(&c_false, &c__1, &c__1, &smin, &c_b29, &t[j + j * t_dim1], ldt,
&c_b29, &c_b29, &work[j + iv * *n], n, &wr, &c_b17, x, &c__2,
&scale, &xnorm, &ierr);
if (xnorm > 1.) {
if (work[j] > bignum / xnorm) {
x[0] /= xnorm;
scale /= xnorm;
}
}
if (scale != 1.) {
dscal_(&ki, &scale, &work[iv * *n + 1], &c__1);
}
work[j + iv * *n] = x[0];
i__2 = j - 1;
d__1 = -x[0];
daxpy_(&i__2, &d__1, &t[j * t_dim1 + 1], &c__1, &work[iv * *n + 1], &c__1);
} else {
dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b29, &t[j - 1 + (j - 1) * t_dim1],
ldt, &c_b29, &c_b29, &work[j - 1 + iv * *n], n, &wr, &c_b17, x,
&c__2, &scale, &xnorm, &ierr);
if (xnorm > 1.) {
d__1 = work[j - 1], d__2 = work[j];
beta = max(d__1, d__2);
if (beta > bignum / xnorm) {
x[0] /= xnorm;
x[1] /= xnorm;
scale /= xnorm;
}
}
if (scale != 1.) {
dscal_(&ki, &scale, &work[iv * *n + 1], &c__1);
}
work[j - 1 + iv * *n] = x[0];
work[j + iv * *n] = x[1];
i__2 = j - 2;
d__1 = -x[0];
daxpy_(&i__2, &d__1, &t[(j - 1) * t_dim1 + 1], &c__1, &work[iv * *n + 1],
&c__1);
i__2 = j - 2;
d__1 = -x[1];
daxpy_(&i__2, &d__1, &t[j * t_dim1 + 1], &c__1, &work[iv * *n + 1], &c__1);
}
L60:;
}
if (!over) {
dcopy_(&ki, &work[iv * *n + 1], &c__1, &vr[is * vr_dim1 + 1], &c__1);
ii = idamax_(&ki, &vr[is * vr_dim1 + 1], &c__1);
remax = 1. / (d__1 = vr[ii + is * vr_dim1], abs(d__1));
dscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1);
i__2 = *n;
for (k = ki + 1; k <= i__2; ++k) {
vr[k + is * vr_dim1] = 0.;
}
} else if (nb == 1) {
if (ki > 1) {
i__2 = ki - 1;
dgemv_((char *)"N", n, &i__2, &c_b29, &vr[vr_offset], ldvr, &work[iv * *n + 1],
&c__1, &work[ki + iv * *n], &vr[ki * vr_dim1 + 1], &c__1, (ftnlen)1);
}
ii = idamax_(n, &vr[ki * vr_dim1 + 1], &c__1);
remax = 1. / (d__1 = vr[ii + ki * vr_dim1], abs(d__1));
dscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1);
} else {
i__2 = *n;
for (k = ki + 1; k <= i__2; ++k) {
work[k + iv * *n] = 0.;
}
iscomplex[iv - 1] = ip;
}
} else {
if ((d__1 = t[ki - 1 + ki * t_dim1], abs(d__1)) >=
(d__2 = t[ki + (ki - 1) * t_dim1], abs(d__2))) {
work[ki - 1 + (iv - 1) * *n] = 1.;
work[ki + iv * *n] = wi / t[ki - 1 + ki * t_dim1];
} else {
work[ki - 1 + (iv - 1) * *n] = -wi / t[ki + (ki - 1) * t_dim1];
work[ki + iv * *n] = 1.;
}
work[ki + (iv - 1) * *n] = 0.;
work[ki - 1 + iv * *n] = 0.;
i__2 = ki - 2;
for (k = 1; k <= i__2; ++k) {
work[k + (iv - 1) * *n] =
-work[ki - 1 + (iv - 1) * *n] * t[k + (ki - 1) * t_dim1];
work[k + iv * *n] = -work[ki + iv * *n] * t[k + ki * t_dim1];
}
jnxt = ki - 2;
for (j = ki - 2; j >= 1; --j) {
if (j > jnxt) {
goto L90;
}
j1 = j;
j2 = j;
jnxt = j - 1;
if (j > 1) {
if (t[j + (j - 1) * t_dim1] != 0.) {
j1 = j - 1;
jnxt = j - 2;
}
}
if (j1 == j2) {
dlaln2_(&c_false, &c__1, &c__2, &smin, &c_b29, &t[j + j * t_dim1], ldt,
&c_b29, &c_b29, &work[j + (iv - 1) * *n], n, &wr, &wi, x, &c__2,
&scale, &xnorm, &ierr);
if (xnorm > 1.) {
if (work[j] > bignum / xnorm) {
x[0] /= xnorm;
x[2] /= xnorm;
scale /= xnorm;
}
}
if (scale != 1.) {
dscal_(&ki, &scale, &work[(iv - 1) * *n + 1], &c__1);
dscal_(&ki, &scale, &work[iv * *n + 1], &c__1);
}
work[j + (iv - 1) * *n] = x[0];
work[j + iv * *n] = x[2];
i__2 = j - 1;
d__1 = -x[0];
daxpy_(&i__2, &d__1, &t[j * t_dim1 + 1], &c__1, &work[(iv - 1) * *n + 1],
&c__1);
i__2 = j - 1;
d__1 = -x[2];
daxpy_(&i__2, &d__1, &t[j * t_dim1 + 1], &c__1, &work[iv * *n + 1], &c__1);
} else {
dlaln2_(&c_false, &c__2, &c__2, &smin, &c_b29, &t[j - 1 + (j - 1) * t_dim1],
ldt, &c_b29, &c_b29, &work[j - 1 + (iv - 1) * *n], n, &wr, &wi, x,
&c__2, &scale, &xnorm, &ierr);
if (xnorm > 1.) {
d__1 = work[j - 1], d__2 = work[j];
beta = max(d__1, d__2);
if (beta > bignum / xnorm) {
rec = 1. / xnorm;
x[0] *= rec;
x[2] *= rec;
x[1] *= rec;
x[3] *= rec;
scale *= rec;
}
}
if (scale != 1.) {
dscal_(&ki, &scale, &work[(iv - 1) * *n + 1], &c__1);
dscal_(&ki, &scale, &work[iv * *n + 1], &c__1);
}
work[j - 1 + (iv - 1) * *n] = x[0];
work[j + (iv - 1) * *n] = x[1];
work[j - 1 + iv * *n] = x[2];
work[j + iv * *n] = x[3];
i__2 = j - 2;
d__1 = -x[0];
daxpy_(&i__2, &d__1, &t[(j - 1) * t_dim1 + 1], &c__1,
&work[(iv - 1) * *n + 1], &c__1);
i__2 = j - 2;
d__1 = -x[1];
daxpy_(&i__2, &d__1, &t[j * t_dim1 + 1], &c__1, &work[(iv - 1) * *n + 1],
&c__1);
i__2 = j - 2;
d__1 = -x[2];
daxpy_(&i__2, &d__1, &t[(j - 1) * t_dim1 + 1], &c__1, &work[iv * *n + 1],
&c__1);
i__2 = j - 2;
d__1 = -x[3];
daxpy_(&i__2, &d__1, &t[j * t_dim1 + 1], &c__1, &work[iv * *n + 1], &c__1);
}
L90:;
}
if (!over) {
dcopy_(&ki, &work[(iv - 1) * *n + 1], &c__1, &vr[(is - 1) * vr_dim1 + 1],
&c__1);
dcopy_(&ki, &work[iv * *n + 1], &c__1, &vr[is * vr_dim1 + 1], &c__1);
emax = 0.;
i__2 = ki;
for (k = 1; k <= i__2; ++k) {
d__3 = emax, d__4 = (d__1 = vr[k + (is - 1) * vr_dim1], abs(d__1)) +
(d__2 = vr[k + is * vr_dim1], abs(d__2));
emax = max(d__3, d__4);
}
remax = 1. / emax;
dscal_(&ki, &remax, &vr[(is - 1) * vr_dim1 + 1], &c__1);
dscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1);
i__2 = *n;
for (k = ki + 1; k <= i__2; ++k) {
vr[k + (is - 1) * vr_dim1] = 0.;
vr[k + is * vr_dim1] = 0.;
}
} else if (nb == 1) {
if (ki > 2) {
i__2 = ki - 2;
dgemv_((char *)"N", n, &i__2, &c_b29, &vr[vr_offset], ldvr,
&work[(iv - 1) * *n + 1], &c__1, &work[ki - 1 + (iv - 1) * *n],
&vr[(ki - 1) * vr_dim1 + 1], &c__1, (ftnlen)1);
i__2 = ki - 2;
dgemv_((char *)"N", n, &i__2, &c_b29, &vr[vr_offset], ldvr, &work[iv * *n + 1],
&c__1, &work[ki + iv * *n], &vr[ki * vr_dim1 + 1], &c__1, (ftnlen)1);
} else {
dscal_(n, &work[ki - 1 + (iv - 1) * *n], &vr[(ki - 1) * vr_dim1 + 1],
&c__1);
dscal_(n, &work[ki + iv * *n], &vr[ki * vr_dim1 + 1], &c__1);
}
emax = 0.;
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
d__3 = emax, d__4 = (d__1 = vr[k + (ki - 1) * vr_dim1], abs(d__1)) +
(d__2 = vr[k + ki * vr_dim1], abs(d__2));
emax = max(d__3, d__4);
}
remax = 1. / emax;
dscal_(n, &remax, &vr[(ki - 1) * vr_dim1 + 1], &c__1);
dscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1);
} else {
i__2 = *n;
for (k = ki + 1; k <= i__2; ++k) {
work[k + (iv - 1) * *n] = 0.;
work[k + iv * *n] = 0.;
}
iscomplex[iv - 2] = -ip;
iscomplex[iv - 1] = ip;
--iv;
}
}
if (nb > 1) {
if (ip == 0) {
ki2 = ki;
} else {
ki2 = ki - 1;
}
if (iv <= 2 || ki2 == 1) {
i__2 = nb - iv + 1;
i__3 = ki2 + nb - iv;
dgemm_((char *)"N", (char *)"N", n, &i__2, &i__3, &c_b29, &vr[vr_offset], ldvr,
&work[iv * *n + 1], n, &c_b17, &work[(nb + iv) * *n + 1], n, (ftnlen)1,
(ftnlen)1);
i__2 = nb;
for (k = iv; k <= i__2; ++k) {
if (iscomplex[k - 1] == 0) {
ii = idamax_(n, &work[(nb + k) * *n + 1], &c__1);
remax = 1. / (d__1 = work[ii + (nb + k) * *n], abs(d__1));
} else if (iscomplex[k - 1] == 1) {
emax = 0.;
i__3 = *n;
for (ii = 1; ii <= i__3; ++ii) {
d__3 = emax,
d__4 = (d__1 = work[ii + (nb + k) * *n], abs(d__1)) +
(d__2 = work[ii + (nb + k + 1) * *n], abs(d__2));
emax = max(d__3, d__4);
}
remax = 1. / emax;
}
dscal_(n, &remax, &work[(nb + k) * *n + 1], &c__1);
}
i__2 = nb - iv + 1;
dlacpy_((char *)"F", n, &i__2, &work[(nb + iv) * *n + 1], n, &vr[ki2 * vr_dim1 + 1],
ldvr, (ftnlen)1);
iv = nb;
} else {
--iv;
}
}
--is;
if (ip != 0) {
--is;
}
L140:;
}
}
if (leftv) {
iv = 1;
ip = 0;
is = 1;
i__2 = *n;
for (ki = 1; ki <= i__2; ++ki) {
if (ip == 1) {
ip = -1;
goto L260;
} else if (ki == *n) {
ip = 0;
} else if (t[ki + 1 + ki * t_dim1] == 0.) {
ip = 0;
} else {
ip = 1;
}
if (somev) {
if (!select[ki]) {
goto L260;
}
}
wr = t[ki + ki * t_dim1];
wi = 0.;
if (ip != 0) {
wi = sqrt((d__1 = t[ki + (ki + 1) * t_dim1], abs(d__1))) *
sqrt((d__2 = t[ki + 1 + ki * t_dim1], abs(d__2)));
}
d__1 = ulp * (abs(wr) + abs(wi));
smin = max(d__1, smlnum);
if (ip == 0) {
work[ki + iv * *n] = 1.;
i__3 = *n;
for (k = ki + 1; k <= i__3; ++k) {
work[k + iv * *n] = -t[ki + k * t_dim1];
}
vmax = 1.;
vcrit = bignum;
jnxt = ki + 1;
i__3 = *n;
for (j = ki + 1; j <= i__3; ++j) {
if (j < jnxt) {
goto L170;
}
j1 = j;
j2 = j;
jnxt = j + 1;
if (j < *n) {
if (t[j + 1 + j * t_dim1] != 0.) {
j2 = j + 1;
jnxt = j + 2;
}
}
if (j1 == j2) {
if (work[j] > vcrit) {
rec = 1. / vmax;
i__4 = *n - ki + 1;
dscal_(&i__4, &rec, &work[ki + iv * *n], &c__1);
vmax = 1.;
vcrit = bignum;
}
i__4 = j - ki - 1;
work[j + iv * *n] -= ddot_(&i__4, &t[ki + 1 + j * t_dim1], &c__1,
&work[ki + 1 + iv * *n], &c__1);
dlaln2_(&c_false, &c__1, &c__1, &smin, &c_b29, &t[j + j * t_dim1], ldt,
&c_b29, &c_b29, &work[j + iv * *n], n, &wr, &c_b17, x, &c__2,
&scale, &xnorm, &ierr);
if (scale != 1.) {
i__4 = *n - ki + 1;
dscal_(&i__4, &scale, &work[ki + iv * *n], &c__1);
}
work[j + iv * *n] = x[0];
d__2 = (d__1 = work[j + iv * *n], abs(d__1));
vmax = max(d__2, vmax);
vcrit = bignum / vmax;
} else {
d__1 = work[j], d__2 = work[j + 1];
beta = max(d__1, d__2);
if (beta > vcrit) {
rec = 1. / vmax;
i__4 = *n - ki + 1;
dscal_(&i__4, &rec, &work[ki + iv * *n], &c__1);
vmax = 1.;
vcrit = bignum;
}
i__4 = j - ki - 1;
work[j + iv * *n] -= ddot_(&i__4, &t[ki + 1 + j * t_dim1], &c__1,
&work[ki + 1 + iv * *n], &c__1);
i__4 = j - ki - 1;
work[j + 1 + iv * *n] -= ddot_(&i__4, &t[ki + 1 + (j + 1) * t_dim1], &c__1,
&work[ki + 1 + iv * *n], &c__1);
dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b29, &t[j + j * t_dim1], ldt,
&c_b29, &c_b29, &work[j + iv * *n], n, &wr, &c_b17, x, &c__2,
&scale, &xnorm, &ierr);
if (scale != 1.) {
i__4 = *n - ki + 1;
dscal_(&i__4, &scale, &work[ki + iv * *n], &c__1);
}
work[j + iv * *n] = x[0];
work[j + 1 + iv * *n] = x[1];
d__3 = (d__1 = work[j + iv * *n], abs(d__1)),
d__4 = (d__2 = work[j + 1 + iv * *n], abs(d__2)), d__3 = max(d__3, d__4);
vmax = max(d__3, vmax);
vcrit = bignum / vmax;
}
L170:;
}
if (!over) {
i__3 = *n - ki + 1;
dcopy_(&i__3, &work[ki + iv * *n], &c__1, &vl[ki + is * vl_dim1], &c__1);
i__3 = *n - ki + 1;
ii = idamax_(&i__3, &vl[ki + is * vl_dim1], &c__1) + ki - 1;
remax = 1. / (d__1 = vl[ii + is * vl_dim1], abs(d__1));
i__3 = *n - ki + 1;
dscal_(&i__3, &remax, &vl[ki + is * vl_dim1], &c__1);
i__3 = ki - 1;
for (k = 1; k <= i__3; ++k) {
vl[k + is * vl_dim1] = 0.;
}
} else if (nb == 1) {
if (ki < *n) {
i__3 = *n - ki;
dgemv_((char *)"N", n, &i__3, &c_b29, &vl[(ki + 1) * vl_dim1 + 1], ldvl,
&work[ki + 1 + iv * *n], &c__1, &work[ki + iv * *n],
&vl[ki * vl_dim1 + 1], &c__1, (ftnlen)1);
}
ii = idamax_(n, &vl[ki * vl_dim1 + 1], &c__1);
remax = 1. / (d__1 = vl[ii + ki * vl_dim1], abs(d__1));
dscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1);
} else {
i__3 = ki - 1;
for (k = 1; k <= i__3; ++k) {
work[k + iv * *n] = 0.;
}
iscomplex[iv - 1] = ip;
}
} else {
if ((d__1 = t[ki + (ki + 1) * t_dim1], abs(d__1)) >=
(d__2 = t[ki + 1 + ki * t_dim1], abs(d__2))) {
work[ki + iv * *n] = wi / t[ki + (ki + 1) * t_dim1];
work[ki + 1 + (iv + 1) * *n] = 1.;
} else {
work[ki + iv * *n] = 1.;
work[ki + 1 + (iv + 1) * *n] = -wi / t[ki + 1 + ki * t_dim1];
}
work[ki + 1 + iv * *n] = 0.;
work[ki + (iv + 1) * *n] = 0.;
i__3 = *n;
for (k = ki + 2; k <= i__3; ++k) {
work[k + iv * *n] = -work[ki + iv * *n] * t[ki + k * t_dim1];
work[k + (iv + 1) * *n] =
-work[ki + 1 + (iv + 1) * *n] * t[ki + 1 + k * t_dim1];
}
vmax = 1.;
vcrit = bignum;
jnxt = ki + 2;
i__3 = *n;
for (j = ki + 2; j <= i__3; ++j) {
if (j < jnxt) {
goto L200;
}
j1 = j;
j2 = j;
jnxt = j + 1;
if (j < *n) {
if (t[j + 1 + j * t_dim1] != 0.) {
j2 = j + 1;
jnxt = j + 2;
}
}
if (j1 == j2) {
if (work[j] > vcrit) {
rec = 1. / vmax;
i__4 = *n - ki + 1;
dscal_(&i__4, &rec, &work[ki + iv * *n], &c__1);
i__4 = *n - ki + 1;
dscal_(&i__4, &rec, &work[ki + (iv + 1) * *n], &c__1);
vmax = 1.;
vcrit = bignum;
}
i__4 = j - ki - 2;
work[j + iv * *n] -= ddot_(&i__4, &t[ki + 2 + j * t_dim1], &c__1,
&work[ki + 2 + iv * *n], &c__1);
i__4 = j - ki - 2;
work[j + (iv + 1) * *n] -= ddot_(&i__4, &t[ki + 2 + j * t_dim1], &c__1,
&work[ki + 2 + (iv + 1) * *n], &c__1);
d__1 = -wi;
dlaln2_(&c_false, &c__1, &c__2, &smin, &c_b29, &t[j + j * t_dim1], ldt,
&c_b29, &c_b29, &work[j + iv * *n], n, &wr, &d__1, x, &c__2, &scale,
&xnorm, &ierr);
if (scale != 1.) {
i__4 = *n - ki + 1;
dscal_(&i__4, &scale, &work[ki + iv * *n], &c__1);
i__4 = *n - ki + 1;
dscal_(&i__4, &scale, &work[ki + (iv + 1) * *n], &c__1);
}
work[j + iv * *n] = x[0];
work[j + (iv + 1) * *n] = x[2];
d__3 = (d__1 = work[j + iv * *n], abs(d__1)),
d__4 = (d__2 = work[j + (iv + 1) * *n], abs(d__2)), d__3 = max(d__3, d__4);
vmax = max(d__3, vmax);
vcrit = bignum / vmax;
} else {
d__1 = work[j], d__2 = work[j + 1];
beta = max(d__1, d__2);
if (beta > vcrit) {
rec = 1. / vmax;
i__4 = *n - ki + 1;
dscal_(&i__4, &rec, &work[ki + iv * *n], &c__1);
i__4 = *n - ki + 1;
dscal_(&i__4, &rec, &work[ki + (iv + 1) * *n], &c__1);
vmax = 1.;
vcrit = bignum;
}
i__4 = j - ki - 2;
work[j + iv * *n] -= ddot_(&i__4, &t[ki + 2 + j * t_dim1], &c__1,
&work[ki + 2 + iv * *n], &c__1);
i__4 = j - ki - 2;
work[j + (iv + 1) * *n] -= ddot_(&i__4, &t[ki + 2 + j * t_dim1], &c__1,
&work[ki + 2 + (iv + 1) * *n], &c__1);
i__4 = j - ki - 2;
work[j + 1 + iv * *n] -= ddot_(&i__4, &t[ki + 2 + (j + 1) * t_dim1], &c__1,
&work[ki + 2 + iv * *n], &c__1);
i__4 = j - ki - 2;
work[j + 1 + (iv + 1) * *n] -=
ddot_(&i__4, &t[ki + 2 + (j + 1) * t_dim1], &c__1,
&work[ki + 2 + (iv + 1) * *n], &c__1);
d__1 = -wi;
dlaln2_(&c_true, &c__2, &c__2, &smin, &c_b29, &t[j + j * t_dim1], ldt,
&c_b29, &c_b29, &work[j + iv * *n], n, &wr, &d__1, x, &c__2, &scale,
&xnorm, &ierr);
if (scale != 1.) {
i__4 = *n - ki + 1;
dscal_(&i__4, &scale, &work[ki + iv * *n], &c__1);
i__4 = *n - ki + 1;
dscal_(&i__4, &scale, &work[ki + (iv + 1) * *n], &c__1);
}
work[j + iv * *n] = x[0];
work[j + (iv + 1) * *n] = x[2];
work[j + 1 + iv * *n] = x[1];
work[j + 1 + (iv + 1) * *n] = x[3];
d__1 = abs(x[0]), d__2 = abs(x[2]), d__1 = max(d__1, d__2),
d__2 = abs(x[1]), d__1 = max(d__1, d__2), d__2 = abs(x[3]),
d__1 = max(d__1, d__2);
vmax = max(d__1, vmax);
vcrit = bignum / vmax;
}
L200:;
}
if (!over) {
i__3 = *n - ki + 1;
dcopy_(&i__3, &work[ki + iv * *n], &c__1, &vl[ki + is * vl_dim1], &c__1);
i__3 = *n - ki + 1;
dcopy_(&i__3, &work[ki + (iv + 1) * *n], &c__1, &vl[ki + (is + 1) * vl_dim1],
&c__1);
emax = 0.;
i__3 = *n;
for (k = ki; k <= i__3; ++k) {
d__3 = emax, d__4 = (d__1 = vl[k + is * vl_dim1], abs(d__1)) +
(d__2 = vl[k + (is + 1) * vl_dim1], abs(d__2));
emax = max(d__3, d__4);
}
remax = 1. / emax;
i__3 = *n - ki + 1;
dscal_(&i__3, &remax, &vl[ki + is * vl_dim1], &c__1);
i__3 = *n - ki + 1;
dscal_(&i__3, &remax, &vl[ki + (is + 1) * vl_dim1], &c__1);
i__3 = ki - 1;
for (k = 1; k <= i__3; ++k) {
vl[k + is * vl_dim1] = 0.;
vl[k + (is + 1) * vl_dim1] = 0.;
}
} else if (nb == 1) {
if (ki < *n - 1) {
i__3 = *n - ki - 1;
dgemv_((char *)"N", n, &i__3, &c_b29, &vl[(ki + 2) * vl_dim1 + 1], ldvl,
&work[ki + 2 + iv * *n], &c__1, &work[ki + iv * *n],
&vl[ki * vl_dim1 + 1], &c__1, (ftnlen)1);
i__3 = *n - ki - 1;
dgemv_((char *)"N", n, &i__3, &c_b29, &vl[(ki + 2) * vl_dim1 + 1], ldvl,
&work[ki + 2 + (iv + 1) * *n], &c__1, &work[ki + 1 + (iv + 1) * *n],
&vl[(ki + 1) * vl_dim1 + 1], &c__1, (ftnlen)1);
} else {
dscal_(n, &work[ki + iv * *n], &vl[ki * vl_dim1 + 1], &c__1);
dscal_(n, &work[ki + 1 + (iv + 1) * *n], &vl[(ki + 1) * vl_dim1 + 1],
&c__1);
}
emax = 0.;
i__3 = *n;
for (k = 1; k <= i__3; ++k) {
d__3 = emax, d__4 = (d__1 = vl[k + ki * vl_dim1], abs(d__1)) +
(d__2 = vl[k + (ki + 1) * vl_dim1], abs(d__2));
emax = max(d__3, d__4);
}
remax = 1. / emax;
dscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1);
dscal_(n, &remax, &vl[(ki + 1) * vl_dim1 + 1], &c__1);
} else {
i__3 = ki - 1;
for (k = 1; k <= i__3; ++k) {
work[k + iv * *n] = 0.;
work[k + (iv + 1) * *n] = 0.;
}
iscomplex[iv - 1] = ip;
iscomplex[iv] = -ip;
++iv;
}
}
if (nb > 1) {
if (ip == 0) {
ki2 = ki;
} else {
ki2 = ki + 1;
}
if (iv >= nb - 1 || ki2 == *n) {
i__3 = *n - ki2 + iv;
dgemm_((char *)"N", (char *)"N", n, &iv, &i__3, &c_b29, &vl[(ki2 - iv + 1) * vl_dim1 + 1], ldvl,
&work[ki2 - iv + 1 + *n], n, &c_b17, &work[(nb + 1) * *n + 1], n,
(ftnlen)1, (ftnlen)1);
i__3 = iv;
for (k = 1; k <= i__3; ++k) {
if (iscomplex[k - 1] == 0) {
ii = idamax_(n, &work[(nb + k) * *n + 1], &c__1);
remax = 1. / (d__1 = work[ii + (nb + k) * *n], abs(d__1));
} else if (iscomplex[k - 1] == 1) {
emax = 0.;
i__4 = *n;
for (ii = 1; ii <= i__4; ++ii) {
d__3 = emax,
d__4 = (d__1 = work[ii + (nb + k) * *n], abs(d__1)) +
(d__2 = work[ii + (nb + k + 1) * *n], abs(d__2));
emax = max(d__3, d__4);
}
remax = 1. / emax;
}
dscal_(n, &remax, &work[(nb + k) * *n + 1], &c__1);
}
dlacpy_((char *)"F", n, &iv, &work[(nb + 1) * *n + 1], n,
&vl[(ki2 - iv + 1) * vl_dim1 + 1], ldvl, (ftnlen)1);
iv = 1;
} else {
++iv;
}
}
++is;
if (ip != 0) {
++is;
}
L260:;
}
}
return 0;
}
#ifdef __cplusplus
}
#endif

217
lib/linalg/dtrexc.cpp Normal file
View File

@ -0,0 +1,217 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static integer c__1 = 1;
static integer c__2 = 2;
int dtrexc_(char *compq, integer *n, doublereal *t, integer *ldt, doublereal *q, integer *ldq,
integer *ifst, integer *ilst, doublereal *work, integer *info, ftnlen compq_len)
{
integer q_dim1, q_offset, t_dim1, t_offset, i__1;
integer nbf, nbl, here;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
logical wantq;
extern int dlaexc_(logical *, integer *, doublereal *, integer *, doublereal *, integer *,
integer *, integer *, integer *, doublereal *, integer *),
xerbla_(char *, integer *, ftnlen);
integer nbnext;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--work;
*info = 0;
wantq = lsame_(compq, (char *)"V", (ftnlen)1, (ftnlen)1);
if (!wantq && !lsame_(compq, (char *)"N", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ldt < max(1, *n)) {
*info = -4;
} else if (*ldq < 1 || wantq && *ldq < max(1, *n)) {
*info = -6;
} else if ((*ifst < 1 || *ifst > *n) && *n > 0) {
*info = -7;
} else if ((*ilst < 1 || *ilst > *n) && *n > 0) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"DTREXC", &i__1, (ftnlen)6);
return 0;
}
if (*n <= 1) {
return 0;
}
if (*ifst > 1) {
if (t[*ifst + (*ifst - 1) * t_dim1] != 0.) {
--(*ifst);
}
}
nbf = 1;
if (*ifst < *n) {
if (t[*ifst + 1 + *ifst * t_dim1] != 0.) {
nbf = 2;
}
}
if (*ilst > 1) {
if (t[*ilst + (*ilst - 1) * t_dim1] != 0.) {
--(*ilst);
}
}
nbl = 1;
if (*ilst < *n) {
if (t[*ilst + 1 + *ilst * t_dim1] != 0.) {
nbl = 2;
}
}
if (*ifst == *ilst) {
return 0;
}
if (*ifst < *ilst) {
if (nbf == 2 && nbl == 1) {
--(*ilst);
}
if (nbf == 1 && nbl == 2) {
++(*ilst);
}
here = *ifst;
L10:
if (nbf == 1 || nbf == 2) {
nbnext = 1;
if (here + nbf + 1 <= *n) {
if (t[here + nbf + 1 + (here + nbf) * t_dim1] != 0.) {
nbnext = 2;
}
}
dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &here, &nbf, &nbnext, &work[1],
info);
if (*info != 0) {
*ilst = here;
return 0;
}
here += nbnext;
if (nbf == 2) {
if (t[here + 1 + here * t_dim1] == 0.) {
nbf = 3;
}
}
} else {
nbnext = 1;
if (here + 3 <= *n) {
if (t[here + 3 + (here + 2) * t_dim1] != 0.) {
nbnext = 2;
}
}
i__1 = here + 1;
dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, &c__1, &nbnext,
&work[1], info);
if (*info != 0) {
*ilst = here;
return 0;
}
if (nbnext == 1) {
dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &here, &c__1, &nbnext,
&work[1], info);
++here;
} else {
if (t[here + 2 + (here + 1) * t_dim1] == 0.) {
nbnext = 1;
}
if (nbnext == 2) {
dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &here, &c__1, &nbnext,
&work[1], info);
if (*info != 0) {
*ilst = here;
return 0;
}
here += 2;
} else {
dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &here, &c__1, &c__1,
&work[1], info);
i__1 = here + 1;
dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, &c__1, &c__1,
&work[1], info);
here += 2;
}
}
}
if (here < *ilst) {
goto L10;
}
} else {
here = *ifst;
L20:
if (nbf == 1 || nbf == 2) {
nbnext = 1;
if (here >= 3) {
if (t[here - 1 + (here - 2) * t_dim1] != 0.) {
nbnext = 2;
}
}
i__1 = here - nbnext;
dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, &nbnext, &nbf, &work[1],
info);
if (*info != 0) {
*ilst = here;
return 0;
}
here -= nbnext;
if (nbf == 2) {
if (t[here + 1 + here * t_dim1] == 0.) {
nbf = 3;
}
}
} else {
nbnext = 1;
if (here >= 3) {
if (t[here - 1 + (here - 2) * t_dim1] != 0.) {
nbnext = 2;
}
}
i__1 = here - nbnext;
dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, &nbnext, &c__1,
&work[1], info);
if (*info != 0) {
*ilst = here;
return 0;
}
if (nbnext == 1) {
dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &here, &nbnext, &c__1,
&work[1], info);
--here;
} else {
if (t[here + (here - 1) * t_dim1] == 0.) {
nbnext = 1;
}
if (nbnext == 2) {
i__1 = here - 1;
dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, &c__2, &c__1,
&work[1], info);
if (*info != 0) {
*ilst = here;
return 0;
}
here += -2;
} else {
dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &here, &c__1, &c__1,
&work[1], info);
i__1 = here - 1;
dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, &c__1, &c__1,
&work[1], info);
here += -2;
}
}
}
if (here > *ilst) {
goto L20;
}
}
*ilst = here;
return 0;
}
#ifdef __cplusplus
}
#endif

65
lib/linalg/dtrtrs.cpp Normal file
View File

@ -0,0 +1,65 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static doublereal c_b12 = 1.;
int dtrtrs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, doublereal *a,
integer *lda, doublereal *b, integer *ldb, integer *info, ftnlen uplo_len,
ftnlen trans_len, ftnlen diag_len)
{
integer a_dim1, a_offset, b_dim1, b_offset, i__1;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern int dtrsm_(char *, char *, char *, char *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen,
ftnlen),
xerbla_(char *, integer *, ftnlen);
logical nounit;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
*info = 0;
nounit = lsame_(diag, (char *)"N", (ftnlen)1, (ftnlen)1);
if (!lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1) && !lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (!lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1) &&
!lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1) &&
!lsame_(trans, (char *)"C", (ftnlen)1, (ftnlen)1)) {
*info = -2;
} else if (!nounit && !lsame_(diag, (char *)"U", (ftnlen)1, (ftnlen)1)) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*nrhs < 0) {
*info = -5;
} else if (*lda < max(1, *n)) {
*info = -7;
} else if (*ldb < max(1, *n)) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"DTRTRS", &i__1, (ftnlen)6);
return 0;
}
if (*n == 0) {
return 0;
}
if (nounit) {
i__1 = *n;
for (*info = 1; *info <= i__1; ++(*info)) {
if (a[*info + *info * a_dim1] == 0.) {
return 0;
}
}
}
*info = 0;
dtrsm_((char *)"Left", uplo, trans, diag, n, nrhs, &c_b12, &a[a_offset], lda, &b[b_offset], ldb,
(ftnlen)4, (ftnlen)1, (ftnlen)1, (ftnlen)1);
return 0;
}
#ifdef __cplusplus
}
#endif

46
lib/linalg/izamax.cpp Normal file
View File

@ -0,0 +1,46 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
integer izamax_(integer *n, doublecomplex *zx, integer *incx)
{
integer ret_val, i__1;
integer i__, ix;
doublereal dmax__;
extern doublereal dcabs1_(doublecomplex *);
--zx;
ret_val = 0;
if (*n < 1 || *incx <= 0) {
return ret_val;
}
ret_val = 1;
if (*n == 1) {
return ret_val;
}
if (*incx == 1) {
dmax__ = dcabs1_(&zx[1]);
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
if (dcabs1_(&zx[i__]) > dmax__) {
ret_val = i__;
dmax__ = dcabs1_(&zx[i__]);
}
}
} else {
ix = 1;
dmax__ = dcabs1_(&zx[1]);
ix += *incx;
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
if (dcabs1_(&zx[ix]) > dmax__) {
ret_val = i__;
dmax__ = dcabs1_(&zx[ix]);
}
ix += *incx;
}
}
return ret_val;
}
#ifdef __cplusplus
}
#endif

43
lib/linalg/zcop.cpp Normal file
View File

@ -0,0 +1,43 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
int zcopy_(integer *n, doublecomplex *zx, integer *incx, doublecomplex *zy, integer *incy)
{
integer i__1, i__2, i__3;
integer i__, ix, iy;
--zy;
--zx;
if (*n <= 0) {
return 0;
}
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__;
zy[i__2].r = zx[i__3].r, zy[i__2].i = zx[i__3].i;
}
} else {
ix = 1;
iy = 1;
if (*incx < 0) {
ix = (-(*n) + 1) * *incx + 1;
}
if (*incy < 0) {
iy = (-(*n) + 1) * *incy + 1;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iy;
i__3 = ix;
zy[i__2].r = zx[i__3].r, zy[i__2].i = zx[i__3].i;
ix += *incx;
iy += *incy;
}
}
return 0;
}
#ifdef __cplusplus
}
#endif

55
lib/linalg/zdotu.cpp Normal file
View File

@ -0,0 +1,55 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
VOID zdotu_(doublecomplex *ret_val, integer *n, doublecomplex *zx, integer *incx, doublecomplex *zy,
integer *incy)
{
integer i__1, i__2, i__3;
doublecomplex z__1, z__2;
integer i__, ix, iy;
doublecomplex ztemp;
--zy;
--zx;
ztemp.r = 0., ztemp.i = 0.;
ret_val->r = 0., ret_val->i = 0.;
if (*n <= 0) {
return;
}
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__;
z__2.r = zx[i__2].r * zy[i__3].r - zx[i__2].i * zy[i__3].i,
z__2.i = zx[i__2].r * zy[i__3].i + zx[i__2].i * zy[i__3].r;
z__1.r = ztemp.r + z__2.r, z__1.i = ztemp.i + z__2.i;
ztemp.r = z__1.r, ztemp.i = z__1.i;
}
} else {
ix = 1;
iy = 1;
if (*incx < 0) {
ix = (-(*n) + 1) * *incx + 1;
}
if (*incy < 0) {
iy = (-(*n) + 1) * *incy + 1;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = ix;
i__3 = iy;
z__2.r = zx[i__2].r * zy[i__3].r - zx[i__2].i * zy[i__3].i,
z__2.i = zx[i__2].r * zy[i__3].i + zx[i__2].i * zy[i__3].r;
z__1.r = ztemp.r + z__2.r, z__1.i = ztemp.i + z__2.i;
ztemp.r = z__1.r, ztemp.i = z__1.i;
ix += *incx;
iy += *incy;
}
}
ret_val->r = ztemp.r, ret_val->i = ztemp.i;
return;
}
#ifdef __cplusplus
}
#endif

90
lib/linalg/zgetrf.cpp Normal file
View File

@ -0,0 +1,90 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static doublecomplex c_b1 = {1., 0.};
static integer c__1 = 1;
static integer c_n1 = -1;
int zgetrf_(integer *m, integer *n, doublecomplex *a, integer *lda, integer *ipiv, integer *info)
{
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
doublecomplex z__1;
integer i__, j, jb, nb, iinfo;
extern int zgemm_(char *, char *, integer *, integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, ftnlen, ftnlen),
ztrsm_(char *, char *, char *, char *, integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, ftnlen, ftnlen, ftnlen,
ftnlen),
xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
extern int zlaswp_(integer *, doublecomplex *, integer *, integer *, integer *, integer *,
integer *),
zgetrf2_(integer *, integer *, doublecomplex *, integer *, integer *, integer *);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1, *m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"ZGETRF", &i__1, (ftnlen)6);
return 0;
}
if (*m == 0 || *n == 0) {
return 0;
}
nb = ilaenv_(&c__1, (char *)"ZGETRF", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
if (nb <= 1 || nb >= min(*m, *n)) {
zgetrf2_(m, n, &a[a_offset], lda, &ipiv[1], info);
} else {
i__1 = min(*m, *n);
i__2 = nb;
for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
i__3 = min(*m, *n) - j + 1;
jb = min(i__3, nb);
i__3 = *m - j + 1;
zgetrf2_(&i__3, &jb, &a[j + j * a_dim1], lda, &ipiv[j], &iinfo);
if (*info == 0 && iinfo > 0) {
*info = iinfo + j - 1;
}
i__4 = *m, i__5 = j + jb - 1;
i__3 = min(i__4, i__5);
for (i__ = j; i__ <= i__3; ++i__) {
ipiv[i__] = j - 1 + ipiv[i__];
}
i__3 = j - 1;
i__4 = j + jb - 1;
zlaswp_(&i__3, &a[a_offset], lda, &j, &i__4, &ipiv[1], &c__1);
if (j + jb <= *n) {
i__3 = *n - j - jb + 1;
i__4 = j + jb - 1;
zlaswp_(&i__3, &a[(j + jb) * a_dim1 + 1], lda, &j, &i__4, &ipiv[1], &c__1);
i__3 = *n - j - jb + 1;
ztrsm_((char *)"Left", (char *)"Lower", (char *)"No transpose", (char *)"Unit", &jb, &i__3, &c_b1,
&a[j + j * a_dim1], lda, &a[j + (j + jb) * a_dim1], lda, (ftnlen)4,
(ftnlen)5, (ftnlen)12, (ftnlen)4);
if (j + jb <= *m) {
i__3 = *m - j - jb + 1;
i__4 = *n - j - jb + 1;
z__1.r = -1., z__1.i = -0.;
zgemm_((char *)"No transpose", (char *)"No transpose", &i__3, &i__4, &jb, &z__1,
&a[j + jb + j * a_dim1], lda, &a[j + (j + jb) * a_dim1], lda, &c_b1,
&a[j + jb + (j + jb) * a_dim1], lda, (ftnlen)12, (ftnlen)12);
}
}
}
}
return 0;
}
#ifdef __cplusplus
}
#endif

117
lib/linalg/zgetrf2.cpp Normal file
View File

@ -0,0 +1,117 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static doublecomplex c_b1 = {1., 0.};
static integer c__1 = 1;
int zgetrf2_(integer *m, integer *n, doublecomplex *a, integer *lda, integer *ipiv, integer *info)
{
integer a_dim1, a_offset, i__1, i__2;
doublecomplex z__1;
double z_lmp_abs(doublecomplex *);
void z_lmp_div(doublecomplex *, doublecomplex *, doublecomplex *);
integer i__, n1, n2;
doublecomplex temp;
integer iinfo;
doublereal sfmin;
extern int zscal_(integer *, doublecomplex *, doublecomplex *, integer *),
zgemm_(char *, char *, integer *, integer *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *,
ftnlen, ftnlen),
ztrsm_(char *, char *, char *, char *, integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, ftnlen, ftnlen, ftnlen,
ftnlen);
extern doublereal dlamch_(char *, ftnlen);
extern int xerbla_(char *, integer *, ftnlen);
extern integer izamax_(integer *, doublecomplex *, integer *);
extern int zlaswp_(integer *, doublecomplex *, integer *, integer *, integer *, integer *,
integer *);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1, *m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"ZGETRF2", &i__1, (ftnlen)7);
return 0;
}
if (*m == 0 || *n == 0) {
return 0;
}
if (*m == 1) {
ipiv[1] = 1;
i__1 = a_dim1 + 1;
if (a[i__1].r == 0. && a[i__1].i == 0.) {
*info = 1;
}
} else if (*n == 1) {
sfmin = dlamch_((char *)"S", (ftnlen)1);
i__ = izamax_(m, &a[a_dim1 + 1], &c__1);
ipiv[1] = i__;
i__1 = i__ + a_dim1;
if (a[i__1].r != 0. || a[i__1].i != 0.) {
if (i__ != 1) {
i__1 = a_dim1 + 1;
temp.r = a[i__1].r, temp.i = a[i__1].i;
i__1 = a_dim1 + 1;
i__2 = i__ + a_dim1;
a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
i__1 = i__ + a_dim1;
a[i__1].r = temp.r, a[i__1].i = temp.i;
}
if (z_lmp_abs(&a[a_dim1 + 1]) >= sfmin) {
i__1 = *m - 1;
z_lmp_div(&z__1, &c_b1, &a[a_dim1 + 1]);
zscal_(&i__1, &z__1, &a[a_dim1 + 2], &c__1);
} else {
i__1 = *m - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + 1 + a_dim1;
z_lmp_div(&z__1, &a[i__ + 1 + a_dim1], &a[a_dim1 + 1]);
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
}
} else {
*info = 1;
}
} else {
n1 = min(*m, *n) / 2;
n2 = *n - n1;
zgetrf2_(m, &n1, &a[a_offset], lda, &ipiv[1], &iinfo);
if (*info == 0 && iinfo > 0) {
*info = iinfo;
}
zlaswp_(&n2, &a[(n1 + 1) * a_dim1 + 1], lda, &c__1, &n1, &ipiv[1], &c__1);
ztrsm_((char *)"L", (char *)"L", (char *)"N", (char *)"U", &n1, &n2, &c_b1, &a[a_offset], lda, &a[(n1 + 1) * a_dim1 + 1],
lda, (ftnlen)1, (ftnlen)1, (ftnlen)1, (ftnlen)1);
i__1 = *m - n1;
z__1.r = -1., z__1.i = -0.;
zgemm_((char *)"N", (char *)"N", &i__1, &n2, &n1, &z__1, &a[n1 + 1 + a_dim1], lda,
&a[(n1 + 1) * a_dim1 + 1], lda, &c_b1, &a[n1 + 1 + (n1 + 1) * a_dim1], lda,
(ftnlen)1, (ftnlen)1);
i__1 = *m - n1;
zgetrf2_(&i__1, &n2, &a[n1 + 1 + (n1 + 1) * a_dim1], lda, &ipiv[n1 + 1], &iinfo);
if (*info == 0 && iinfo > 0) {
*info = iinfo + n1;
}
i__1 = min(*m, *n);
for (i__ = n1 + 1; i__ <= i__1; ++i__) {
ipiv[i__] += n1;
}
i__1 = n1 + 1;
i__2 = min(*m, *n);
zlaswp_(&n1, &a[a_dim1 + 1], lda, &i__1, &i__2, &ipiv[1], &c__1);
}
return 0;
}
#ifdef __cplusplus
}
#endif

132
lib/linalg/zgetri.cpp Normal file
View File

@ -0,0 +1,132 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static doublecomplex c_b2 = {1., 0.};
static integer c__1 = 1;
static integer c_n1 = -1;
static integer c__2 = 2;
int zgetri_(integer *n, doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *work,
integer *lwork, integer *info)
{
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
doublecomplex z__1;
integer i__, j, jb, nb, jj, jp, nn, iws, nbmin;
extern int zgemm_(char *, char *, integer *, integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, ftnlen, ftnlen),
zgemv_(char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, ftnlen),
zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *),
ztrsm_(char *, char *, char *, char *, integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, ftnlen, ftnlen, ftnlen,
ftnlen),
xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
integer ldwork, lwkopt;
logical lquery;
extern int ztrtri_(char *, char *, integer *, doublecomplex *, integer *, integer *, ftnlen,
ftnlen);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
--work;
*info = 0;
nb = ilaenv_(&c__1, (char *)"ZGETRI", (char *)" ", n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
lwkopt = *n * nb;
work[1].r = (doublereal)lwkopt, work[1].i = 0.;
lquery = *lwork == -1;
if (*n < 0) {
*info = -1;
} else if (*lda < max(1, *n)) {
*info = -3;
} else if (*lwork < max(1, *n) && !lquery) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"ZGETRI", &i__1, (ftnlen)6);
return 0;
} else if (lquery) {
return 0;
}
if (*n == 0) {
return 0;
}
ztrtri_((char *)"Upper", (char *)"Non-unit", n, &a[a_offset], lda, info, (ftnlen)5, (ftnlen)8);
if (*info > 0) {
return 0;
}
nbmin = 2;
ldwork = *n;
if (nb > 1 && nb < *n) {
i__1 = ldwork * nb;
iws = max(i__1, 1);
if (*lwork < iws) {
nb = *lwork / ldwork;
i__1 = 2,
i__2 = ilaenv_(&c__2, (char *)"ZGETRI", (char *)" ", n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
nbmin = max(i__1, i__2);
}
} else {
iws = *n;
}
if (nb < nbmin || nb >= *n) {
for (j = *n; j >= 1; --j) {
i__1 = *n;
for (i__ = j + 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__ + j * a_dim1;
work[i__2].r = a[i__3].r, work[i__2].i = a[i__3].i;
i__2 = i__ + j * a_dim1;
a[i__2].r = 0., a[i__2].i = 0.;
}
if (j < *n) {
i__1 = *n - j;
z__1.r = -1., z__1.i = -0.;
zgemv_((char *)"No transpose", n, &i__1, &z__1, &a[(j + 1) * a_dim1 + 1], lda, &work[j + 1],
&c__1, &c_b2, &a[j * a_dim1 + 1], &c__1, (ftnlen)12);
}
}
} else {
nn = (*n - 1) / nb * nb + 1;
i__1 = -nb;
for (j = nn; i__1 < 0 ? j >= 1 : j <= 1; j += i__1) {
i__2 = nb, i__3 = *n - j + 1;
jb = min(i__2, i__3);
i__2 = j + jb - 1;
for (jj = j; jj <= i__2; ++jj) {
i__3 = *n;
for (i__ = jj + 1; i__ <= i__3; ++i__) {
i__4 = i__ + (jj - j) * ldwork;
i__5 = i__ + jj * a_dim1;
work[i__4].r = a[i__5].r, work[i__4].i = a[i__5].i;
i__4 = i__ + jj * a_dim1;
a[i__4].r = 0., a[i__4].i = 0.;
}
}
if (j + jb <= *n) {
i__2 = *n - j - jb + 1;
z__1.r = -1., z__1.i = -0.;
zgemm_((char *)"No transpose", (char *)"No transpose", n, &jb, &i__2, &z__1,
&a[(j + jb) * a_dim1 + 1], lda, &work[j + jb], &ldwork, &c_b2,
&a[j * a_dim1 + 1], lda, (ftnlen)12, (ftnlen)12);
}
ztrsm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", n, &jb, &c_b2, &work[j], &ldwork,
&a[j * a_dim1 + 1], lda, (ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4);
}
}
for (j = *n - 1; j >= 1; --j) {
jp = ipiv[j];
if (jp != j) {
zswap_(n, &a[j * a_dim1 + 1], &c__1, &a[jp * a_dim1 + 1], &c__1);
}
}
work[1].r = (doublereal)iws, work[1].i = 0.;
return 0;
}
#ifdef __cplusplus
}
#endif

197
lib/linalg/zhegs2.cpp Normal file
View File

@ -0,0 +1,197 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static doublecomplex c_b1 = {1., 0.};
static integer c__1 = 1;
int zhegs2_(integer *itype, char *uplo, integer *n, doublecomplex *a, integer *lda,
doublecomplex *b, integer *ldb, integer *info, ftnlen uplo_len)
{
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
doublereal d__1, d__2;
doublecomplex z__1;
integer k;
doublecomplex ct;
doublereal akk, bkk;
extern int zher2_(char *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, ftnlen);
extern logical lsame_(char *, char *, ftnlen, ftnlen);
logical upper;
extern int zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *),
ztrmv_(char *, char *, char *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *, ftnlen, ftnlen, ftnlen),
ztrsv_(char *, char *, char *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *, ftnlen, ftnlen, ftnlen),
xerbla_(char *, integer *, ftnlen),
zdscal_(integer *, doublereal *, doublecomplex *, integer *),
zlacgv_(integer *, doublecomplex *, integer *);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
*info = 0;
upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1);
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (!upper && !lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1, *n)) {
*info = -5;
} else if (*ldb < max(1, *n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"ZHEGS2", &i__1, (ftnlen)6);
return 0;
}
if (*itype == 1) {
if (upper) {
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
i__2 = k + k * a_dim1;
akk = a[i__2].r;
i__2 = k + k * b_dim1;
bkk = b[i__2].r;
d__1 = bkk;
akk /= d__1 * d__1;
i__2 = k + k * a_dim1;
a[i__2].r = akk, a[i__2].i = 0.;
if (k < *n) {
i__2 = *n - k;
d__1 = 1. / bkk;
zdscal_(&i__2, &d__1, &a[k + (k + 1) * a_dim1], lda);
d__1 = akk * -.5;
ct.r = d__1, ct.i = 0.;
i__2 = *n - k;
zlacgv_(&i__2, &a[k + (k + 1) * a_dim1], lda);
i__2 = *n - k;
zlacgv_(&i__2, &b[k + (k + 1) * b_dim1], ldb);
i__2 = *n - k;
zaxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + (k + 1) * a_dim1],
lda);
i__2 = *n - k;
z__1.r = -1., z__1.i = -0.;
zher2_(uplo, &i__2, &z__1, &a[k + (k + 1) * a_dim1], lda,
&b[k + (k + 1) * b_dim1], ldb, &a[k + 1 + (k + 1) * a_dim1], lda,
(ftnlen)1);
i__2 = *n - k;
zaxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + (k + 1) * a_dim1],
lda);
i__2 = *n - k;
zlacgv_(&i__2, &b[k + (k + 1) * b_dim1], ldb);
i__2 = *n - k;
ztrsv_(uplo, (char *)"Conjugate transpose", (char *)"Non-unit", &i__2,
&b[k + 1 + (k + 1) * b_dim1], ldb, &a[k + (k + 1) * a_dim1], lda,
(ftnlen)1, (ftnlen)19, (ftnlen)8);
i__2 = *n - k;
zlacgv_(&i__2, &a[k + (k + 1) * a_dim1], lda);
}
}
} else {
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
i__2 = k + k * a_dim1;
akk = a[i__2].r;
i__2 = k + k * b_dim1;
bkk = b[i__2].r;
d__1 = bkk;
akk /= d__1 * d__1;
i__2 = k + k * a_dim1;
a[i__2].r = akk, a[i__2].i = 0.;
if (k < *n) {
i__2 = *n - k;
d__1 = 1. / bkk;
zdscal_(&i__2, &d__1, &a[k + 1 + k * a_dim1], &c__1);
d__1 = akk * -.5;
ct.r = d__1, ct.i = 0.;
i__2 = *n - k;
zaxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k + 1 + k * a_dim1],
&c__1);
i__2 = *n - k;
z__1.r = -1., z__1.i = -0.;
zher2_(uplo, &i__2, &z__1, &a[k + 1 + k * a_dim1], &c__1,
&b[k + 1 + k * b_dim1], &c__1, &a[k + 1 + (k + 1) * a_dim1], lda,
(ftnlen)1);
i__2 = *n - k;
zaxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k + 1 + k * a_dim1],
&c__1);
i__2 = *n - k;
ztrsv_(uplo, (char *)"No transpose", (char *)"Non-unit", &i__2, &b[k + 1 + (k + 1) * b_dim1],
ldb, &a[k + 1 + k * a_dim1], &c__1, (ftnlen)1, (ftnlen)12, (ftnlen)8);
}
}
}
} else {
if (upper) {
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
i__2 = k + k * a_dim1;
akk = a[i__2].r;
i__2 = k + k * b_dim1;
bkk = b[i__2].r;
i__2 = k - 1;
ztrmv_(uplo, (char *)"No transpose", (char *)"Non-unit", &i__2, &b[b_offset], ldb,
&a[k * a_dim1 + 1], &c__1, (ftnlen)1, (ftnlen)12, (ftnlen)8);
d__1 = akk * .5;
ct.r = d__1, ct.i = 0.;
i__2 = k - 1;
zaxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1);
i__2 = k - 1;
zher2_(uplo, &i__2, &c_b1, &a[k * a_dim1 + 1], &c__1, &b[k * b_dim1 + 1], &c__1,
&a[a_offset], lda, (ftnlen)1);
i__2 = k - 1;
zaxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1);
i__2 = k - 1;
zdscal_(&i__2, &bkk, &a[k * a_dim1 + 1], &c__1);
i__2 = k + k * a_dim1;
d__2 = bkk;
d__1 = akk * (d__2 * d__2);
a[i__2].r = d__1, a[i__2].i = 0.;
}
} else {
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
i__2 = k + k * a_dim1;
akk = a[i__2].r;
i__2 = k + k * b_dim1;
bkk = b[i__2].r;
i__2 = k - 1;
zlacgv_(&i__2, &a[k + a_dim1], lda);
i__2 = k - 1;
ztrmv_(uplo, (char *)"Conjugate transpose", (char *)"Non-unit", &i__2, &b[b_offset], ldb,
&a[k + a_dim1], lda, (ftnlen)1, (ftnlen)19, (ftnlen)8);
d__1 = akk * .5;
ct.r = d__1, ct.i = 0.;
i__2 = k - 1;
zlacgv_(&i__2, &b[k + b_dim1], ldb);
i__2 = k - 1;
zaxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda);
i__2 = k - 1;
zher2_(uplo, &i__2, &c_b1, &a[k + a_dim1], lda, &b[k + b_dim1], ldb, &a[a_offset],
lda, (ftnlen)1);
i__2 = k - 1;
zaxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda);
i__2 = k - 1;
zlacgv_(&i__2, &b[k + b_dim1], ldb);
i__2 = k - 1;
zdscal_(&i__2, &bkk, &a[k + a_dim1], lda);
i__2 = k - 1;
zlacgv_(&i__2, &a[k + a_dim1], lda);
i__2 = k + k * a_dim1;
d__2 = bkk;
d__1 = akk * (d__2 * d__2);
a[i__2].r = d__1, a[i__2].i = 0.;
}
}
}
return 0;
}
#ifdef __cplusplus
}
#endif

195
lib/linalg/zhegst.cpp Normal file
View File

@ -0,0 +1,195 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static doublecomplex c_b1 = {1., 0.};
static doublecomplex c_b2 = {.5, 0.};
static integer c__1 = 1;
static integer c_n1 = -1;
static doublereal c_b18 = 1.;
int zhegst_(integer *itype, char *uplo, integer *n, doublecomplex *a, integer *lda,
doublecomplex *b, integer *ldb, integer *info, ftnlen uplo_len)
{
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
doublecomplex z__1;
integer k, kb, nb;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern int zhemm_(char *, char *, integer *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, ftnlen, ftnlen);
logical upper;
extern int ztrmm_(char *, char *, char *, char *, integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, ftnlen, ftnlen,
ftnlen, ftnlen),
ztrsm_(char *, char *, char *, char *, integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, ftnlen, ftnlen, ftnlen,
ftnlen),
zhegs2_(integer *, char *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *, integer *, ftnlen),
zher2k_(char *, char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, doublecomplex *, integer *, ftnlen,
ftnlen),
xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
*info = 0;
upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1);
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (!upper && !lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1, *n)) {
*info = -5;
} else if (*ldb < max(1, *n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"ZHEGST", &i__1, (ftnlen)6);
return 0;
}
if (*n == 0) {
return 0;
}
nb = ilaenv_(&c__1, (char *)"ZHEGST", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
if (nb <= 1 || nb >= *n) {
zhegs2_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info, (ftnlen)1);
} else {
if (*itype == 1) {
if (upper) {
i__1 = *n;
i__2 = nb;
for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
i__3 = *n - k + 1;
kb = min(i__3, nb);
zhegs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + k * b_dim1], ldb,
info, (ftnlen)1);
if (k + kb <= *n) {
i__3 = *n - k - kb + 1;
ztrsm_((char *)"L", uplo, (char *)"C", (char *)"N", &kb, &i__3, &c_b1, &b[k + k * b_dim1], ldb,
&a[k + (k + kb) * a_dim1], lda, (ftnlen)1, (ftnlen)1, (ftnlen)1,
(ftnlen)1);
i__3 = *n - k - kb + 1;
z__1.r = -.5, z__1.i = -0.;
zhemm_((char *)"L", uplo, &kb, &i__3, &z__1, &a[k + k * a_dim1], lda,
&b[k + (k + kb) * b_dim1], ldb, &c_b1, &a[k + (k + kb) * a_dim1],
lda, (ftnlen)1, (ftnlen)1);
i__3 = *n - k - kb + 1;
z__1.r = -1., z__1.i = -0.;
zher2k_(uplo, (char *)"C", &i__3, &kb, &z__1, &a[k + (k + kb) * a_dim1], lda,
&b[k + (k + kb) * b_dim1], ldb, &c_b18,
&a[k + kb + (k + kb) * a_dim1], lda, (ftnlen)1, (ftnlen)1);
i__3 = *n - k - kb + 1;
z__1.r = -.5, z__1.i = -0.;
zhemm_((char *)"L", uplo, &kb, &i__3, &z__1, &a[k + k * a_dim1], lda,
&b[k + (k + kb) * b_dim1], ldb, &c_b1, &a[k + (k + kb) * a_dim1],
lda, (ftnlen)1, (ftnlen)1);
i__3 = *n - k - kb + 1;
ztrsm_((char *)"R", uplo, (char *)"N", (char *)"N", &kb, &i__3, &c_b1,
&b[k + kb + (k + kb) * b_dim1], ldb, &a[k + (k + kb) * a_dim1], lda,
(ftnlen)1, (ftnlen)1, (ftnlen)1, (ftnlen)1);
}
}
} else {
i__2 = *n;
i__1 = nb;
for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
i__3 = *n - k + 1;
kb = min(i__3, nb);
zhegs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + k * b_dim1], ldb,
info, (ftnlen)1);
if (k + kb <= *n) {
i__3 = *n - k - kb + 1;
ztrsm_((char *)"R", uplo, (char *)"C", (char *)"N", &i__3, &kb, &c_b1, &b[k + k * b_dim1], ldb,
&a[k + kb + k * a_dim1], lda, (ftnlen)1, (ftnlen)1, (ftnlen)1,
(ftnlen)1);
i__3 = *n - k - kb + 1;
z__1.r = -.5, z__1.i = -0.;
zhemm_((char *)"R", uplo, &i__3, &kb, &z__1, &a[k + k * a_dim1], lda,
&b[k + kb + k * b_dim1], ldb, &c_b1, &a[k + kb + k * a_dim1], lda,
(ftnlen)1, (ftnlen)1);
i__3 = *n - k - kb + 1;
z__1.r = -1., z__1.i = -0.;
zher2k_(uplo, (char *)"N", &i__3, &kb, &z__1, &a[k + kb + k * a_dim1], lda,
&b[k + kb + k * b_dim1], ldb, &c_b18,
&a[k + kb + (k + kb) * a_dim1], lda, (ftnlen)1, (ftnlen)1);
i__3 = *n - k - kb + 1;
z__1.r = -.5, z__1.i = -0.;
zhemm_((char *)"R", uplo, &i__3, &kb, &z__1, &a[k + k * a_dim1], lda,
&b[k + kb + k * b_dim1], ldb, &c_b1, &a[k + kb + k * a_dim1], lda,
(ftnlen)1, (ftnlen)1);
i__3 = *n - k - kb + 1;
ztrsm_((char *)"L", uplo, (char *)"N", (char *)"N", &i__3, &kb, &c_b1,
&b[k + kb + (k + kb) * b_dim1], ldb, &a[k + kb + k * a_dim1], lda,
(ftnlen)1, (ftnlen)1, (ftnlen)1, (ftnlen)1);
}
}
}
} else {
if (upper) {
i__1 = *n;
i__2 = nb;
for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
i__3 = *n - k + 1;
kb = min(i__3, nb);
i__3 = k - 1;
ztrmm_((char *)"L", uplo, (char *)"N", (char *)"N", &i__3, &kb, &c_b1, &b[b_offset], ldb,
&a[k * a_dim1 + 1], lda, (ftnlen)1, (ftnlen)1, (ftnlen)1, (ftnlen)1);
i__3 = k - 1;
zhemm_((char *)"R", uplo, &i__3, &kb, &c_b2, &a[k + k * a_dim1], lda,
&b[k * b_dim1 + 1], ldb, &c_b1, &a[k * a_dim1 + 1], lda, (ftnlen)1,
(ftnlen)1);
i__3 = k - 1;
zher2k_(uplo, (char *)"N", &i__3, &kb, &c_b1, &a[k * a_dim1 + 1], lda,
&b[k * b_dim1 + 1], ldb, &c_b18, &a[a_offset], lda, (ftnlen)1,
(ftnlen)1);
i__3 = k - 1;
zhemm_((char *)"R", uplo, &i__3, &kb, &c_b2, &a[k + k * a_dim1], lda,
&b[k * b_dim1 + 1], ldb, &c_b1, &a[k * a_dim1 + 1], lda, (ftnlen)1,
(ftnlen)1);
i__3 = k - 1;
ztrmm_((char *)"R", uplo, (char *)"C", (char *)"N", &i__3, &kb, &c_b1, &b[k + k * b_dim1], ldb,
&a[k * a_dim1 + 1], lda, (ftnlen)1, (ftnlen)1, (ftnlen)1, (ftnlen)1);
zhegs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + k * b_dim1], ldb,
info, (ftnlen)1);
}
} else {
i__2 = *n;
i__1 = nb;
for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
i__3 = *n - k + 1;
kb = min(i__3, nb);
i__3 = k - 1;
ztrmm_((char *)"R", uplo, (char *)"N", (char *)"N", &kb, &i__3, &c_b1, &b[b_offset], ldb,
&a[k + a_dim1], lda, (ftnlen)1, (ftnlen)1, (ftnlen)1, (ftnlen)1);
i__3 = k - 1;
zhemm_((char *)"L", uplo, &kb, &i__3, &c_b2, &a[k + k * a_dim1], lda, &b[k + b_dim1],
ldb, &c_b1, &a[k + a_dim1], lda, (ftnlen)1, (ftnlen)1);
i__3 = k - 1;
zher2k_(uplo, (char *)"C", &i__3, &kb, &c_b1, &a[k + a_dim1], lda, &b[k + b_dim1], ldb,
&c_b18, &a[a_offset], lda, (ftnlen)1, (ftnlen)1);
i__3 = k - 1;
zhemm_((char *)"L", uplo, &kb, &i__3, &c_b2, &a[k + k * a_dim1], lda, &b[k + b_dim1],
ldb, &c_b1, &a[k + a_dim1], lda, (ftnlen)1, (ftnlen)1);
i__3 = k - 1;
ztrmm_((char *)"L", uplo, (char *)"C", (char *)"N", &kb, &i__3, &c_b1, &b[k + k * b_dim1], ldb,
&a[k + a_dim1], lda, (ftnlen)1, (ftnlen)1, (ftnlen)1, (ftnlen)1);
zhegs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + k * b_dim1], ldb,
info, (ftnlen)1);
}
}
}
}
return 0;
}
#ifdef __cplusplus
}
#endif

115
lib/linalg/zhegv.cpp Normal file
View File

@ -0,0 +1,115 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static doublecomplex c_b1 = {1., 0.};
static integer c__1 = 1;
static integer c_n1 = -1;
int zhegv_(integer *itype, char *jobz, char *uplo, integer *n, doublecomplex *a, integer *lda,
doublecomplex *b, integer *ldb, doublereal *w, doublecomplex *work, integer *lwork,
doublereal *rwork, integer *info, ftnlen jobz_len, ftnlen uplo_len)
{
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
integer nb, neig;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern int zheev_(char *, char *, integer *, doublecomplex *, integer *, doublereal *,
doublecomplex *, integer *, doublereal *, integer *, ftnlen, ftnlen);
char trans[1];
logical upper, wantz;
extern int ztrmm_(char *, char *, char *, char *, integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, ftnlen, ftnlen,
ftnlen, ftnlen),
ztrsm_(char *, char *, char *, char *, integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, ftnlen, ftnlen, ftnlen,
ftnlen),
xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
extern int zhegst_(integer *, char *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *, integer *, ftnlen);
integer lwkopt;
logical lquery;
extern int zpotrf_(char *, integer *, doublecomplex *, integer *, integer *, ftnlen);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--w;
--work;
--rwork;
wantz = lsame_(jobz, (char *)"V", (ftnlen)1, (ftnlen)1);
upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1);
lquery = *lwork == -1;
*info = 0;
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (!(wantz || lsame_(jobz, (char *)"N", (ftnlen)1, (ftnlen)1))) {
*info = -2;
} else if (!(upper || lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1, *n)) {
*info = -6;
} else if (*ldb < max(1, *n)) {
*info = -8;
}
if (*info == 0) {
nb = ilaenv_(&c__1, (char *)"ZHETRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
i__1 = 1, i__2 = (nb + 1) * *n;
lwkopt = max(i__1, i__2);
work[1].r = (doublereal)lwkopt, work[1].i = 0.;
i__1 = 1, i__2 = (*n << 1) - 1;
if (*lwork < max(i__1, i__2) && !lquery) {
*info = -11;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"ZHEGV ", &i__1, (ftnlen)6);
return 0;
} else if (lquery) {
return 0;
}
if (*n == 0) {
return 0;
}
zpotrf_(uplo, n, &b[b_offset], ldb, info, (ftnlen)1);
if (*info != 0) {
*info = *n + *info;
return 0;
}
zhegst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info, (ftnlen)1);
zheev_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, &rwork[1], info, (ftnlen)1,
(ftnlen)1);
if (wantz) {
neig = *n;
if (*info > 0) {
neig = *info - 1;
}
if (*itype == 1 || *itype == 2) {
if (upper) {
*(unsigned char *)trans = 'N';
} else {
*(unsigned char *)trans = 'C';
}
ztrsm_((char *)"Left", uplo, trans, (char *)"Non-unit", n, &neig, &c_b1, &b[b_offset], ldb,
&a[a_offset], lda, (ftnlen)4, (ftnlen)1, (ftnlen)1, (ftnlen)8);
} else if (*itype == 3) {
if (upper) {
*(unsigned char *)trans = 'C';
} else {
*(unsigned char *)trans = 'N';
}
ztrmm_((char *)"Left", uplo, trans, (char *)"Non-unit", n, &neig, &c_b1, &b[b_offset], ldb,
&a[a_offset], lda, (ftnlen)4, (ftnlen)1, (ftnlen)1, (ftnlen)8);
}
}
work[1].r = (doublereal)lwkopt, work[1].i = 0.;
return 0;
}
#ifdef __cplusplus
}
#endif

271
lib/linalg/zhemm.cpp Normal file
View File

@ -0,0 +1,271 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
int zhemm_(char *side, char *uplo, integer *m, integer *n, doublecomplex *alpha, doublecomplex *a,
integer *lda, doublecomplex *b, integer *ldb, doublecomplex *beta, doublecomplex *c__,
integer *ldc, ftnlen side_len, ftnlen uplo_len)
{
integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5,
i__6;
doublereal d__1;
doublecomplex z__1, z__2, z__3, z__4, z__5;
void d_lmp_cnjg(doublecomplex *, doublecomplex *);
integer i__, j, k, info;
doublecomplex temp1, temp2;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
integer nrowa;
logical upper;
extern int xerbla_(char *, integer *, ftnlen);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) {
nrowa = *m;
} else {
nrowa = *n;
}
upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1);
info = 0;
if (!lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1) && !lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) {
info = 1;
} else if (!upper && !lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) {
info = 2;
} else if (*m < 0) {
info = 3;
} else if (*n < 0) {
info = 4;
} else if (*lda < max(1, nrowa)) {
info = 7;
} else if (*ldb < max(1, *m)) {
info = 9;
} else if (*ldc < max(1, *m)) {
info = 12;
}
if (info != 0) {
xerbla_((char *)"ZHEMM ", &info, (ftnlen)6);
return 0;
}
if (*m == 0 || *n == 0 ||
alpha->r == 0. && alpha->i == 0. && (beta->r == 1. && beta->i == 0.)) {
return 0;
}
if (alpha->r == 0. && alpha->i == 0.) {
if (beta->r == 0. && beta->i == 0.) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
c__[i__3].r = 0., c__[i__3].i = 0.;
}
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i,
z__1.i = beta->r * c__[i__4].i + beta->i * c__[i__4].r;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
}
}
}
return 0;
}
if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) {
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * b_dim1;
z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
z__1.i = alpha->r * b[i__3].i + alpha->i * b[i__3].r;
temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.;
i__3 = i__ - 1;
for (k = 1; k <= i__3; ++k) {
i__4 = k + j * c_dim1;
i__5 = k + j * c_dim1;
i__6 = k + i__ * a_dim1;
z__2.r = temp1.r * a[i__6].r - temp1.i * a[i__6].i,
z__2.i = temp1.r * a[i__6].i + temp1.i * a[i__6].r;
z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i + z__2.i;
c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
i__4 = k + j * b_dim1;
d_lmp_cnjg(&z__3, &a[k + i__ * a_dim1]);
z__2.r = b[i__4].r * z__3.r - b[i__4].i * z__3.i,
z__2.i = b[i__4].r * z__3.i + b[i__4].i * z__3.r;
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
temp2.r = z__1.r, temp2.i = z__1.i;
}
if (beta->r == 0. && beta->i == 0.) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + i__ * a_dim1;
d__1 = a[i__4].r;
z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i;
z__3.r = alpha->r * temp2.r - alpha->i * temp2.i,
z__3.i = alpha->r * temp2.i + alpha->i * temp2.r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
} else {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i,
z__3.i = beta->r * c__[i__4].i + beta->i * c__[i__4].r;
i__5 = i__ + i__ * a_dim1;
d__1 = a[i__5].r;
z__4.r = d__1 * temp1.r, z__4.i = d__1 * temp1.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__5.r = alpha->r * temp2.r - alpha->i * temp2.i,
z__5.i = alpha->r * temp2.i + alpha->i * temp2.r;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
}
}
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
for (i__ = *m; i__ >= 1; --i__) {
i__2 = i__ + j * b_dim1;
z__1.r = alpha->r * b[i__2].r - alpha->i * b[i__2].i,
z__1.i = alpha->r * b[i__2].i + alpha->i * b[i__2].r;
temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.;
i__2 = *m;
for (k = i__ + 1; k <= i__2; ++k) {
i__3 = k + j * c_dim1;
i__4 = k + j * c_dim1;
i__5 = k + i__ * a_dim1;
z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5].r;
z__1.r = c__[i__4].r + z__2.r, z__1.i = c__[i__4].i + z__2.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
i__3 = k + j * b_dim1;
d_lmp_cnjg(&z__3, &a[k + i__ * a_dim1]);
z__2.r = b[i__3].r * z__3.r - b[i__3].i * z__3.i,
z__2.i = b[i__3].r * z__3.i + b[i__3].i * z__3.r;
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
temp2.r = z__1.r, temp2.i = z__1.i;
}
if (beta->r == 0. && beta->i == 0.) {
i__2 = i__ + j * c_dim1;
i__3 = i__ + i__ * a_dim1;
d__1 = a[i__3].r;
z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i;
z__3.r = alpha->r * temp2.r - alpha->i * temp2.i,
z__3.i = alpha->r * temp2.i + alpha->i * temp2.r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
} else {
i__2 = i__ + j * c_dim1;
i__3 = i__ + j * c_dim1;
z__3.r = beta->r * c__[i__3].r - beta->i * c__[i__3].i,
z__3.i = beta->r * c__[i__3].i + beta->i * c__[i__3].r;
i__4 = i__ + i__ * a_dim1;
d__1 = a[i__4].r;
z__4.r = d__1 * temp1.r, z__4.i = d__1 * temp1.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__5.r = alpha->r * temp2.r - alpha->i * temp2.i,
z__5.i = alpha->r * temp2.i + alpha->i * temp2.r;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
}
}
}
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j + j * a_dim1;
d__1 = a[i__2].r;
z__1.r = d__1 * alpha->r, z__1.i = d__1 * alpha->i;
temp1.r = z__1.r, temp1.i = z__1.i;
if (beta->r == 0. && beta->i == 0.) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * b_dim1;
z__1.r = temp1.r * b[i__4].r - temp1.i * b[i__4].i,
z__1.i = temp1.r * b[i__4].i + temp1.i * b[i__4].r;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
}
} else {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
z__2.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i,
z__2.i = beta->r * c__[i__4].i + beta->i * c__[i__4].r;
i__5 = i__ + j * b_dim1;
z__3.r = temp1.r * b[i__5].r - temp1.i * b[i__5].i,
z__3.i = temp1.r * b[i__5].i + temp1.i * b[i__5].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
}
}
i__2 = j - 1;
for (k = 1; k <= i__2; ++k) {
if (upper) {
i__3 = k + j * a_dim1;
z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
z__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3].r;
temp1.r = z__1.r, temp1.i = z__1.i;
} else {
d_lmp_cnjg(&z__2, &a[j + k * a_dim1]);
z__1.r = alpha->r * z__2.r - alpha->i * z__2.i,
z__1.i = alpha->r * z__2.i + alpha->i * z__2.r;
temp1.r = z__1.r, temp1.i = z__1.i;
}
i__3 = *m;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * c_dim1;
i__5 = i__ + j * c_dim1;
i__6 = i__ + k * b_dim1;
z__2.r = temp1.r * b[i__6].r - temp1.i * b[i__6].i,
z__2.i = temp1.r * b[i__6].i + temp1.i * b[i__6].r;
z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i + z__2.i;
c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
}
}
i__2 = *n;
for (k = j + 1; k <= i__2; ++k) {
if (upper) {
d_lmp_cnjg(&z__2, &a[j + k * a_dim1]);
z__1.r = alpha->r * z__2.r - alpha->i * z__2.i,
z__1.i = alpha->r * z__2.i + alpha->i * z__2.r;
temp1.r = z__1.r, temp1.i = z__1.i;
} else {
i__3 = k + j * a_dim1;
z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
z__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3].r;
temp1.r = z__1.r, temp1.i = z__1.i;
}
i__3 = *m;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * c_dim1;
i__5 = i__ + j * c_dim1;
i__6 = i__ + k * b_dim1;
z__2.r = temp1.r * b[i__6].r - temp1.i * b[i__6].i,
z__2.i = temp1.r * b[i__6].i + temp1.i * b[i__6].r;
z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i + z__2.i;
c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
}
}
}
}
return 0;
}
#ifdef __cplusplus
}
#endif

187
lib/linalg/zher.cpp Normal file
View File

@ -0,0 +1,187 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
int zher_(char *uplo, integer *n, doublereal *alpha, doublecomplex *x, integer *incx,
doublecomplex *a, integer *lda, ftnlen uplo_len)
{
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1;
doublecomplex z__1, z__2;
void d_lmp_cnjg(doublecomplex *, doublecomplex *);
integer i__, j, ix, jx, kx, info;
doublecomplex temp;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern int xerbla_(char *, integer *, ftnlen);
--x;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
info = 0;
if (!lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1) && !lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) {
info = 1;
} else if (*n < 0) {
info = 2;
} else if (*incx == 0) {
info = 5;
} else if (*lda < max(1, *n)) {
info = 7;
}
if (info != 0) {
xerbla_((char *)"ZHER ", &info, (ftnlen)6);
return 0;
}
if (*n == 0 || *alpha == 0.) {
return 0;
}
if (*incx <= 0) {
kx = 1 - (*n - 1) * *incx;
} else if (*incx != 1) {
kx = 1;
}
if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) {
if (*incx == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
if (x[i__2].r != 0. || x[i__2].i != 0.) {
d_lmp_cnjg(&z__2, &x[j]);
z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
i__5 = i__;
z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
z__2.i = x[i__5].r * temp.i + x[i__5].i * temp.r;
z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i + z__2.i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
}
i__2 = j + j * a_dim1;
i__3 = j + j * a_dim1;
i__4 = j;
z__1.r = x[i__4].r * temp.r - x[i__4].i * temp.i,
z__1.i = x[i__4].r * temp.i + x[i__4].i * temp.r;
d__1 = a[i__3].r + z__1.r;
a[i__2].r = d__1, a[i__2].i = 0.;
} else {
i__2 = j + j * a_dim1;
i__3 = j + j * a_dim1;
d__1 = a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
}
}
} else {
jx = kx;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = jx;
if (x[i__2].r != 0. || x[i__2].i != 0.) {
d_lmp_cnjg(&z__2, &x[jx]);
z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
ix = kx;
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
i__5 = ix;
z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
z__2.i = x[i__5].r * temp.i + x[i__5].i * temp.r;
z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i + z__2.i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
ix += *incx;
}
i__2 = j + j * a_dim1;
i__3 = j + j * a_dim1;
i__4 = jx;
z__1.r = x[i__4].r * temp.r - x[i__4].i * temp.i,
z__1.i = x[i__4].r * temp.i + x[i__4].i * temp.r;
d__1 = a[i__3].r + z__1.r;
a[i__2].r = d__1, a[i__2].i = 0.;
} else {
i__2 = j + j * a_dim1;
i__3 = j + j * a_dim1;
d__1 = a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
}
jx += *incx;
}
}
} else {
if (*incx == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
if (x[i__2].r != 0. || x[i__2].i != 0.) {
d_lmp_cnjg(&z__2, &x[j]);
z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
i__2 = j + j * a_dim1;
i__3 = j + j * a_dim1;
i__4 = j;
z__1.r = temp.r * x[i__4].r - temp.i * x[i__4].i,
z__1.i = temp.r * x[i__4].i + temp.i * x[i__4].r;
d__1 = a[i__3].r + z__1.r;
a[i__2].r = d__1, a[i__2].i = 0.;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
i__5 = i__;
z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
z__2.i = x[i__5].r * temp.i + x[i__5].i * temp.r;
z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i + z__2.i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
}
} else {
i__2 = j + j * a_dim1;
i__3 = j + j * a_dim1;
d__1 = a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
}
}
} else {
jx = kx;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = jx;
if (x[i__2].r != 0. || x[i__2].i != 0.) {
d_lmp_cnjg(&z__2, &x[jx]);
z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
i__2 = j + j * a_dim1;
i__3 = j + j * a_dim1;
i__4 = jx;
z__1.r = temp.r * x[i__4].r - temp.i * x[i__4].i,
z__1.i = temp.r * x[i__4].i + temp.i * x[i__4].r;
d__1 = a[i__3].r + z__1.r;
a[i__2].r = d__1, a[i__2].i = 0.;
ix = jx;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
ix += *incx;
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
i__5 = ix;
z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
z__2.i = x[i__5].r * temp.i + x[i__5].i * temp.r;
z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i + z__2.i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
}
} else {
i__2 = j + j * a_dim1;
i__3 = j + j * a_dim1;
d__1 = a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
}
jx += *incx;
}
}
}
return 0;
}
#ifdef __cplusplus
}
#endif

325
lib/linalg/zherk.cpp Normal file
View File

@ -0,0 +1,325 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
int zherk_(char *uplo, char *trans, integer *n, integer *k, doublereal *alpha, doublecomplex *a,
integer *lda, doublereal *beta, doublecomplex *c__, integer *ldc, ftnlen uplo_len,
ftnlen trans_len)
{
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1;
doublecomplex z__1, z__2, z__3;
void d_lmp_cnjg(doublecomplex *, doublecomplex *);
integer i__, j, l, info;
doublecomplex temp;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
integer nrowa;
doublereal rtemp;
logical upper;
extern int xerbla_(char *, integer *, ftnlen);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
if (lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1)) {
nrowa = *n;
} else {
nrowa = *k;
}
upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1);
info = 0;
if (!upper && !lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) {
info = 1;
} else if (!lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1) &&
!lsame_(trans, (char *)"C", (ftnlen)1, (ftnlen)1)) {
info = 2;
} else if (*n < 0) {
info = 3;
} else if (*k < 0) {
info = 4;
} else if (*lda < max(1, nrowa)) {
info = 7;
} else if (*ldc < max(1, *n)) {
info = 10;
}
if (info != 0) {
xerbla_((char *)"ZHERK ", &info, (ftnlen)6);
return 0;
}
if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) {
return 0;
}
if (*alpha == 0.) {
if (upper) {
if (*beta == 0.) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
c__[i__3].r = 0., c__[i__3].i = 0.;
}
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[i__4].i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
}
i__2 = j + j * c_dim1;
i__3 = j + j * c_dim1;
d__1 = *beta * c__[i__3].r;
c__[i__2].r = d__1, c__[i__2].i = 0.;
}
}
} else {
if (*beta == 0.) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
c__[i__3].r = 0., c__[i__3].i = 0.;
}
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j + j * c_dim1;
i__3 = j + j * c_dim1;
d__1 = *beta * c__[i__3].r;
c__[i__2].r = d__1, c__[i__2].i = 0.;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[i__4].i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
}
}
}
}
return 0;
}
if (lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1)) {
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (*beta == 0.) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
c__[i__3].r = 0., c__[i__3].i = 0.;
}
} else if (*beta != 1.) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[i__4].i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
}
i__2 = j + j * c_dim1;
i__3 = j + j * c_dim1;
d__1 = *beta * c__[i__3].r;
c__[i__2].r = d__1, c__[i__2].i = 0.;
} else {
i__2 = j + j * c_dim1;
i__3 = j + j * c_dim1;
d__1 = c__[i__3].r;
c__[i__2].r = d__1, c__[i__2].i = 0.;
}
i__2 = *k;
for (l = 1; l <= i__2; ++l) {
i__3 = j + l * a_dim1;
if (a[i__3].r != 0. || a[i__3].i != 0.) {
d_lmp_cnjg(&z__2, &a[j + l * a_dim1]);
z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
i__3 = j - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * c_dim1;
i__5 = i__ + j * c_dim1;
i__6 = i__ + l * a_dim1;
z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
z__2.i = temp.r * a[i__6].i + temp.i * a[i__6].r;
z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i + z__2.i;
c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
}
i__3 = j + j * c_dim1;
i__4 = j + j * c_dim1;
i__5 = i__ + l * a_dim1;
z__1.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
z__1.i = temp.r * a[i__5].i + temp.i * a[i__5].r;
d__1 = c__[i__4].r + z__1.r;
c__[i__3].r = d__1, c__[i__3].i = 0.;
}
}
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (*beta == 0.) {
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
c__[i__3].r = 0., c__[i__3].i = 0.;
}
} else if (*beta != 1.) {
i__2 = j + j * c_dim1;
i__3 = j + j * c_dim1;
d__1 = *beta * c__[i__3].r;
c__[i__2].r = d__1, c__[i__2].i = 0.;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[i__4].i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
}
} else {
i__2 = j + j * c_dim1;
i__3 = j + j * c_dim1;
d__1 = c__[i__3].r;
c__[i__2].r = d__1, c__[i__2].i = 0.;
}
i__2 = *k;
for (l = 1; l <= i__2; ++l) {
i__3 = j + l * a_dim1;
if (a[i__3].r != 0. || a[i__3].i != 0.) {
d_lmp_cnjg(&z__2, &a[j + l * a_dim1]);
z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
i__3 = j + j * c_dim1;
i__4 = j + j * c_dim1;
i__5 = j + l * a_dim1;
z__1.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
z__1.i = temp.r * a[i__5].i + temp.i * a[i__5].r;
d__1 = c__[i__4].r + z__1.r;
c__[i__3].r = d__1, c__[i__3].i = 0.;
i__3 = *n;
for (i__ = j + 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * c_dim1;
i__5 = i__ + j * c_dim1;
i__6 = i__ + l * a_dim1;
z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
z__2.i = temp.r * a[i__6].i + temp.i * a[i__6].r;
z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i + z__2.i;
c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
}
}
}
}
}
} else {
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
temp.r = 0., temp.i = 0.;
i__3 = *k;
for (l = 1; l <= i__3; ++l) {
d_lmp_cnjg(&z__3, &a[l + i__ * a_dim1]);
i__4 = l + j * a_dim1;
z__2.r = z__3.r * a[i__4].r - z__3.i * a[i__4].i,
z__2.i = z__3.r * a[i__4].i + z__3.i * a[i__4].r;
z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
}
if (*beta == 0.) {
i__3 = i__ + j * c_dim1;
z__1.r = *alpha * temp.r, z__1.i = *alpha * temp.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
} else {
i__3 = i__ + j * c_dim1;
z__2.r = *alpha * temp.r, z__2.i = *alpha * temp.i;
i__4 = i__ + j * c_dim1;
z__3.r = *beta * c__[i__4].r, z__3.i = *beta * c__[i__4].i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
}
}
rtemp = 0.;
i__2 = *k;
for (l = 1; l <= i__2; ++l) {
d_lmp_cnjg(&z__3, &a[l + j * a_dim1]);
i__3 = l + j * a_dim1;
z__2.r = z__3.r * a[i__3].r - z__3.i * a[i__3].i,
z__2.i = z__3.r * a[i__3].i + z__3.i * a[i__3].r;
z__1.r = rtemp + z__2.r, z__1.i = z__2.i;
rtemp = z__1.r;
}
if (*beta == 0.) {
i__2 = j + j * c_dim1;
d__1 = *alpha * rtemp;
c__[i__2].r = d__1, c__[i__2].i = 0.;
} else {
i__2 = j + j * c_dim1;
i__3 = j + j * c_dim1;
d__1 = *alpha * rtemp + *beta * c__[i__3].r;
c__[i__2].r = d__1, c__[i__2].i = 0.;
}
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
rtemp = 0.;
i__2 = *k;
for (l = 1; l <= i__2; ++l) {
d_lmp_cnjg(&z__3, &a[l + j * a_dim1]);
i__3 = l + j * a_dim1;
z__2.r = z__3.r * a[i__3].r - z__3.i * a[i__3].i,
z__2.i = z__3.r * a[i__3].i + z__3.i * a[i__3].r;
z__1.r = rtemp + z__2.r, z__1.i = z__2.i;
rtemp = z__1.r;
}
if (*beta == 0.) {
i__2 = j + j * c_dim1;
d__1 = *alpha * rtemp;
c__[i__2].r = d__1, c__[i__2].i = 0.;
} else {
i__2 = j + j * c_dim1;
i__3 = j + j * c_dim1;
d__1 = *alpha * rtemp + *beta * c__[i__3].r;
c__[i__2].r = d__1, c__[i__2].i = 0.;
}
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
temp.r = 0., temp.i = 0.;
i__3 = *k;
for (l = 1; l <= i__3; ++l) {
d_lmp_cnjg(&z__3, &a[l + i__ * a_dim1]);
i__4 = l + j * a_dim1;
z__2.r = z__3.r * a[i__4].r - z__3.i * a[i__4].i,
z__2.i = z__3.r * a[i__4].i + z__3.i * a[i__4].r;
z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
}
if (*beta == 0.) {
i__3 = i__ + j * c_dim1;
z__1.r = *alpha * temp.r, z__1.i = *alpha * temp.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
} else {
i__3 = i__ + j * c_dim1;
z__2.r = *alpha * temp.r, z__2.i = *alpha * temp.i;
i__4 = i__ + j * c_dim1;
z__3.r = *beta * c__[i__4].r, z__3.i = *beta * c__[i__4].i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
}
}
}
}
}
return 0;
}
#ifdef __cplusplus
}
#endif

439
lib/linalg/zhetf2.cpp Normal file
View File

@ -0,0 +1,439 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static integer c__1 = 1;
int zhetf2_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *ipiv, integer *info,
ftnlen uplo_len)
{
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
double sqrt(doublereal), d_lmp_imag(doublecomplex *);
void d_lmp_cnjg(doublecomplex *, doublecomplex *);
doublereal d__;
integer i__, j, k;
doublecomplex t;
doublereal r1, d11;
doublecomplex d12;
doublereal d22;
doublecomplex d21;
integer kk, kp;
doublecomplex wk;
doublereal tt;
doublecomplex wkm1, wkp1;
integer imax, jmax;
extern int zher_(char *, integer *, doublereal *, doublecomplex *, integer *, doublecomplex *,
integer *, ftnlen);
doublereal alpha;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
integer kstep;
logical upper;
extern int zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal dlapy2_(doublereal *, doublereal *);
doublereal absakk;
extern logical disnan_(doublereal *);
extern int xerbla_(char *, integer *, ftnlen),
zdscal_(integer *, doublereal *, doublecomplex *, integer *);
doublereal colmax;
extern integer izamax_(integer *, doublecomplex *, integer *);
doublereal rowmax;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
*info = 0;
upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1);
if (!upper && !lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1, *n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"ZHETF2", &i__1, (ftnlen)6);
return 0;
}
alpha = (sqrt(17.) + 1.) / 8.;
if (upper) {
k = *n;
L10:
if (k < 1) {
goto L90;
}
kstep = 1;
i__1 = k + k * a_dim1;
absakk = (d__1 = a[i__1].r, abs(d__1));
if (k > 1) {
i__1 = k - 1;
imax = izamax_(&i__1, &a[k * a_dim1 + 1], &c__1);
i__1 = imax + k * a_dim1;
colmax =
(d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_lmp_imag(&a[imax + k * a_dim1]), abs(d__2));
} else {
colmax = 0.;
}
if (max(absakk, colmax) == 0. || disnan_(&absakk)) {
if (*info == 0) {
*info = k;
}
kp = k;
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
} else {
if (absakk >= alpha * colmax) {
kp = k;
} else {
i__1 = k - imax;
jmax = imax + izamax_(&i__1, &a[imax + (imax + 1) * a_dim1], lda);
i__1 = imax + jmax * a_dim1;
rowmax = (d__1 = a[i__1].r, abs(d__1)) +
(d__2 = d_lmp_imag(&a[imax + jmax * a_dim1]), abs(d__2));
if (imax > 1) {
i__1 = imax - 1;
jmax = izamax_(&i__1, &a[imax * a_dim1 + 1], &c__1);
i__1 = jmax + imax * a_dim1;
d__3 = rowmax, d__4 = (d__1 = a[i__1].r, abs(d__1)) +
(d__2 = d_lmp_imag(&a[jmax + imax * a_dim1]), abs(d__2));
rowmax = max(d__3, d__4);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
kp = k;
} else {
i__1 = imax + imax * a_dim1;
if ((d__1 = a[i__1].r, abs(d__1)) >= alpha * rowmax) {
kp = imax;
} else {
kp = imax;
kstep = 2;
}
}
}
kk = k - kstep + 1;
if (kp != kk) {
i__1 = kp - 1;
zswap_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], &c__1);
i__1 = kk - 1;
for (j = kp + 1; j <= i__1; ++j) {
d_lmp_cnjg(&z__1, &a[j + kk * a_dim1]);
t.r = z__1.r, t.i = z__1.i;
i__2 = j + kk * a_dim1;
d_lmp_cnjg(&z__1, &a[kp + j * a_dim1]);
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = kp + j * a_dim1;
a[i__2].r = t.r, a[i__2].i = t.i;
}
i__1 = kp + kk * a_dim1;
d_lmp_cnjg(&z__1, &a[kp + kk * a_dim1]);
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = kk + kk * a_dim1;
r1 = a[i__1].r;
i__1 = kk + kk * a_dim1;
i__2 = kp + kp * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = kp + kp * a_dim1;
a[i__1].r = r1, a[i__1].i = 0.;
if (kstep == 2) {
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = k - 1 + k * a_dim1;
t.r = a[i__1].r, t.i = a[i__1].i;
i__1 = k - 1 + k * a_dim1;
i__2 = kp + k * a_dim1;
a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
i__1 = kp + k * a_dim1;
a[i__1].r = t.r, a[i__1].i = t.i;
}
} else {
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
if (kstep == 2) {
i__1 = k - 1 + (k - 1) * a_dim1;
i__2 = k - 1 + (k - 1) * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
}
}
if (kstep == 1) {
i__1 = k + k * a_dim1;
r1 = 1. / a[i__1].r;
i__1 = k - 1;
d__1 = -r1;
zher_(uplo, &i__1, &d__1, &a[k * a_dim1 + 1], &c__1, &a[a_offset], lda, (ftnlen)1);
i__1 = k - 1;
zdscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1);
} else {
if (k > 2) {
i__1 = k - 1 + k * a_dim1;
d__1 = a[i__1].r;
d__2 = d_lmp_imag(&a[k - 1 + k * a_dim1]);
d__ = dlapy2_(&d__1, &d__2);
i__1 = k - 1 + (k - 1) * a_dim1;
d22 = a[i__1].r / d__;
i__1 = k + k * a_dim1;
d11 = a[i__1].r / d__;
tt = 1. / (d11 * d22 - 1.);
i__1 = k - 1 + k * a_dim1;
z__1.r = a[i__1].r / d__, z__1.i = a[i__1].i / d__;
d12.r = z__1.r, d12.i = z__1.i;
d__ = tt / d__;
for (j = k - 2; j >= 1; --j) {
i__1 = j + (k - 1) * a_dim1;
z__3.r = d11 * a[i__1].r, z__3.i = d11 * a[i__1].i;
d_lmp_cnjg(&z__5, &d12);
i__2 = j + k * a_dim1;
z__4.r = z__5.r * a[i__2].r - z__5.i * a[i__2].i,
z__4.i = z__5.r * a[i__2].i + z__5.i * a[i__2].r;
z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i;
wkm1.r = z__1.r, wkm1.i = z__1.i;
i__1 = j + k * a_dim1;
z__3.r = d22 * a[i__1].r, z__3.i = d22 * a[i__1].i;
i__2 = j + (k - 1) * a_dim1;
z__4.r = d12.r * a[i__2].r - d12.i * a[i__2].i,
z__4.i = d12.r * a[i__2].i + d12.i * a[i__2].r;
z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i;
wk.r = z__1.r, wk.i = z__1.i;
for (i__ = j; i__ >= 1; --i__) {
i__1 = i__ + j * a_dim1;
i__2 = i__ + j * a_dim1;
i__3 = i__ + k * a_dim1;
d_lmp_cnjg(&z__4, &wk);
z__3.r = a[i__3].r * z__4.r - a[i__3].i * z__4.i,
z__3.i = a[i__3].r * z__4.i + a[i__3].i * z__4.r;
z__2.r = a[i__2].r - z__3.r, z__2.i = a[i__2].i - z__3.i;
i__4 = i__ + (k - 1) * a_dim1;
d_lmp_cnjg(&z__6, &wkm1);
z__5.r = a[i__4].r * z__6.r - a[i__4].i * z__6.i,
z__5.i = a[i__4].r * z__6.i + a[i__4].i * z__6.r;
z__1.r = z__2.r - z__5.r, z__1.i = z__2.i - z__5.i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
}
i__1 = j + k * a_dim1;
a[i__1].r = wk.r, a[i__1].i = wk.i;
i__1 = j + (k - 1) * a_dim1;
a[i__1].r = wkm1.r, a[i__1].i = wkm1.i;
i__1 = j + j * a_dim1;
i__2 = j + j * a_dim1;
d__1 = a[i__2].r;
z__1.r = d__1, z__1.i = 0.;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
}
}
}
}
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k - 1] = -kp;
}
k -= kstep;
goto L10;
} else {
k = 1;
L50:
if (k > *n) {
goto L90;
}
kstep = 1;
i__1 = k + k * a_dim1;
absakk = (d__1 = a[i__1].r, abs(d__1));
if (k < *n) {
i__1 = *n - k;
imax = k + izamax_(&i__1, &a[k + 1 + k * a_dim1], &c__1);
i__1 = imax + k * a_dim1;
colmax =
(d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_lmp_imag(&a[imax + k * a_dim1]), abs(d__2));
} else {
colmax = 0.;
}
if (max(absakk, colmax) == 0. || disnan_(&absakk)) {
if (*info == 0) {
*info = k;
}
kp = k;
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
} else {
if (absakk >= alpha * colmax) {
kp = k;
} else {
i__1 = imax - k;
jmax = k - 1 + izamax_(&i__1, &a[imax + k * a_dim1], lda);
i__1 = imax + jmax * a_dim1;
rowmax = (d__1 = a[i__1].r, abs(d__1)) +
(d__2 = d_lmp_imag(&a[imax + jmax * a_dim1]), abs(d__2));
if (imax < *n) {
i__1 = *n - imax;
jmax = imax + izamax_(&i__1, &a[imax + 1 + imax * a_dim1], &c__1);
i__1 = jmax + imax * a_dim1;
d__3 = rowmax, d__4 = (d__1 = a[i__1].r, abs(d__1)) +
(d__2 = d_lmp_imag(&a[jmax + imax * a_dim1]), abs(d__2));
rowmax = max(d__3, d__4);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
kp = k;
} else {
i__1 = imax + imax * a_dim1;
if ((d__1 = a[i__1].r, abs(d__1)) >= alpha * rowmax) {
kp = imax;
} else {
kp = imax;
kstep = 2;
}
}
}
kk = k + kstep - 1;
if (kp != kk) {
if (kp < *n) {
i__1 = *n - kp;
zswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1 + kp * a_dim1], &c__1);
}
i__1 = kp - 1;
for (j = kk + 1; j <= i__1; ++j) {
d_lmp_cnjg(&z__1, &a[j + kk * a_dim1]);
t.r = z__1.r, t.i = z__1.i;
i__2 = j + kk * a_dim1;
d_lmp_cnjg(&z__1, &a[kp + j * a_dim1]);
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = kp + j * a_dim1;
a[i__2].r = t.r, a[i__2].i = t.i;
}
i__1 = kp + kk * a_dim1;
d_lmp_cnjg(&z__1, &a[kp + kk * a_dim1]);
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = kk + kk * a_dim1;
r1 = a[i__1].r;
i__1 = kk + kk * a_dim1;
i__2 = kp + kp * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = kp + kp * a_dim1;
a[i__1].r = r1, a[i__1].i = 0.;
if (kstep == 2) {
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = k + 1 + k * a_dim1;
t.r = a[i__1].r, t.i = a[i__1].i;
i__1 = k + 1 + k * a_dim1;
i__2 = kp + k * a_dim1;
a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
i__1 = kp + k * a_dim1;
a[i__1].r = t.r, a[i__1].i = t.i;
}
} else {
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
if (kstep == 2) {
i__1 = k + 1 + (k + 1) * a_dim1;
i__2 = k + 1 + (k + 1) * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
}
}
if (kstep == 1) {
if (k < *n) {
i__1 = k + k * a_dim1;
r1 = 1. / a[i__1].r;
i__1 = *n - k;
d__1 = -r1;
zher_(uplo, &i__1, &d__1, &a[k + 1 + k * a_dim1], &c__1,
&a[k + 1 + (k + 1) * a_dim1], lda, (ftnlen)1);
i__1 = *n - k;
zdscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1);
}
} else {
if (k < *n - 1) {
i__1 = k + 1 + k * a_dim1;
d__1 = a[i__1].r;
d__2 = d_lmp_imag(&a[k + 1 + k * a_dim1]);
d__ = dlapy2_(&d__1, &d__2);
i__1 = k + 1 + (k + 1) * a_dim1;
d11 = a[i__1].r / d__;
i__1 = k + k * a_dim1;
d22 = a[i__1].r / d__;
tt = 1. / (d11 * d22 - 1.);
i__1 = k + 1 + k * a_dim1;
z__1.r = a[i__1].r / d__, z__1.i = a[i__1].i / d__;
d21.r = z__1.r, d21.i = z__1.i;
d__ = tt / d__;
i__1 = *n;
for (j = k + 2; j <= i__1; ++j) {
i__2 = j + k * a_dim1;
z__3.r = d11 * a[i__2].r, z__3.i = d11 * a[i__2].i;
i__3 = j + (k + 1) * a_dim1;
z__4.r = d21.r * a[i__3].r - d21.i * a[i__3].i,
z__4.i = d21.r * a[i__3].i + d21.i * a[i__3].r;
z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i;
wk.r = z__1.r, wk.i = z__1.i;
i__2 = j + (k + 1) * a_dim1;
z__3.r = d22 * a[i__2].r, z__3.i = d22 * a[i__2].i;
d_lmp_cnjg(&z__5, &d21);
i__3 = j + k * a_dim1;
z__4.r = z__5.r * a[i__3].r - z__5.i * a[i__3].i,
z__4.i = z__5.r * a[i__3].i + z__5.i * a[i__3].r;
z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i;
wkp1.r = z__1.r, wkp1.i = z__1.i;
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
i__5 = i__ + k * a_dim1;
d_lmp_cnjg(&z__4, &wk);
z__3.r = a[i__5].r * z__4.r - a[i__5].i * z__4.i,
z__3.i = a[i__5].r * z__4.i + a[i__5].i * z__4.r;
z__2.r = a[i__4].r - z__3.r, z__2.i = a[i__4].i - z__3.i;
i__6 = i__ + (k + 1) * a_dim1;
d_lmp_cnjg(&z__6, &wkp1);
z__5.r = a[i__6].r * z__6.r - a[i__6].i * z__6.i,
z__5.i = a[i__6].r * z__6.i + a[i__6].i * z__6.r;
z__1.r = z__2.r - z__5.r, z__1.i = z__2.i - z__5.i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
}
i__2 = j + k * a_dim1;
a[i__2].r = wk.r, a[i__2].i = wk.i;
i__2 = j + (k + 1) * a_dim1;
a[i__2].r = wkp1.r, a[i__2].i = wkp1.i;
i__2 = j + j * a_dim1;
i__3 = j + j * a_dim1;
d__1 = a[i__3].r;
z__1.r = d__1, z__1.i = 0.;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
}
}
}
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k + 1] = -kp;
}
k += kstep;
goto L50;
}
L90:
return 0;
}
#ifdef __cplusplus
}
#endif

123
lib/linalg/zhetrf.cpp Normal file
View File

@ -0,0 +1,123 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static integer c__1 = 1;
static integer c_n1 = -1;
static integer c__2 = 2;
int zhetrf_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *ipiv,
doublecomplex *work, integer *lwork, integer *info, ftnlen uplo_len)
{
integer a_dim1, a_offset, i__1, i__2;
integer j, k, kb, nb, iws;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
integer nbmin, iinfo;
logical upper;
extern int zhetf2_(char *, integer *, doublecomplex *, integer *, integer *, integer *, ftnlen),
zlahef_(char *, integer *, integer *, integer *, doublecomplex *, integer *, integer *,
doublecomplex *, integer *, integer *, ftnlen),
xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
integer ldwork, lwkopt;
logical lquery;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
--work;
*info = 0;
upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1);
lquery = *lwork == -1;
if (!upper && !lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1, *n)) {
*info = -4;
} else if (*lwork < 1 && !lquery) {
*info = -7;
}
if (*info == 0) {
nb = ilaenv_(&c__1, (char *)"ZHETRF", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
lwkopt = *n * nb;
work[1].r = (doublereal)lwkopt, work[1].i = 0.;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"ZHETRF", &i__1, (ftnlen)6);
return 0;
} else if (lquery) {
return 0;
}
nbmin = 2;
ldwork = *n;
if (nb > 1 && nb < *n) {
iws = ldwork * nb;
if (*lwork < iws) {
i__1 = *lwork / ldwork;
nb = max(i__1, 1);
i__1 = 2,
i__2 = ilaenv_(&c__2, (char *)"ZHETRF", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
nbmin = max(i__1, i__2);
}
} else {
iws = 1;
}
if (nb < nbmin) {
nb = *n;
}
if (upper) {
k = *n;
L10:
if (k < 1) {
goto L40;
}
if (k > nb) {
zlahef_(uplo, &k, &nb, &kb, &a[a_offset], lda, &ipiv[1], &work[1], n, &iinfo,
(ftnlen)1);
} else {
zhetf2_(uplo, &k, &a[a_offset], lda, &ipiv[1], &iinfo, (ftnlen)1);
kb = k;
}
if (*info == 0 && iinfo > 0) {
*info = iinfo;
}
k -= kb;
goto L10;
} else {
k = 1;
L20:
if (k > *n) {
goto L40;
}
if (k <= *n - nb) {
i__1 = *n - k + 1;
zlahef_(uplo, &i__1, &nb, &kb, &a[k + k * a_dim1], lda, &ipiv[k], &work[1], n, &iinfo,
(ftnlen)1);
} else {
i__1 = *n - k + 1;
zhetf2_(uplo, &i__1, &a[k + k * a_dim1], lda, &ipiv[k], &iinfo, (ftnlen)1);
kb = *n - k + 1;
}
if (*info == 0 && iinfo > 0) {
*info = iinfo + k - 1;
}
i__1 = k + kb - 1;
for (j = k; j <= i__1; ++j) {
if (ipiv[j] > 0) {
ipiv[j] = ipiv[j] + k - 1;
} else {
ipiv[j] = ipiv[j] - k + 1;
}
}
k += kb;
goto L20;
}
L40:
work[1].r = (doublereal)lwkopt, work[1].i = 0.;
return 0;
}
#ifdef __cplusplus
}
#endif

319
lib/linalg/zhetri.cpp Normal file
View File

@ -0,0 +1,319 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static doublecomplex c_b2 = {0., 0.};
static integer c__1 = 1;
int zhetri_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *ipiv,
doublecomplex *work, integer *info, ftnlen uplo_len)
{
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1, z__2;
double z_lmp_abs(doublecomplex *);
void d_lmp_cnjg(doublecomplex *, doublecomplex *);
doublereal d__;
integer j, k;
doublereal t, ak;
integer kp;
doublereal akp1;
doublecomplex temp, akkp1;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern VOID zdotc_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *);
integer kstep;
extern int zhemv_(char *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *,
ftnlen);
logical upper;
extern int zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *),
zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *),
xerbla_(char *, integer *, ftnlen);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
--work;
*info = 0;
upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1);
if (!upper && !lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1, *n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"ZHETRI", &i__1, (ftnlen)6);
return 0;
}
if (*n == 0) {
return 0;
}
if (upper) {
for (*info = *n; *info >= 1; --(*info)) {
i__1 = *info + *info * a_dim1;
if (ipiv[*info] > 0 && (a[i__1].r == 0. && a[i__1].i == 0.)) {
return 0;
}
}
} else {
i__1 = *n;
for (*info = 1; *info <= i__1; ++(*info)) {
i__2 = *info + *info * a_dim1;
if (ipiv[*info] > 0 && (a[i__2].r == 0. && a[i__2].i == 0.)) {
return 0;
}
}
}
*info = 0;
if (upper) {
k = 1;
L30:
if (k > *n) {
goto L50;
}
if (ipiv[k] > 0) {
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
d__1 = 1. / a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
if (k > 1) {
i__1 = k - 1;
zcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
i__1 = k - 1;
z__1.r = -1., z__1.i = -0.;
zhemv_(uplo, &i__1, &z__1, &a[a_offset], lda, &work[1], &c__1, &c_b2,
&a[k * a_dim1 + 1], &c__1, (ftnlen)1);
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
i__3 = k - 1;
zdotc_(&z__2, &i__3, &work[1], &c__1, &a[k * a_dim1 + 1], &c__1);
d__1 = z__2.r;
z__1.r = a[i__2].r - d__1, z__1.i = a[i__2].i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
}
kstep = 1;
} else {
t = z_lmp_abs(&a[k + (k + 1) * a_dim1]);
i__1 = k + k * a_dim1;
ak = a[i__1].r / t;
i__1 = k + 1 + (k + 1) * a_dim1;
akp1 = a[i__1].r / t;
i__1 = k + (k + 1) * a_dim1;
z__1.r = a[i__1].r / t, z__1.i = a[i__1].i / t;
akkp1.r = z__1.r, akkp1.i = z__1.i;
d__ = t * (ak * akp1 - 1.);
i__1 = k + k * a_dim1;
d__1 = akp1 / d__;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = k + 1 + (k + 1) * a_dim1;
d__1 = ak / d__;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = k + (k + 1) * a_dim1;
z__2.r = -akkp1.r, z__2.i = -akkp1.i;
z__1.r = z__2.r / d__, z__1.i = z__2.i / d__;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
if (k > 1) {
i__1 = k - 1;
zcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
i__1 = k - 1;
z__1.r = -1., z__1.i = -0.;
zhemv_(uplo, &i__1, &z__1, &a[a_offset], lda, &work[1], &c__1, &c_b2,
&a[k * a_dim1 + 1], &c__1, (ftnlen)1);
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
i__3 = k - 1;
zdotc_(&z__2, &i__3, &work[1], &c__1, &a[k * a_dim1 + 1], &c__1);
d__1 = z__2.r;
z__1.r = a[i__2].r - d__1, z__1.i = a[i__2].i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = k + (k + 1) * a_dim1;
i__2 = k + (k + 1) * a_dim1;
i__3 = k - 1;
zdotc_(&z__2, &i__3, &a[k * a_dim1 + 1], &c__1, &a[(k + 1) * a_dim1 + 1], &c__1);
z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = k - 1;
zcopy_(&i__1, &a[(k + 1) * a_dim1 + 1], &c__1, &work[1], &c__1);
i__1 = k - 1;
z__1.r = -1., z__1.i = -0.;
zhemv_(uplo, &i__1, &z__1, &a[a_offset], lda, &work[1], &c__1, &c_b2,
&a[(k + 1) * a_dim1 + 1], &c__1, (ftnlen)1);
i__1 = k + 1 + (k + 1) * a_dim1;
i__2 = k + 1 + (k + 1) * a_dim1;
i__3 = k - 1;
zdotc_(&z__2, &i__3, &work[1], &c__1, &a[(k + 1) * a_dim1 + 1], &c__1);
d__1 = z__2.r;
z__1.r = a[i__2].r - d__1, z__1.i = a[i__2].i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
}
kstep = 2;
}
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k) {
i__1 = kp - 1;
zswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], &c__1);
i__1 = k - 1;
for (j = kp + 1; j <= i__1; ++j) {
d_lmp_cnjg(&z__1, &a[j + k * a_dim1]);
temp.r = z__1.r, temp.i = z__1.i;
i__2 = j + k * a_dim1;
d_lmp_cnjg(&z__1, &a[kp + j * a_dim1]);
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = kp + j * a_dim1;
a[i__2].r = temp.r, a[i__2].i = temp.i;
}
i__1 = kp + k * a_dim1;
d_lmp_cnjg(&z__1, &a[kp + k * a_dim1]);
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = k + k * a_dim1;
temp.r = a[i__1].r, temp.i = a[i__1].i;
i__1 = k + k * a_dim1;
i__2 = kp + kp * a_dim1;
a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
i__1 = kp + kp * a_dim1;
a[i__1].r = temp.r, a[i__1].i = temp.i;
if (kstep == 2) {
i__1 = k + (k + 1) * a_dim1;
temp.r = a[i__1].r, temp.i = a[i__1].i;
i__1 = k + (k + 1) * a_dim1;
i__2 = kp + (k + 1) * a_dim1;
a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
i__1 = kp + (k + 1) * a_dim1;
a[i__1].r = temp.r, a[i__1].i = temp.i;
}
}
k += kstep;
goto L30;
L50:;
} else {
k = *n;
L60:
if (k < 1) {
goto L80;
}
if (ipiv[k] > 0) {
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
d__1 = 1. / a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
if (k < *n) {
i__1 = *n - k;
zcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1);
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zhemv_(uplo, &i__1, &z__1, &a[k + 1 + (k + 1) * a_dim1], lda, &work[1], &c__1,
&c_b2, &a[k + 1 + k * a_dim1], &c__1, (ftnlen)1);
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
i__3 = *n - k;
zdotc_(&z__2, &i__3, &work[1], &c__1, &a[k + 1 + k * a_dim1], &c__1);
d__1 = z__2.r;
z__1.r = a[i__2].r - d__1, z__1.i = a[i__2].i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
}
kstep = 1;
} else {
t = z_lmp_abs(&a[k + (k - 1) * a_dim1]);
i__1 = k - 1 + (k - 1) * a_dim1;
ak = a[i__1].r / t;
i__1 = k + k * a_dim1;
akp1 = a[i__1].r / t;
i__1 = k + (k - 1) * a_dim1;
z__1.r = a[i__1].r / t, z__1.i = a[i__1].i / t;
akkp1.r = z__1.r, akkp1.i = z__1.i;
d__ = t * (ak * akp1 - 1.);
i__1 = k - 1 + (k - 1) * a_dim1;
d__1 = akp1 / d__;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = k + k * a_dim1;
d__1 = ak / d__;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = k + (k - 1) * a_dim1;
z__2.r = -akkp1.r, z__2.i = -akkp1.i;
z__1.r = z__2.r / d__, z__1.i = z__2.i / d__;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
if (k < *n) {
i__1 = *n - k;
zcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1);
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zhemv_(uplo, &i__1, &z__1, &a[k + 1 + (k + 1) * a_dim1], lda, &work[1], &c__1,
&c_b2, &a[k + 1 + k * a_dim1], &c__1, (ftnlen)1);
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
i__3 = *n - k;
zdotc_(&z__2, &i__3, &work[1], &c__1, &a[k + 1 + k * a_dim1], &c__1);
d__1 = z__2.r;
z__1.r = a[i__2].r - d__1, z__1.i = a[i__2].i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = k + (k - 1) * a_dim1;
i__2 = k + (k - 1) * a_dim1;
i__3 = *n - k;
zdotc_(&z__2, &i__3, &a[k + 1 + k * a_dim1], &c__1, &a[k + 1 + (k - 1) * a_dim1],
&c__1);
z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = *n - k;
zcopy_(&i__1, &a[k + 1 + (k - 1) * a_dim1], &c__1, &work[1], &c__1);
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zhemv_(uplo, &i__1, &z__1, &a[k + 1 + (k + 1) * a_dim1], lda, &work[1], &c__1,
&c_b2, &a[k + 1 + (k - 1) * a_dim1], &c__1, (ftnlen)1);
i__1 = k - 1 + (k - 1) * a_dim1;
i__2 = k - 1 + (k - 1) * a_dim1;
i__3 = *n - k;
zdotc_(&z__2, &i__3, &work[1], &c__1, &a[k + 1 + (k - 1) * a_dim1], &c__1);
d__1 = z__2.r;
z__1.r = a[i__2].r - d__1, z__1.i = a[i__2].i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
}
kstep = 2;
}
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k) {
if (kp < *n) {
i__1 = *n - kp;
zswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + kp * a_dim1], &c__1);
}
i__1 = kp - 1;
for (j = k + 1; j <= i__1; ++j) {
d_lmp_cnjg(&z__1, &a[j + k * a_dim1]);
temp.r = z__1.r, temp.i = z__1.i;
i__2 = j + k * a_dim1;
d_lmp_cnjg(&z__1, &a[kp + j * a_dim1]);
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = kp + j * a_dim1;
a[i__2].r = temp.r, a[i__2].i = temp.i;
}
i__1 = kp + k * a_dim1;
d_lmp_cnjg(&z__1, &a[kp + k * a_dim1]);
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = k + k * a_dim1;
temp.r = a[i__1].r, temp.i = a[i__1].i;
i__1 = k + k * a_dim1;
i__2 = kp + kp * a_dim1;
a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
i__1 = kp + kp * a_dim1;
a[i__1].r = temp.r, a[i__1].i = temp.i;
if (kstep == 2) {
i__1 = k + (k - 1) * a_dim1;
temp.r = a[i__1].r, temp.i = a[i__1].i;
i__1 = k + (k - 1) * a_dim1;
i__2 = kp + (k - 1) * a_dim1;
a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
i__1 = kp + (k - 1) * a_dim1;
a[i__1].r = temp.r, a[i__1].i = temp.i;
}
}
k -= kstep;
goto L60;
L80:;
}
return 0;
}
#ifdef __cplusplus
}
#endif

520
lib/linalg/zlahef.cpp Normal file
View File

@ -0,0 +1,520 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static doublecomplex c_b1 = {1., 0.};
static integer c__1 = 1;
int zlahef_(char *uplo, integer *n, integer *nb, integer *kb, doublecomplex *a, integer *lda,
integer *ipiv, doublecomplex *w, integer *ldw, integer *info, ftnlen uplo_len)
{
integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2, z__3, z__4;
double sqrt(doublereal), d_lmp_imag(doublecomplex *);
void d_lmp_cnjg(doublecomplex *, doublecomplex *),
z_lmp_div(doublecomplex *, doublecomplex *, doublecomplex *);
integer j, k;
doublereal t, r1;
doublecomplex d11, d21, d22;
integer jb, jj, kk, jp, kp, kw, kkw, imax, jmax;
doublereal alpha;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern int zgemm_(char *, char *, integer *, integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, ftnlen, ftnlen);
integer kstep;
extern int zgemv_(char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *,
ftnlen),
zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *),
zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *);
doublereal absakk;
extern int zdscal_(integer *, doublereal *, doublecomplex *, integer *);
doublereal colmax;
extern int zlacgv_(integer *, doublecomplex *, integer *);
extern integer izamax_(integer *, doublecomplex *, integer *);
doublereal rowmax;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
w_dim1 = *ldw;
w_offset = 1 + w_dim1;
w -= w_offset;
*info = 0;
alpha = (sqrt(17.) + 1.) / 8.;
if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) {
k = *n;
L10:
kw = *nb + k - *n;
if (k <= *n - *nb + 1 && *nb < *n || k < 1) {
goto L30;
}
kstep = 1;
i__1 = k - 1;
zcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1);
i__1 = k + kw * w_dim1;
i__2 = k + k * a_dim1;
d__1 = a[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
if (k < *n) {
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zgemv_((char *)"No transpose", &k, &i__1, &z__1, &a[(k + 1) * a_dim1 + 1], lda,
&w[k + (kw + 1) * w_dim1], ldw, &c_b1, &w[kw * w_dim1 + 1], &c__1, (ftnlen)12);
i__1 = k + kw * w_dim1;
i__2 = k + kw * w_dim1;
d__1 = w[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
}
i__1 = k + kw * w_dim1;
absakk = (d__1 = w[i__1].r, abs(d__1));
if (k > 1) {
i__1 = k - 1;
imax = izamax_(&i__1, &w[kw * w_dim1 + 1], &c__1);
i__1 = imax + kw * w_dim1;
colmax =
(d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_lmp_imag(&w[imax + kw * w_dim1]), abs(d__2));
} else {
colmax = 0.;
}
if (max(absakk, colmax) == 0.) {
if (*info == 0) {
*info = k;
}
kp = k;
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
} else {
if (absakk >= alpha * colmax) {
kp = k;
} else {
i__1 = imax - 1;
zcopy_(&i__1, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) * w_dim1 + 1], &c__1);
i__1 = imax + (kw - 1) * w_dim1;
i__2 = imax + imax * a_dim1;
d__1 = a[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
i__1 = k - imax;
zcopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax + 1 + (kw - 1) * w_dim1],
&c__1);
i__1 = k - imax;
zlacgv_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1], &c__1);
if (k < *n) {
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zgemv_((char *)"No transpose", &k, &i__1, &z__1, &a[(k + 1) * a_dim1 + 1], lda,
&w[imax + (kw + 1) * w_dim1], ldw, &c_b1, &w[(kw - 1) * w_dim1 + 1],
&c__1, (ftnlen)12);
i__1 = imax + (kw - 1) * w_dim1;
i__2 = imax + (kw - 1) * w_dim1;
d__1 = w[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
}
i__1 = k - imax;
jmax = imax + izamax_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1], &c__1);
i__1 = jmax + (kw - 1) * w_dim1;
rowmax = (d__1 = w[i__1].r, abs(d__1)) +
(d__2 = d_lmp_imag(&w[jmax + (kw - 1) * w_dim1]), abs(d__2));
if (imax > 1) {
i__1 = imax - 1;
jmax = izamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1);
i__1 = jmax + (kw - 1) * w_dim1;
d__3 = rowmax, d__4 = (d__1 = w[i__1].r, abs(d__1)) +
(d__2 = d_lmp_imag(&w[jmax + (kw - 1) * w_dim1]), abs(d__2));
rowmax = max(d__3, d__4);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
kp = k;
} else {
i__1 = imax + (kw - 1) * w_dim1;
if ((d__1 = w[i__1].r, abs(d__1)) >= alpha * rowmax) {
kp = imax;
zcopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1);
} else {
kp = imax;
kstep = 2;
}
}
}
kk = k - kstep + 1;
kkw = *nb + kk - *n;
if (kp != kk) {
i__1 = kp + kp * a_dim1;
i__2 = kk + kk * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = kk - 1 - kp;
zcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + 1) * a_dim1], lda);
i__1 = kk - 1 - kp;
zlacgv_(&i__1, &a[kp + (kp + 1) * a_dim1], lda);
if (kp > 1) {
i__1 = kp - 1;
zcopy_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], &c__1);
}
if (k < *n) {
i__1 = *n - k;
zswap_(&i__1, &a[kk + (k + 1) * a_dim1], lda, &a[kp + (k + 1) * a_dim1], lda);
}
i__1 = *n - kk + 1;
zswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw * w_dim1], ldw);
}
if (kstep == 1) {
zcopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1);
if (k > 1) {
i__1 = k + k * a_dim1;
r1 = 1. / a[i__1].r;
i__1 = k - 1;
zdscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1);
i__1 = k - 1;
zlacgv_(&i__1, &w[kw * w_dim1 + 1], &c__1);
}
} else {
if (k > 2) {
i__1 = k - 1 + kw * w_dim1;
d21.r = w[i__1].r, d21.i = w[i__1].i;
d_lmp_cnjg(&z__2, &d21);
z_lmp_div(&z__1, &w[k + kw * w_dim1], &z__2);
d11.r = z__1.r, d11.i = z__1.i;
z_lmp_div(&z__1, &w[k - 1 + (kw - 1) * w_dim1], &d21);
d22.r = z__1.r, d22.i = z__1.i;
z__1.r = d11.r * d22.r - d11.i * d22.i, z__1.i = d11.r * d22.i + d11.i * d22.r;
t = 1. / (z__1.r - 1.);
z__2.r = t, z__2.i = 0.;
z_lmp_div(&z__1, &z__2, &d21);
d21.r = z__1.r, d21.i = z__1.i;
i__1 = k - 2;
for (j = 1; j <= i__1; ++j) {
i__2 = j + (k - 1) * a_dim1;
i__3 = j + (kw - 1) * w_dim1;
z__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i,
z__3.i = d11.r * w[i__3].i + d11.i * w[i__3].r;
i__4 = j + kw * w_dim1;
z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4].i;
z__1.r = d21.r * z__2.r - d21.i * z__2.i,
z__1.i = d21.r * z__2.i + d21.i * z__2.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = j + k * a_dim1;
d_lmp_cnjg(&z__2, &d21);
i__3 = j + kw * w_dim1;
z__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i,
z__4.i = d22.r * w[i__3].i + d22.i * w[i__3].r;
i__4 = j + (kw - 1) * w_dim1;
z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4].i;
z__1.r = z__2.r * z__3.r - z__2.i * z__3.i,
z__1.i = z__2.r * z__3.i + z__2.i * z__3.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
}
i__1 = k - 1 + (k - 1) * a_dim1;
i__2 = k - 1 + (kw - 1) * w_dim1;
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = k - 1 + k * a_dim1;
i__2 = k - 1 + kw * w_dim1;
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = k + k * a_dim1;
i__2 = k + kw * w_dim1;
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = k - 1;
zlacgv_(&i__1, &w[kw * w_dim1 + 1], &c__1);
i__1 = k - 2;
zlacgv_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1);
}
}
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k - 1] = -kp;
}
k -= kstep;
goto L10;
L30:
i__1 = -(*nb);
for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j += i__1) {
i__2 = *nb, i__3 = k - j + 1;
jb = min(i__2, i__3);
i__2 = j + jb - 1;
for (jj = j; jj <= i__2; ++jj) {
i__3 = jj + jj * a_dim1;
i__4 = jj + jj * a_dim1;
d__1 = a[i__4].r;
a[i__3].r = d__1, a[i__3].i = 0.;
i__3 = jj - j + 1;
i__4 = *n - k;
z__1.r = -1., z__1.i = -0.;
zgemv_((char *)"No transpose", &i__3, &i__4, &z__1, &a[j + (k + 1) * a_dim1], lda,
&w[jj + (kw + 1) * w_dim1], ldw, &c_b1, &a[j + jj * a_dim1], &c__1,
(ftnlen)12);
i__3 = jj + jj * a_dim1;
i__4 = jj + jj * a_dim1;
d__1 = a[i__4].r;
a[i__3].r = d__1, a[i__3].i = 0.;
}
i__2 = j - 1;
i__3 = *n - k;
z__1.r = -1., z__1.i = -0.;
zgemm_((char *)"No transpose", (char *)"Transpose", &i__2, &jb, &i__3, &z__1, &a[(k + 1) * a_dim1 + 1],
lda, &w[j + (kw + 1) * w_dim1], ldw, &c_b1, &a[j * a_dim1 + 1], lda, (ftnlen)12,
(ftnlen)9);
}
j = k + 1;
L60:
jj = j;
jp = ipiv[j];
if (jp < 0) {
jp = -jp;
++j;
}
++j;
if (jp != jj && j <= *n) {
i__1 = *n - j + 1;
zswap_(&i__1, &a[jp + j * a_dim1], lda, &a[jj + j * a_dim1], lda);
}
if (j < *n) {
goto L60;
}
*kb = *n - k;
} else {
k = 1;
L70:
if (k >= *nb && *nb < *n || k > *n) {
goto L90;
}
kstep = 1;
i__1 = k + k * w_dim1;
i__2 = k + k * a_dim1;
d__1 = a[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
if (k < *n) {
i__1 = *n - k;
zcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &w[k + 1 + k * w_dim1], &c__1);
}
i__1 = *n - k + 1;
i__2 = k - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_((char *)"No transpose", &i__1, &i__2, &z__1, &a[k + a_dim1], lda, &w[k + w_dim1], ldw, &c_b1,
&w[k + k * w_dim1], &c__1, (ftnlen)12);
i__1 = k + k * w_dim1;
i__2 = k + k * w_dim1;
d__1 = w[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
i__1 = k + k * w_dim1;
absakk = (d__1 = w[i__1].r, abs(d__1));
if (k < *n) {
i__1 = *n - k;
imax = k + izamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1);
i__1 = imax + k * w_dim1;
colmax =
(d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_lmp_imag(&w[imax + k * w_dim1]), abs(d__2));
} else {
colmax = 0.;
}
if (max(absakk, colmax) == 0.) {
if (*info == 0) {
*info = k;
}
kp = k;
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
} else {
if (absakk >= alpha * colmax) {
kp = k;
} else {
i__1 = imax - k;
zcopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) * w_dim1], &c__1);
i__1 = imax - k;
zlacgv_(&i__1, &w[k + (k + 1) * w_dim1], &c__1);
i__1 = imax + (k + 1) * w_dim1;
i__2 = imax + imax * a_dim1;
d__1 = a[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
if (imax < *n) {
i__1 = *n - imax;
zcopy_(&i__1, &a[imax + 1 + imax * a_dim1], &c__1,
&w[imax + 1 + (k + 1) * w_dim1], &c__1);
}
i__1 = *n - k + 1;
i__2 = k - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_((char *)"No transpose", &i__1, &i__2, &z__1, &a[k + a_dim1], lda, &w[imax + w_dim1],
ldw, &c_b1, &w[k + (k + 1) * w_dim1], &c__1, (ftnlen)12);
i__1 = imax + (k + 1) * w_dim1;
i__2 = imax + (k + 1) * w_dim1;
d__1 = w[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
i__1 = imax - k;
jmax = k - 1 + izamax_(&i__1, &w[k + (k + 1) * w_dim1], &c__1);
i__1 = jmax + (k + 1) * w_dim1;
rowmax = (d__1 = w[i__1].r, abs(d__1)) +
(d__2 = d_lmp_imag(&w[jmax + (k + 1) * w_dim1]), abs(d__2));
if (imax < *n) {
i__1 = *n - imax;
jmax = imax + izamax_(&i__1, &w[imax + 1 + (k + 1) * w_dim1], &c__1);
i__1 = jmax + (k + 1) * w_dim1;
d__3 = rowmax, d__4 = (d__1 = w[i__1].r, abs(d__1)) +
(d__2 = d_lmp_imag(&w[jmax + (k + 1) * w_dim1]), abs(d__2));
rowmax = max(d__3, d__4);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
kp = k;
} else {
i__1 = imax + (k + 1) * w_dim1;
if ((d__1 = w[i__1].r, abs(d__1)) >= alpha * rowmax) {
kp = imax;
i__1 = *n - k + 1;
zcopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * w_dim1], &c__1);
} else {
kp = imax;
kstep = 2;
}
}
}
kk = k + kstep - 1;
if (kp != kk) {
i__1 = kp + kp * a_dim1;
i__2 = kk + kk * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = kp - kk - 1;
zcopy_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk + 1) * a_dim1], lda);
i__1 = kp - kk - 1;
zlacgv_(&i__1, &a[kp + (kk + 1) * a_dim1], lda);
if (kp < *n) {
i__1 = *n - kp;
zcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1 + kp * a_dim1], &c__1);
}
if (k > 1) {
i__1 = k - 1;
zswap_(&i__1, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda);
}
zswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw);
}
if (kstep == 1) {
i__1 = *n - k + 1;
zcopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], &c__1);
if (k < *n) {
i__1 = k + k * a_dim1;
r1 = 1. / a[i__1].r;
i__1 = *n - k;
zdscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1);
i__1 = *n - k;
zlacgv_(&i__1, &w[k + 1 + k * w_dim1], &c__1);
}
} else {
if (k < *n - 1) {
i__1 = k + 1 + k * w_dim1;
d21.r = w[i__1].r, d21.i = w[i__1].i;
z_lmp_div(&z__1, &w[k + 1 + (k + 1) * w_dim1], &d21);
d11.r = z__1.r, d11.i = z__1.i;
d_lmp_cnjg(&z__2, &d21);
z_lmp_div(&z__1, &w[k + k * w_dim1], &z__2);
d22.r = z__1.r, d22.i = z__1.i;
z__1.r = d11.r * d22.r - d11.i * d22.i, z__1.i = d11.r * d22.i + d11.i * d22.r;
t = 1. / (z__1.r - 1.);
z__2.r = t, z__2.i = 0.;
z_lmp_div(&z__1, &z__2, &d21);
d21.r = z__1.r, d21.i = z__1.i;
i__1 = *n;
for (j = k + 2; j <= i__1; ++j) {
i__2 = j + k * a_dim1;
d_lmp_cnjg(&z__2, &d21);
i__3 = j + k * w_dim1;
z__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i,
z__4.i = d11.r * w[i__3].i + d11.i * w[i__3].r;
i__4 = j + (k + 1) * w_dim1;
z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4].i;
z__1.r = z__2.r * z__3.r - z__2.i * z__3.i,
z__1.i = z__2.r * z__3.i + z__2.i * z__3.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = j + (k + 1) * a_dim1;
i__3 = j + (k + 1) * w_dim1;
z__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i,
z__3.i = d22.r * w[i__3].i + d22.i * w[i__3].r;
i__4 = j + k * w_dim1;
z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4].i;
z__1.r = d21.r * z__2.r - d21.i * z__2.i,
z__1.i = d21.r * z__2.i + d21.i * z__2.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
}
i__1 = k + k * a_dim1;
i__2 = k + k * w_dim1;
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = k + 1 + k * a_dim1;
i__2 = k + 1 + k * w_dim1;
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = k + 1 + (k + 1) * a_dim1;
i__2 = k + 1 + (k + 1) * w_dim1;
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = *n - k;
zlacgv_(&i__1, &w[k + 1 + k * w_dim1], &c__1);
i__1 = *n - k - 1;
zlacgv_(&i__1, &w[k + 2 + (k + 1) * w_dim1], &c__1);
}
}
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k + 1] = -kp;
}
k += kstep;
goto L70;
L90:
i__1 = *n;
i__2 = *nb;
for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
i__3 = *nb, i__4 = *n - j + 1;
jb = min(i__3, i__4);
i__3 = j + jb - 1;
for (jj = j; jj <= i__3; ++jj) {
i__4 = jj + jj * a_dim1;
i__5 = jj + jj * a_dim1;
d__1 = a[i__5].r;
a[i__4].r = d__1, a[i__4].i = 0.;
i__4 = j + jb - jj;
i__5 = k - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_((char *)"No transpose", &i__4, &i__5, &z__1, &a[jj + a_dim1], lda, &w[jj + w_dim1],
ldw, &c_b1, &a[jj + jj * a_dim1], &c__1, (ftnlen)12);
i__4 = jj + jj * a_dim1;
i__5 = jj + jj * a_dim1;
d__1 = a[i__5].r;
a[i__4].r = d__1, a[i__4].i = 0.;
}
if (j + jb <= *n) {
i__3 = *n - j - jb + 1;
i__4 = k - 1;
z__1.r = -1., z__1.i = -0.;
zgemm_((char *)"No transpose", (char *)"Transpose", &i__3, &jb, &i__4, &z__1, &a[j + jb + a_dim1],
lda, &w[j + w_dim1], ldw, &c_b1, &a[j + jb + j * a_dim1], lda, (ftnlen)12,
(ftnlen)9);
}
}
j = k - 1;
L120:
jj = j;
jp = ipiv[j];
if (jp < 0) {
jp = -jp;
--j;
}
--j;
if (jp != jj && j >= 1) {
zswap_(&j, &a[jp + a_dim1], lda, &a[jj + a_dim1], lda);
}
if (j > 1) {
goto L120;
}
*kb = k - 1;
}
return 0;
}
#ifdef __cplusplus
}
#endif

79
lib/linalg/zlaswp.cpp Normal file
View File

@ -0,0 +1,79 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
int zlaswp_(integer *n, doublecomplex *a, integer *lda, integer *k1, integer *k2, integer *ipiv,
integer *incx)
{
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
integer i__, j, k, i1, i2, n32, ip, ix, ix0, inc;
doublecomplex temp;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
if (*incx > 0) {
ix0 = *k1;
i1 = *k1;
i2 = *k2;
inc = 1;
} else if (*incx < 0) {
ix0 = *k1 + (*k1 - *k2) * *incx;
i1 = *k2;
i2 = *k1;
inc = -1;
} else {
return 0;
}
n32 = *n / 32 << 5;
if (n32 != 0) {
i__1 = n32;
for (j = 1; j <= i__1; j += 32) {
ix = ix0;
i__2 = i2;
i__3 = inc;
for (i__ = i1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3) {
ip = ipiv[ix];
if (ip != i__) {
i__4 = j + 31;
for (k = j; k <= i__4; ++k) {
i__5 = i__ + k * a_dim1;
temp.r = a[i__5].r, temp.i = a[i__5].i;
i__5 = i__ + k * a_dim1;
i__6 = ip + k * a_dim1;
a[i__5].r = a[i__6].r, a[i__5].i = a[i__6].i;
i__5 = ip + k * a_dim1;
a[i__5].r = temp.r, a[i__5].i = temp.i;
}
}
ix += *incx;
}
}
}
if (n32 != *n) {
++n32;
ix = ix0;
i__1 = i2;
i__3 = inc;
for (i__ = i1; i__3 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__3) {
ip = ipiv[ix];
if (ip != i__) {
i__2 = *n;
for (k = n32; k <= i__2; ++k) {
i__4 = i__ + k * a_dim1;
temp.r = a[i__4].r, temp.i = a[i__4].i;
i__4 = i__ + k * a_dim1;
i__5 = ip + k * a_dim1;
a[i__4].r = a[i__5].r, a[i__4].i = a[i__5].i;
i__4 = ip + k * a_dim1;
a[i__4].r = temp.r, a[i__4].i = temp.i;
}
}
ix += *incx;
}
}
return 0;
}
#ifdef __cplusplus
}
#endif

431
lib/linalg/zlasyf.cpp Normal file
View File

@ -0,0 +1,431 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static doublecomplex c_b1 = {1., 0.};
static integer c__1 = 1;
int zlasyf_(char *uplo, integer *n, integer *nb, integer *kb, doublecomplex *a, integer *lda,
integer *ipiv, doublecomplex *w, integer *ldw, integer *info, ftnlen uplo_len)
{
integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2, z__3;
double sqrt(doublereal), d_lmp_imag(doublecomplex *);
void z_lmp_div(doublecomplex *, doublecomplex *, doublecomplex *);
integer j, k;
doublecomplex t, r1, d11, d21, d22;
integer jb, jj, kk, jp, kp, kw, kkw, imax, jmax;
doublereal alpha;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern int zscal_(integer *, doublecomplex *, doublecomplex *, integer *),
zgemm_(char *, char *, integer *, integer *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *,
ftnlen, ftnlen);
integer kstep;
extern int zgemv_(char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *,
ftnlen),
zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *),
zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *);
doublereal absakk, colmax;
extern integer izamax_(integer *, doublecomplex *, integer *);
doublereal rowmax;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
w_dim1 = *ldw;
w_offset = 1 + w_dim1;
w -= w_offset;
*info = 0;
alpha = (sqrt(17.) + 1.) / 8.;
if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) {
k = *n;
L10:
kw = *nb + k - *n;
if (k <= *n - *nb + 1 && *nb < *n || k < 1) {
goto L30;
}
zcopy_(&k, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1);
if (k < *n) {
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zgemv_((char *)"No transpose", &k, &i__1, &z__1, &a[(k + 1) * a_dim1 + 1], lda,
&w[k + (kw + 1) * w_dim1], ldw, &c_b1, &w[kw * w_dim1 + 1], &c__1, (ftnlen)12);
}
kstep = 1;
i__1 = k + kw * w_dim1;
absakk = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_lmp_imag(&w[k + kw * w_dim1]), abs(d__2));
if (k > 1) {
i__1 = k - 1;
imax = izamax_(&i__1, &w[kw * w_dim1 + 1], &c__1);
i__1 = imax + kw * w_dim1;
colmax =
(d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_lmp_imag(&w[imax + kw * w_dim1]), abs(d__2));
} else {
colmax = 0.;
}
if (max(absakk, colmax) == 0.) {
if (*info == 0) {
*info = k;
}
kp = k;
} else {
if (absakk >= alpha * colmax) {
kp = k;
} else {
zcopy_(&imax, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) * w_dim1 + 1], &c__1);
i__1 = k - imax;
zcopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax + 1 + (kw - 1) * w_dim1],
&c__1);
if (k < *n) {
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zgemv_((char *)"No transpose", &k, &i__1, &z__1, &a[(k + 1) * a_dim1 + 1], lda,
&w[imax + (kw + 1) * w_dim1], ldw, &c_b1, &w[(kw - 1) * w_dim1 + 1],
&c__1, (ftnlen)12);
}
i__1 = k - imax;
jmax = imax + izamax_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1], &c__1);
i__1 = jmax + (kw - 1) * w_dim1;
rowmax = (d__1 = w[i__1].r, abs(d__1)) +
(d__2 = d_lmp_imag(&w[jmax + (kw - 1) * w_dim1]), abs(d__2));
if (imax > 1) {
i__1 = imax - 1;
jmax = izamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1);
i__1 = jmax + (kw - 1) * w_dim1;
d__3 = rowmax, d__4 = (d__1 = w[i__1].r, abs(d__1)) +
(d__2 = d_lmp_imag(&w[jmax + (kw - 1) * w_dim1]), abs(d__2));
rowmax = max(d__3, d__4);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
kp = k;
} else {
i__1 = imax + (kw - 1) * w_dim1;
if ((d__1 = w[i__1].r, abs(d__1)) +
(d__2 = d_lmp_imag(&w[imax + (kw - 1) * w_dim1]), abs(d__2)) >=
alpha * rowmax) {
kp = imax;
zcopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1);
} else {
kp = imax;
kstep = 2;
}
}
}
kk = k - kstep + 1;
kkw = *nb + kk - *n;
if (kp != kk) {
i__1 = kp + kp * a_dim1;
i__2 = kk + kk * a_dim1;
a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
i__1 = kk - 1 - kp;
zcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + 1) * a_dim1], lda);
if (kp > 1) {
i__1 = kp - 1;
zcopy_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], &c__1);
}
if (k < *n) {
i__1 = *n - k;
zswap_(&i__1, &a[kk + (k + 1) * a_dim1], lda, &a[kp + (k + 1) * a_dim1], lda);
}
i__1 = *n - kk + 1;
zswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw * w_dim1], ldw);
}
if (kstep == 1) {
zcopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1);
z_lmp_div(&z__1, &c_b1, &a[k + k * a_dim1]);
r1.r = z__1.r, r1.i = z__1.i;
i__1 = k - 1;
zscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1);
} else {
if (k > 2) {
i__1 = k - 1 + kw * w_dim1;
d21.r = w[i__1].r, d21.i = w[i__1].i;
z_lmp_div(&z__1, &w[k + kw * w_dim1], &d21);
d11.r = z__1.r, d11.i = z__1.i;
z_lmp_div(&z__1, &w[k - 1 + (kw - 1) * w_dim1], &d21);
d22.r = z__1.r, d22.i = z__1.i;
z__3.r = d11.r * d22.r - d11.i * d22.i, z__3.i = d11.r * d22.i + d11.i * d22.r;
z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.;
z_lmp_div(&z__1, &c_b1, &z__2);
t.r = z__1.r, t.i = z__1.i;
z_lmp_div(&z__1, &t, &d21);
d21.r = z__1.r, d21.i = z__1.i;
i__1 = k - 2;
for (j = 1; j <= i__1; ++j) {
i__2 = j + (k - 1) * a_dim1;
i__3 = j + (kw - 1) * w_dim1;
z__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i,
z__3.i = d11.r * w[i__3].i + d11.i * w[i__3].r;
i__4 = j + kw * w_dim1;
z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4].i;
z__1.r = d21.r * z__2.r - d21.i * z__2.i,
z__1.i = d21.r * z__2.i + d21.i * z__2.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = j + k * a_dim1;
i__3 = j + kw * w_dim1;
z__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i,
z__3.i = d22.r * w[i__3].i + d22.i * w[i__3].r;
i__4 = j + (kw - 1) * w_dim1;
z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4].i;
z__1.r = d21.r * z__2.r - d21.i * z__2.i,
z__1.i = d21.r * z__2.i + d21.i * z__2.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
}
i__1 = k - 1 + (k - 1) * a_dim1;
i__2 = k - 1 + (kw - 1) * w_dim1;
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = k - 1 + k * a_dim1;
i__2 = k - 1 + kw * w_dim1;
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = k + k * a_dim1;
i__2 = k + kw * w_dim1;
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
}
}
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k - 1] = -kp;
}
k -= kstep;
goto L10;
L30:
i__1 = -(*nb);
for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j += i__1) {
i__2 = *nb, i__3 = k - j + 1;
jb = min(i__2, i__3);
i__2 = j + jb - 1;
for (jj = j; jj <= i__2; ++jj) {
i__3 = jj - j + 1;
i__4 = *n - k;
z__1.r = -1., z__1.i = -0.;
zgemv_((char *)"No transpose", &i__3, &i__4, &z__1, &a[j + (k + 1) * a_dim1], lda,
&w[jj + (kw + 1) * w_dim1], ldw, &c_b1, &a[j + jj * a_dim1], &c__1,
(ftnlen)12);
}
i__2 = j - 1;
i__3 = *n - k;
z__1.r = -1., z__1.i = -0.;
zgemm_((char *)"No transpose", (char *)"Transpose", &i__2, &jb, &i__3, &z__1, &a[(k + 1) * a_dim1 + 1],
lda, &w[j + (kw + 1) * w_dim1], ldw, &c_b1, &a[j * a_dim1 + 1], lda, (ftnlen)12,
(ftnlen)9);
}
j = k + 1;
L60:
jj = j;
jp = ipiv[j];
if (jp < 0) {
jp = -jp;
++j;
}
++j;
if (jp != jj && j <= *n) {
i__1 = *n - j + 1;
zswap_(&i__1, &a[jp + j * a_dim1], lda, &a[jj + j * a_dim1], lda);
}
if (j < *n) {
goto L60;
}
*kb = *n - k;
} else {
k = 1;
L70:
if (k >= *nb && *nb < *n || k > *n) {
goto L90;
}
i__1 = *n - k + 1;
zcopy_(&i__1, &a[k + k * a_dim1], &c__1, &w[k + k * w_dim1], &c__1);
i__1 = *n - k + 1;
i__2 = k - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_((char *)"No transpose", &i__1, &i__2, &z__1, &a[k + a_dim1], lda, &w[k + w_dim1], ldw, &c_b1,
&w[k + k * w_dim1], &c__1, (ftnlen)12);
kstep = 1;
i__1 = k + k * w_dim1;
absakk = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_lmp_imag(&w[k + k * w_dim1]), abs(d__2));
if (k < *n) {
i__1 = *n - k;
imax = k + izamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1);
i__1 = imax + k * w_dim1;
colmax =
(d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_lmp_imag(&w[imax + k * w_dim1]), abs(d__2));
} else {
colmax = 0.;
}
if (max(absakk, colmax) == 0.) {
if (*info == 0) {
*info = k;
}
kp = k;
} else {
if (absakk >= alpha * colmax) {
kp = k;
} else {
i__1 = imax - k;
zcopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) * w_dim1], &c__1);
i__1 = *n - imax + 1;
zcopy_(&i__1, &a[imax + imax * a_dim1], &c__1, &w[imax + (k + 1) * w_dim1], &c__1);
i__1 = *n - k + 1;
i__2 = k - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_((char *)"No transpose", &i__1, &i__2, &z__1, &a[k + a_dim1], lda, &w[imax + w_dim1],
ldw, &c_b1, &w[k + (k + 1) * w_dim1], &c__1, (ftnlen)12);
i__1 = imax - k;
jmax = k - 1 + izamax_(&i__1, &w[k + (k + 1) * w_dim1], &c__1);
i__1 = jmax + (k + 1) * w_dim1;
rowmax = (d__1 = w[i__1].r, abs(d__1)) +
(d__2 = d_lmp_imag(&w[jmax + (k + 1) * w_dim1]), abs(d__2));
if (imax < *n) {
i__1 = *n - imax;
jmax = imax + izamax_(&i__1, &w[imax + 1 + (k + 1) * w_dim1], &c__1);
i__1 = jmax + (k + 1) * w_dim1;
d__3 = rowmax, d__4 = (d__1 = w[i__1].r, abs(d__1)) +
(d__2 = d_lmp_imag(&w[jmax + (k + 1) * w_dim1]), abs(d__2));
rowmax = max(d__3, d__4);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
kp = k;
} else {
i__1 = imax + (k + 1) * w_dim1;
if ((d__1 = w[i__1].r, abs(d__1)) +
(d__2 = d_lmp_imag(&w[imax + (k + 1) * w_dim1]), abs(d__2)) >=
alpha * rowmax) {
kp = imax;
i__1 = *n - k + 1;
zcopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * w_dim1], &c__1);
} else {
kp = imax;
kstep = 2;
}
}
}
kk = k + kstep - 1;
if (kp != kk) {
i__1 = kp + kp * a_dim1;
i__2 = kk + kk * a_dim1;
a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
i__1 = kp - kk - 1;
zcopy_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk + 1) * a_dim1], lda);
if (kp < *n) {
i__1 = *n - kp;
zcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1 + kp * a_dim1], &c__1);
}
if (k > 1) {
i__1 = k - 1;
zswap_(&i__1, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda);
}
zswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw);
}
if (kstep == 1) {
i__1 = *n - k + 1;
zcopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], &c__1);
if (k < *n) {
z_lmp_div(&z__1, &c_b1, &a[k + k * a_dim1]);
r1.r = z__1.r, r1.i = z__1.i;
i__1 = *n - k;
zscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1);
}
} else {
if (k < *n - 1) {
i__1 = k + 1 + k * w_dim1;
d21.r = w[i__1].r, d21.i = w[i__1].i;
z_lmp_div(&z__1, &w[k + 1 + (k + 1) * w_dim1], &d21);
d11.r = z__1.r, d11.i = z__1.i;
z_lmp_div(&z__1, &w[k + k * w_dim1], &d21);
d22.r = z__1.r, d22.i = z__1.i;
z__3.r = d11.r * d22.r - d11.i * d22.i, z__3.i = d11.r * d22.i + d11.i * d22.r;
z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.;
z_lmp_div(&z__1, &c_b1, &z__2);
t.r = z__1.r, t.i = z__1.i;
z_lmp_div(&z__1, &t, &d21);
d21.r = z__1.r, d21.i = z__1.i;
i__1 = *n;
for (j = k + 2; j <= i__1; ++j) {
i__2 = j + k * a_dim1;
i__3 = j + k * w_dim1;
z__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i,
z__3.i = d11.r * w[i__3].i + d11.i * w[i__3].r;
i__4 = j + (k + 1) * w_dim1;
z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4].i;
z__1.r = d21.r * z__2.r - d21.i * z__2.i,
z__1.i = d21.r * z__2.i + d21.i * z__2.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = j + (k + 1) * a_dim1;
i__3 = j + (k + 1) * w_dim1;
z__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i,
z__3.i = d22.r * w[i__3].i + d22.i * w[i__3].r;
i__4 = j + k * w_dim1;
z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4].i;
z__1.r = d21.r * z__2.r - d21.i * z__2.i,
z__1.i = d21.r * z__2.i + d21.i * z__2.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
}
i__1 = k + k * a_dim1;
i__2 = k + k * w_dim1;
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = k + 1 + k * a_dim1;
i__2 = k + 1 + k * w_dim1;
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = k + 1 + (k + 1) * a_dim1;
i__2 = k + 1 + (k + 1) * w_dim1;
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
}
}
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k + 1] = -kp;
}
k += kstep;
goto L70;
L90:
i__1 = *n;
i__2 = *nb;
for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
i__3 = *nb, i__4 = *n - j + 1;
jb = min(i__3, i__4);
i__3 = j + jb - 1;
for (jj = j; jj <= i__3; ++jj) {
i__4 = j + jb - jj;
i__5 = k - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_((char *)"No transpose", &i__4, &i__5, &z__1, &a[jj + a_dim1], lda, &w[jj + w_dim1],
ldw, &c_b1, &a[jj + jj * a_dim1], &c__1, (ftnlen)12);
}
if (j + jb <= *n) {
i__3 = *n - j - jb + 1;
i__4 = k - 1;
z__1.r = -1., z__1.i = -0.;
zgemm_((char *)"No transpose", (char *)"Transpose", &i__3, &jb, &i__4, &z__1, &a[j + jb + a_dim1],
lda, &w[j + w_dim1], ldw, &c_b1, &a[j + jb + j * a_dim1], lda, (ftnlen)12,
(ftnlen)9);
}
}
j = k - 1;
L120:
jj = j;
jp = ipiv[j];
if (jp < 0) {
jp = -jp;
--j;
}
--j;
if (jp != jj && j >= 1) {
zswap_(&j, &a[jp + a_dim1], lda, &a[jj + a_dim1], lda);
}
if (j > 1) {
goto L120;
}
*kb = k - 1;
}
return 0;
}
#ifdef __cplusplus
}
#endif

100
lib/linalg/zlauu2.cpp Normal file
View File

@ -0,0 +1,100 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static doublecomplex c_b1 = {1., 0.};
static integer c__1 = 1;
int zlauu2_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *info, ftnlen uplo_len)
{
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1;
integer i__;
doublereal aii;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern VOID zdotc_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *);
extern int zgemv_(char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *,
ftnlen);
logical upper;
extern int xerbla_(char *, integer *, ftnlen),
zdscal_(integer *, doublereal *, doublecomplex *, integer *),
zlacgv_(integer *, doublecomplex *, integer *);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
*info = 0;
upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1);
if (!upper && !lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1, *n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"ZLAUU2", &i__1, (ftnlen)6);
return 0;
}
if (*n == 0) {
return 0;
}
if (upper) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + i__ * a_dim1;
aii = a[i__2].r;
if (i__ < *n) {
i__2 = i__ + i__ * a_dim1;
i__3 = *n - i__;
zdotc_(&z__1, &i__3, &a[i__ + (i__ + 1) * a_dim1], lda,
&a[i__ + (i__ + 1) * a_dim1], lda);
d__1 = aii * aii + z__1.r;
a[i__2].r = d__1, a[i__2].i = 0.;
i__2 = *n - i__;
zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
i__2 = i__ - 1;
i__3 = *n - i__;
z__1.r = aii, z__1.i = 0.;
zgemv_((char *)"No transpose", &i__2, &i__3, &c_b1, &a[(i__ + 1) * a_dim1 + 1], lda,
&a[i__ + (i__ + 1) * a_dim1], lda, &z__1, &a[i__ * a_dim1 + 1], &c__1,
(ftnlen)12);
i__2 = *n - i__;
zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
} else {
zdscal_(&i__, &aii, &a[i__ * a_dim1 + 1], &c__1);
}
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + i__ * a_dim1;
aii = a[i__2].r;
if (i__ < *n) {
i__2 = i__ + i__ * a_dim1;
i__3 = *n - i__;
zdotc_(&z__1, &i__3, &a[i__ + 1 + i__ * a_dim1], &c__1, &a[i__ + 1 + i__ * a_dim1],
&c__1);
d__1 = aii * aii + z__1.r;
a[i__2].r = d__1, a[i__2].i = 0.;
i__2 = i__ - 1;
zlacgv_(&i__2, &a[i__ + a_dim1], lda);
i__2 = *n - i__;
i__3 = i__ - 1;
z__1.r = aii, z__1.i = 0.;
zgemv_((char *)"Conjugate transpose", &i__2, &i__3, &c_b1, &a[i__ + 1 + a_dim1], lda,
&a[i__ + 1 + i__ * a_dim1], &c__1, &z__1, &a[i__ + a_dim1], lda, (ftnlen)19);
i__2 = i__ - 1;
zlacgv_(&i__2, &a[i__ + a_dim1], lda);
} else {
zdscal_(&i__, &aii, &a[i__ + a_dim1], lda);
}
}
}
return 0;
}
#ifdef __cplusplus
}
#endif

103
lib/linalg/zlauum.cpp Normal file
View File

@ -0,0 +1,103 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static doublecomplex c_b1 = {1., 0.};
static integer c__1 = 1;
static integer c_n1 = -1;
static doublereal c_b21 = 1.;
int zlauum_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *info, ftnlen uplo_len)
{
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
integer i__, ib, nb;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern int zgemm_(char *, char *, integer *, integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, ftnlen, ftnlen),
zherk_(char *, char *, integer *, integer *, doublereal *, doublecomplex *, integer *,
doublereal *, doublecomplex *, integer *, ftnlen, ftnlen);
logical upper;
extern int ztrmm_(char *, char *, char *, char *, integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, ftnlen, ftnlen,
ftnlen, ftnlen),
zlauu2_(char *, integer *, doublecomplex *, integer *, integer *, ftnlen),
xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
*info = 0;
upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1);
if (!upper && !lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1, *n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"ZLAUUM", &i__1, (ftnlen)6);
return 0;
}
if (*n == 0) {
return 0;
}
nb = ilaenv_(&c__1, (char *)"ZLAUUM", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
if (nb <= 1 || nb >= *n) {
zlauu2_(uplo, n, &a[a_offset], lda, info, (ftnlen)1);
} else {
if (upper) {
i__1 = *n;
i__2 = nb;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
i__3 = nb, i__4 = *n - i__ + 1;
ib = min(i__3, i__4);
i__3 = i__ - 1;
ztrmm_((char *)"Right", (char *)"Upper", (char *)"Conjugate transpose", (char *)"Non-unit", &i__3, &ib, &c_b1,
&a[i__ + i__ * a_dim1], lda, &a[i__ * a_dim1 + 1], lda, (ftnlen)5, (ftnlen)5,
(ftnlen)19, (ftnlen)8);
zlauu2_((char *)"Upper", &ib, &a[i__ + i__ * a_dim1], lda, info, (ftnlen)5);
if (i__ + ib <= *n) {
i__3 = i__ - 1;
i__4 = *n - i__ - ib + 1;
zgemm_((char *)"No transpose", (char *)"Conjugate transpose", &i__3, &ib, &i__4, &c_b1,
&a[(i__ + ib) * a_dim1 + 1], lda, &a[i__ + (i__ + ib) * a_dim1], lda,
&c_b1, &a[i__ * a_dim1 + 1], lda, (ftnlen)12, (ftnlen)19);
i__3 = *n - i__ - ib + 1;
zherk_((char *)"Upper", (char *)"No transpose", &ib, &i__3, &c_b21,
&a[i__ + (i__ + ib) * a_dim1], lda, &c_b21, &a[i__ + i__ * a_dim1], lda,
(ftnlen)5, (ftnlen)12);
}
}
} else {
i__2 = *n;
i__1 = nb;
for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
i__3 = nb, i__4 = *n - i__ + 1;
ib = min(i__3, i__4);
i__3 = i__ - 1;
ztrmm_((char *)"Left", (char *)"Lower", (char *)"Conjugate transpose", (char *)"Non-unit", &ib, &i__3, &c_b1,
&a[i__ + i__ * a_dim1], lda, &a[i__ + a_dim1], lda, (ftnlen)4, (ftnlen)5,
(ftnlen)19, (ftnlen)8);
zlauu2_((char *)"Lower", &ib, &a[i__ + i__ * a_dim1], lda, info, (ftnlen)5);
if (i__ + ib <= *n) {
i__3 = i__ - 1;
i__4 = *n - i__ - ib + 1;
zgemm_((char *)"Conjugate transpose", (char *)"No transpose", &ib, &i__3, &i__4, &c_b1,
&a[i__ + ib + i__ * a_dim1], lda, &a[i__ + ib + a_dim1], lda, &c_b1,
&a[i__ + a_dim1], lda, (ftnlen)19, (ftnlen)12);
i__3 = *n - i__ - ib + 1;
zherk_((char *)"Lower", (char *)"Conjugate transpose", &ib, &i__3, &c_b21,
&a[i__ + ib + i__ * a_dim1], lda, &c_b21, &a[i__ + i__ * a_dim1], lda,
(ftnlen)5, (ftnlen)19);
}
}
}
}
return 0;
}
#ifdef __cplusplus
}
#endif

115
lib/linalg/zpotrf.cpp Normal file
View File

@ -0,0 +1,115 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static doublecomplex c_b1 = {1., 0.};
static integer c__1 = 1;
static integer c_n1 = -1;
static doublereal c_b14 = -1.;
static doublereal c_b15 = 1.;
int zpotrf_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *info, ftnlen uplo_len)
{
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
doublecomplex z__1;
integer j, jb, nb;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern int zgemm_(char *, char *, integer *, integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, ftnlen, ftnlen),
zherk_(char *, char *, integer *, integer *, doublereal *, doublecomplex *, integer *,
doublereal *, doublecomplex *, integer *, ftnlen, ftnlen);
logical upper;
extern int ztrsm_(char *, char *, char *, char *, integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, ftnlen, ftnlen,
ftnlen, ftnlen),
xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
ftnlen, ftnlen);
extern int zpotrf2_(char *, integer *, doublecomplex *, integer *, integer *, ftnlen);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
*info = 0;
upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1);
if (!upper && !lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1, *n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"ZPOTRF", &i__1, (ftnlen)6);
return 0;
}
if (*n == 0) {
return 0;
}
nb = ilaenv_(&c__1, (char *)"ZPOTRF", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
if (nb <= 1 || nb >= *n) {
zpotrf2_(uplo, n, &a[a_offset], lda, info, (ftnlen)1);
} else {
if (upper) {
i__1 = *n;
i__2 = nb;
for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
i__3 = nb, i__4 = *n - j + 1;
jb = min(i__3, i__4);
i__3 = j - 1;
zherk_((char *)"Upper", (char *)"Conjugate transpose", &jb, &i__3, &c_b14, &a[j * a_dim1 + 1], lda,
&c_b15, &a[j + j * a_dim1], lda, (ftnlen)5, (ftnlen)19);
zpotrf2_((char *)"Upper", &jb, &a[j + j * a_dim1], lda, info, (ftnlen)5);
if (*info != 0) {
goto L30;
}
if (j + jb <= *n) {
i__3 = *n - j - jb + 1;
i__4 = j - 1;
z__1.r = -1., z__1.i = -0.;
zgemm_((char *)"Conjugate transpose", (char *)"No transpose", &jb, &i__3, &i__4, &z__1,
&a[j * a_dim1 + 1], lda, &a[(j + jb) * a_dim1 + 1], lda, &c_b1,
&a[j + (j + jb) * a_dim1], lda, (ftnlen)19, (ftnlen)12);
i__3 = *n - j - jb + 1;
ztrsm_((char *)"Left", (char *)"Upper", (char *)"Conjugate transpose", (char *)"Non-unit", &jb, &i__3, &c_b1,
&a[j + j * a_dim1], lda, &a[j + (j + jb) * a_dim1], lda, (ftnlen)4,
(ftnlen)5, (ftnlen)19, (ftnlen)8);
}
}
} else {
i__2 = *n;
i__1 = nb;
for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
i__3 = nb, i__4 = *n - j + 1;
jb = min(i__3, i__4);
i__3 = j - 1;
zherk_((char *)"Lower", (char *)"No transpose", &jb, &i__3, &c_b14, &a[j + a_dim1], lda, &c_b15,
&a[j + j * a_dim1], lda, (ftnlen)5, (ftnlen)12);
zpotrf2_((char *)"Lower", &jb, &a[j + j * a_dim1], lda, info, (ftnlen)5);
if (*info != 0) {
goto L30;
}
if (j + jb <= *n) {
i__3 = *n - j - jb + 1;
i__4 = j - 1;
z__1.r = -1., z__1.i = -0.;
zgemm_((char *)"No transpose", (char *)"Conjugate transpose", &i__3, &jb, &i__4, &z__1,
&a[j + jb + a_dim1], lda, &a[j + a_dim1], lda, &c_b1,
&a[j + jb + j * a_dim1], lda, (ftnlen)12, (ftnlen)19);
i__3 = *n - j - jb + 1;
ztrsm_((char *)"Right", (char *)"Lower", (char *)"Conjugate transpose", (char *)"Non-unit", &i__3, &jb, &c_b1,
&a[j + j * a_dim1], lda, &a[j + jb + j * a_dim1], lda, (ftnlen)5,
(ftnlen)5, (ftnlen)19, (ftnlen)8);
}
}
}
}
goto L40;
L30:
*info = *info + j - 1;
L40:
return 0;
}
#ifdef __cplusplus
}
#endif

89
lib/linalg/zpotrf2.cpp Normal file
View File

@ -0,0 +1,89 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
static doublecomplex c_b1 = {1., 0.};
static doublereal c_b11 = -1.;
static doublereal c_b12 = 1.;
int zpotrf2_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *info, ftnlen uplo_len)
{
integer a_dim1, a_offset, i__1;
doublereal d__1;
double sqrt(doublereal);
integer n1, n2;
doublereal ajj;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
integer iinfo;
extern int zherk_(char *, char *, integer *, integer *, doublereal *, doublecomplex *,
integer *, doublereal *, doublecomplex *, integer *, ftnlen, ftnlen);
logical upper;
extern int ztrsm_(char *, char *, char *, char *, integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, ftnlen, ftnlen,
ftnlen, ftnlen);
extern logical disnan_(doublereal *);
extern int xerbla_(char *, integer *, ftnlen);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
*info = 0;
upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1);
if (!upper && !lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1, *n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"ZPOTRF2", &i__1, (ftnlen)7);
return 0;
}
if (*n == 0) {
return 0;
}
if (*n == 1) {
i__1 = a_dim1 + 1;
ajj = a[i__1].r;
if (ajj <= 0. || disnan_(&ajj)) {
*info = 1;
return 0;
}
i__1 = a_dim1 + 1;
d__1 = sqrt(ajj);
a[i__1].r = d__1, a[i__1].i = 0.;
} else {
n1 = *n / 2;
n2 = *n - n1;
zpotrf2_(uplo, &n1, &a[a_dim1 + 1], lda, &iinfo, (ftnlen)1);
if (iinfo != 0) {
*info = iinfo;
return 0;
}
if (upper) {
ztrsm_((char *)"L", (char *)"U", (char *)"C", (char *)"N", &n1, &n2, &c_b1, &a[a_dim1 + 1], lda,
&a[(n1 + 1) * a_dim1 + 1], lda, (ftnlen)1, (ftnlen)1, (ftnlen)1, (ftnlen)1);
zherk_(uplo, (char *)"C", &n2, &n1, &c_b11, &a[(n1 + 1) * a_dim1 + 1], lda, &c_b12,
&a[n1 + 1 + (n1 + 1) * a_dim1], lda, (ftnlen)1, (ftnlen)1);
zpotrf2_(uplo, &n2, &a[n1 + 1 + (n1 + 1) * a_dim1], lda, &iinfo, (ftnlen)1);
if (iinfo != 0) {
*info = iinfo + n1;
return 0;
}
} else {
ztrsm_((char *)"R", (char *)"L", (char *)"C", (char *)"N", &n2, &n1, &c_b1, &a[a_dim1 + 1], lda, &a[n1 + 1 + a_dim1],
lda, (ftnlen)1, (ftnlen)1, (ftnlen)1, (ftnlen)1);
zherk_(uplo, (char *)"N", &n2, &n1, &c_b11, &a[n1 + 1 + a_dim1], lda, &c_b12,
&a[n1 + 1 + (n1 + 1) * a_dim1], lda, (ftnlen)1, (ftnlen)1);
zpotrf2_(uplo, &n2, &a[n1 + 1 + (n1 + 1) * a_dim1], lda, &iinfo, (ftnlen)1);
if (iinfo != 0) {
*info = iinfo + n1;
return 0;
}
}
}
return 0;
}
#ifdef __cplusplus
}
#endif

40
lib/linalg/zpotri.cpp Normal file
View File

@ -0,0 +1,40 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
int zpotri_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *info, ftnlen uplo_len)
{
integer a_dim1, a_offset, i__1;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern int xerbla_(char *, integer *, ftnlen),
zlauum_(char *, integer *, doublecomplex *, integer *, integer *, ftnlen),
ztrtri_(char *, char *, integer *, doublecomplex *, integer *, integer *, ftnlen, ftnlen);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
*info = 0;
if (!lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1) && !lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1, *n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_((char *)"ZPOTRI", &i__1, (ftnlen)6);
return 0;
}
if (*n == 0) {
return 0;
}
ztrtri_(uplo, (char *)"Non-unit", n, &a[a_offset], lda, info, (ftnlen)1, (ftnlen)8);
if (*info > 0) {
return 0;
}
zlauum_(uplo, n, &a[a_offset], lda, info, (ftnlen)1);
return 0;
}
#ifdef __cplusplus
}
#endif

263
lib/linalg/zsymv.cpp Normal file
View File

@ -0,0 +1,263 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
int zsymv_(char *uplo, integer *n, doublecomplex *alpha, doublecomplex *a, integer *lda,
doublecomplex *x, integer *incx, doublecomplex *beta, doublecomplex *y, integer *incy,
ftnlen uplo_len)
{
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
doublecomplex z__1, z__2, z__3, z__4;
integer i__, j, ix, iy, jx, jy, kx, ky, info;
doublecomplex temp1, temp2;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern int xerbla_(char *, integer *, ftnlen);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--x;
--y;
info = 0;
if (!lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1) && !lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) {
info = 1;
} else if (*n < 0) {
info = 2;
} else if (*lda < max(1, *n)) {
info = 5;
} else if (*incx == 0) {
info = 7;
} else if (*incy == 0) {
info = 10;
}
if (info != 0) {
xerbla_((char *)"ZSYMV ", &info, (ftnlen)6);
return 0;
}
if (*n == 0 || alpha->r == 0. && alpha->i == 0. && (beta->r == 1. && beta->i == 0.)) {
return 0;
}
if (*incx > 0) {
kx = 1;
} else {
kx = 1 - (*n - 1) * *incx;
}
if (*incy > 0) {
ky = 1;
} else {
ky = 1 - (*n - 1) * *incy;
}
if (beta->r != 1. || beta->i != 0.) {
if (*incy == 1) {
if (beta->r == 0. && beta->i == 0.) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
y[i__2].r = 0., y[i__2].i = 0.;
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__;
z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
z__1.i = beta->r * y[i__3].i + beta->i * y[i__3].r;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
}
}
} else {
iy = ky;
if (beta->r == 0. && beta->i == 0.) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iy;
y[i__2].r = 0., y[i__2].i = 0.;
iy += *incy;
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iy;
i__3 = iy;
z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
z__1.i = beta->r * y[i__3].i + beta->i * y[i__3].r;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
iy += *incy;
}
}
}
}
if (alpha->r == 0. && alpha->i == 0.) {
return 0;
}
if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) {
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.;
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__ + j * a_dim1;
z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5].r;
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
i__3 = i__ + j * a_dim1;
i__4 = i__;
z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4].r;
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
temp2.r = z__1.r, temp2.i = z__1.i;
}
i__2 = j;
i__3 = j;
i__4 = j + j * a_dim1;
z__3.r = temp1.r * a[i__4].r - temp1.i * a[i__4].i,
z__3.i = temp1.r * a[i__4].i + temp1.i * a[i__4].r;
z__2.r = y[i__3].r + z__3.r, z__2.i = y[i__3].i + z__3.i;
z__4.r = alpha->r * temp2.r - alpha->i * temp2.i,
z__4.i = alpha->r * temp2.i + alpha->i * temp2.r;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = jx;
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.;
ix = kx;
iy = ky;
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = iy;
i__4 = iy;
i__5 = i__ + j * a_dim1;
z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5].r;
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
i__3 = i__ + j * a_dim1;
i__4 = ix;
z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4].r;
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
temp2.r = z__1.r, temp2.i = z__1.i;
ix += *incx;
iy += *incy;
}
i__2 = jy;
i__3 = jy;
i__4 = j + j * a_dim1;
z__3.r = temp1.r * a[i__4].r - temp1.i * a[i__4].i,
z__3.i = temp1.r * a[i__4].i + temp1.i * a[i__4].r;
z__2.r = y[i__3].r + z__3.r, z__2.i = y[i__3].i + z__3.i;
z__4.r = alpha->r * temp2.r - alpha->i * temp2.i,
z__4.i = alpha->r * temp2.i + alpha->i * temp2.r;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
jx += *incx;
jy += *incy;
}
}
} else {
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.;
i__2 = j;
i__3 = j;
i__4 = j + j * a_dim1;
z__2.r = temp1.r * a[i__4].r - temp1.i * a[i__4].i,
z__2.i = temp1.r * a[i__4].i + temp1.i * a[i__4].r;
z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__ + j * a_dim1;
z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5].r;
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
i__3 = i__ + j * a_dim1;
i__4 = i__;
z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4].r;
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
temp2.r = z__1.r, temp2.i = z__1.i;
}
i__2 = j;
i__3 = j;
z__2.r = alpha->r * temp2.r - alpha->i * temp2.i,
z__2.i = alpha->r * temp2.i + alpha->i * temp2.r;
z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
}
} else {
jx = kx;
jy = ky;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = jx;
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp1.r = z__1.r, temp1.i = z__1.i;
temp2.r = 0., temp2.i = 0.;
i__2 = jy;
i__3 = jy;
i__4 = j + j * a_dim1;
z__2.r = temp1.r * a[i__4].r - temp1.i * a[i__4].i,
z__2.i = temp1.r * a[i__4].i + temp1.i * a[i__4].r;
z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
ix = jx;
iy = jy;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
ix += *incx;
iy += *incy;
i__3 = iy;
i__4 = iy;
i__5 = i__ + j * a_dim1;
z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5].r;
z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
y[i__3].r = z__1.r, y[i__3].i = z__1.i;
i__3 = i__ + j * a_dim1;
i__4 = ix;
z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4].r;
z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
temp2.r = z__1.r, temp2.i = z__1.i;
}
i__2 = jy;
i__3 = jy;
z__2.r = alpha->r * temp2.r - alpha->i * temp2.i,
z__2.i = alpha->r * temp2.i + alpha->i * temp2.r;
z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
y[i__2].r = z__1.r, y[i__2].i = z__1.i;
jx += *incx;
jy += *incy;
}
}
}
return 0;
}
#ifdef __cplusplus
}
#endif

141
lib/linalg/zsyr.cpp Normal file
View File

@ -0,0 +1,141 @@
#ifdef __cplusplus
extern "C" {
#endif
#include "lmp_f2c.h"
int zsyr_(char *uplo, integer *n, doublecomplex *alpha, doublecomplex *x, integer *incx,
doublecomplex *a, integer *lda, ftnlen uplo_len)
{
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
doublecomplex z__1, z__2;
integer i__, j, ix, jx, kx, info;
doublecomplex temp;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern int xerbla_(char *, integer *, ftnlen);
--x;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
info = 0;
if (!lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1) && !lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) {
info = 1;
} else if (*n < 0) {
info = 2;
} else if (*incx == 0) {
info = 5;
} else if (*lda < max(1, *n)) {
info = 7;
}
if (info != 0) {
xerbla_((char *)"ZSYR ", &info, (ftnlen)6);
return 0;
}
if (*n == 0 || alpha->r == 0. && alpha->i == 0.) {
return 0;
}
if (*incx <= 0) {
kx = 1 - (*n - 1) * *incx;
} else if (*incx != 1) {
kx = 1;
}
if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) {
if (*incx == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
if (x[i__2].r != 0. || x[i__2].i != 0.) {
i__2 = j;
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp.r = z__1.r, temp.i = z__1.i;
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
i__5 = i__;
z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
z__2.i = x[i__5].r * temp.i + x[i__5].i * temp.r;
z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i + z__2.i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
}
}
}
} else {
jx = kx;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = jx;
if (x[i__2].r != 0. || x[i__2].i != 0.) {
i__2 = jx;
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp.r = z__1.r, temp.i = z__1.i;
ix = kx;
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
i__5 = ix;
z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
z__2.i = x[i__5].r * temp.i + x[i__5].i * temp.r;
z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i + z__2.i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
ix += *incx;
}
}
jx += *incx;
}
}
} else {
if (*incx == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
if (x[i__2].r != 0. || x[i__2].i != 0.) {
i__2 = j;
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp.r = z__1.r, temp.i = z__1.i;
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
i__5 = i__;
z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
z__2.i = x[i__5].r * temp.i + x[i__5].i * temp.r;
z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i + z__2.i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
}
}
}
} else {
jx = kx;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = jx;
if (x[i__2].r != 0. || x[i__2].i != 0.) {
i__2 = jx;
z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2].r;
temp.r = z__1.r, temp.i = z__1.i;
ix = jx;
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
i__5 = ix;
z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
z__2.i = x[i__5].r * temp.i + x[i__5].i * temp.r;
z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i + z__2.i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
ix += *incx;
}
}
jx += *incx;
}
}
}
return 0;
}
#ifdef __cplusplus
}
#endif

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