diff --git a/cmake/CMakeLists.txt b/cmake/CMakeLists.txt index 3a185564d3..11a6098ed7 100644 --- a/cmake/CMakeLists.txt +++ b/cmake/CMakeLists.txt @@ -440,16 +440,12 @@ if(PKG_MSCG OR PKG_ATC OR PKG_AWPMD OR PKG_ML-QUIP OR PKG_ML-POD OR PKG_LATTE OR find_package(BLAS) endif() if(NOT LAPACK_FOUND OR NOT BLAS_FOUND OR USE_INTERNAL_LINALG) - include(CheckGeneratorSupport) - if(NOT CMAKE_GENERATOR_SUPPORT_FORTRAN) - status(FATAL_ERROR "Cannot build internal linear algebra library as CMake build tool lacks Fortran support") - endif() - enable_language(Fortran) - file(GLOB LAPACK_SOURCES ${LAMMPS_LIB_SOURCE_DIR}/linalg/[^.]*.[fF]) - add_library(linalg STATIC ${LAPACK_SOURCES}) + file(GLOB LINALG_SOURCES ${LAMMPS_LIB_SOURCE_DIR}/linalg/[^.]*.cpp) + add_library(linalg STATIC ${LINALG_SOURCES}) set_target_properties(linalg PROPERTIES OUTPUT_NAME lammps_linalg${LAMMPS_MACHINE}) set(BLAS_LIBRARIES "$") set(LAPACK_LIBRARIES "$") + target_link_libraries(lammps PRIVATE linalg) else() list(APPEND LAPACK_LIBRARIES ${BLAS_LIBRARIES}) endif() diff --git a/cmake/CMakeSettings.json b/cmake/CMakeSettings.json index c139114c0b..205b443bf1 100644 --- a/cmake/CMakeSettings.json +++ b/cmake/CMakeSettings.json @@ -72,7 +72,7 @@ "configurationType": "Debug", "buildRoot": "${workspaceRoot}\\build\\${name}", "installRoot": "${workspaceRoot}\\install\\${name}", - "cmakeCommandArgs": "-C ${workspaceRoot}\\cmake\\presets\\windows.cmake -DCMAKE_C_COMPILER=clang-cl.exe -DCMAKE_CXX_COMPILER=clang-cl.exe", + "cmakeCommandArgs": "-C ${workspaceRoot}\\cmake\\presets\\windows.cmake -DCMAKE_C_COMPILER=clang-cl.exe -DCMAKE_CXX_COMPILER=clang-cl.exe -DBUILD_MPI=off", "buildCommandArgs": "", "ctestCommandArgs": "", "inheritEnvironments": [ "clang_cl_x64" ], @@ -105,7 +105,7 @@ "configurationType": "Release", "buildRoot": "${workspaceRoot}\\build\\${name}", "installRoot": "${workspaceRoot}\\install\\${name}", - "cmakeCommandArgs": "-C ${workspaceRoot}\\cmake\\presets\\windows.cmake -DCMAKE_C_COMPILER=clang-cl.exe -DCMAKE_CXX_COMPILER=clang-cl.exe", + "cmakeCommandArgs": "-C ${workspaceRoot}\\cmake\\presets\\windows.cmake -DCMAKE_C_COMPILER=clang-cl.exe -DCMAKE_CXX_COMPILER=clang-cl.exe -DBUILD_MPI=off", "buildCommandArgs": "", "ctestCommandArgs": "-V", "inheritEnvironments": [ "clang_cl_x64" ], @@ -305,4 +305,4 @@ ] } ] -} +} \ No newline at end of file diff --git a/cmake/Modules/Packages/ML-PACE.cmake b/cmake/Modules/Packages/ML-PACE.cmake index 0159f36c34..b64584e5a7 100644 --- a/cmake/Modules/Packages/ML-PACE.cmake +++ b/cmake/Modules/Packages/ML-PACE.cmake @@ -1,6 +1,6 @@ -set(PACELIB_URL "https://github.com/ICAMS/lammps-user-pace/archive/refs/tags/v.2022.10.15.tar.gz" CACHE STRING "URL for PACE evaluator library sources") +set(PACELIB_URL "https://github.com/ICAMS/lammps-user-pace/archive/refs/tags/v.2023.01.3.tar.gz" CACHE STRING "URL for PACE evaluator library sources") -set(PACELIB_MD5 "848ad6a6cc79fa82745927001fb1c9b5" CACHE STRING "MD5 checksum of PACE evaluator library tarball") +set(PACELIB_MD5 "f418d32b60e531063ac4285bf702b468" CACHE STRING "MD5 checksum of PACE evaluator library tarball") mark_as_advanced(PACELIB_URL) mark_as_advanced(PACELIB_MD5) diff --git a/cmake/presets/windows.cmake b/cmake/presets/windows.cmake index 21be0efefb..e93cd35daa 100644 --- a/cmake/presets/windows.cmake +++ b/cmake/presets/windows.cmake @@ -1,6 +1,7 @@ set(WIN_PACKAGES AMOEBA ASPHERE + AWPMD BOCS BODY BPM @@ -20,6 +21,7 @@ set(WIN_PACKAGES DPD-SMOOTH DRUDE EFF + ELECTRODE EXTRA-COMPUTE EXTRA-DUMP EXTRA-FIX @@ -35,6 +37,7 @@ set(WIN_PACKAGES MEAM MISC ML-IAP + ML-POD ML-SNAP MOFFF MOLECULE diff --git a/doc/src/Build_extras.rst b/doc/src/Build_extras.rst index 53dbb2c4ea..d1161164e9 100644 --- a/doc/src/Build_extras.rst +++ b/doc/src/Build_extras.rst @@ -861,11 +861,11 @@ library. .. code-block:: bash - make lib-latte # print help message - make lib-latte args="-b" # download and build in lib/latte/LATTE-master - make lib-latte args="-p $HOME/latte" # use existing LATTE installation in $HOME/latte - make lib-latte args="-b -m gfortran" # download and build in lib/latte and - # copy Makefile.lammps.gfortran to Makefile.lammps + make lib-latte # print help message + make lib-latte args="-b" # download and build in lib/latte/LATTE-master + make lib-latte args="-p $HOME/latte" # use existing LATTE installation in $HOME/latte + make lib-latte args="-b -m gfortran" # download and build in lib/latte and + # copy Makefile.lammps.gfortran to Makefile.lammps Note that 3 symbolic (soft) links, ``includelink`` and ``liblink`` and ``filelink.o``, are created in ``lib/latte`` to point to @@ -1211,10 +1211,10 @@ The ATC package requires the MANYBODY package also be installed. .. code-block:: bash - make lib-linalg # print help message - make lib-linalg args="-m serial" # build with GNU Fortran compiler (settings as with "make serial") - make lib-linalg args="-m mpi" # build with default MPI Fortran compiler (settings as with "make mpi") - make lib-linalg args="-m gfortran" # build with GNU Fortran compiler + make lib-linalg # print help message + make lib-linalg args="-m serial" # build with GNU C++ compiler (settings as with "make serial") + make lib-linalg args="-m mpi" # build with default MPI C++ compiler (settings as with "make mpi") + make lib-linalg args="-m g++" # build with GNU Fortran compiler ---------- @@ -1262,10 +1262,10 @@ AWPMD package .. code-block:: bash - make lib-linalg # print help message - make lib-linalg args="-m serial" # build with GNU Fortran compiler (settings as with "make serial") - make lib-linalg args="-m mpi" # build with default MPI Fortran compiler (settings as with "make mpi") - make lib-linalg args="-m gfortran" # build with GNU Fortran compiler + make lib-linalg # print help message + make lib-linalg args="-m serial" # build with GNU C++ compiler (settings as with "make serial") + make lib-linalg args="-m mpi" # build with default MPI C++ compiler (settings as with "make mpi") + make lib-linalg args="-m g++" # build with GNU C++ compiler ---------- @@ -1366,10 +1366,10 @@ This package depends on the KSPACE package. .. code-block:: bash - make lib-linalg # print help message - make lib-linalg args="-m serial" # build with GNU Fortran compiler (settings as with "make serial") - make lib-linalg args="-m mpi" # build with default MPI Fortran compiler (settings as with "make mpi") - make lib-linalg args="-m gfortran" # build with GNU Fortran compiler + make lib-linalg # print help message + make lib-linalg args="-m serial" # build with GNU C++ compiler (settings as with "make serial") + make lib-linalg args="-m mpi" # build with default MPI C++ compiler (settings as with "make mpi") + make lib-linalg args="-m g++" # build with GNU C++ compiler The package itself is activated with ``make yes-KSPACE`` and ``make yes-ELECTRODE`` @@ -1450,10 +1450,10 @@ ML-POD package .. code-block:: bash - make lib-linalg # print help message - make lib-linalg args="-m serial" # build with GNU Fortran compiler (settings as with "make serial") - make lib-linalg args="-m mpi" # build with default MPI Fortran compiler (settings as with "make mpi") - make lib-linalg args="-m gfortran" # build with GNU Fortran compiler + make lib-linalg # print help message + make lib-linalg args="-m serial" # build with GNU C++ compiler (settings as with "make serial") + make lib-linalg args="-m mpi" # build with default MPI C++ compiler (settings as with "make mpi") + make lib-linalg args="-m g++" # build with GNU C++ compiler The package itself is activated with ``make yes-ML-POD``. diff --git a/doc/src/Commands_all.rst b/doc/src/Commands_all.rst index bd9d0ed09c..4a035f5b41 100644 --- a/doc/src/Commands_all.rst +++ b/doc/src/Commands_all.rst @@ -24,6 +24,7 @@ table above. * :doc:`angle_coeff ` * :doc:`angle_style ` + * :doc:`angle_write ` * :doc:`atom_modify ` * :doc:`atom_style ` * :doc:`balance ` @@ -45,6 +46,7 @@ table above. * :doc:`dielectric ` * :doc:`dihedral_coeff ` * :doc:`dihedral_style ` + * :doc:`dihedral_write ` * :doc:`dimension ` * :doc:`displace_atoms ` * :doc:`dump ` diff --git a/doc/src/Packages_details.rst b/doc/src/Packages_details.rst index 99a8baf183..969765e3be 100644 --- a/doc/src/Packages_details.rst +++ b/doc/src/Packages_details.rst @@ -2548,17 +2548,18 @@ REACTION package **Contents:** -This package allows for complex bond topology changes (reactions) -during a running MD simulation, when using classical force fields. -Topology changes are defined in pre- and post-reaction molecule -templates and can include creation and deletion of bonds, angles, -dihedrals, impropers, atom types, bond types, angle types, dihedral -types, improper types, and/or atomic charges. Other options currently -available include reaction constraints (e.g. angle and Arrhenius -constraints), deletion of reaction byproducts or other small -molecules, and chiral-sensitive reactions. +This package implements the REACTER protocol, which allows for complex +bond topology changes (reactions) during a running MD simulation when +using classical force fields. Topology changes are defined in pre- and +post-reaction molecule templates and can include creation and deletion +of bonds, angles, dihedrals, impropers, atom types, bond types, angle +types, dihedral types, improper types, and/or atomic charges. Other +options currently available include reaction constraints (e.g., angle +and Arrhenius constraints), deletion of reaction byproducts or other +small molecules, creation of new atoms or molecules bonded to existing +atoms, and using LAMMPS variables for input parameters. -**Author:** Jacob R. Gissinger (CU Boulder) while at NASA Langley Research Center. +**Author:** Jacob R. Gissinger (NASA Langley Research Center). **Supporting info:** @@ -2568,7 +2569,8 @@ molecules, and chiral-sensitive reactions. * examples/PACKAGES/reaction * `2017 LAMMPS Workshop `_ * `2019 LAMMPS Workshop `_ -* reacter.org +* `2021 LAMMPS Workshop `_ +* `REACTER website (reacter.org) `_ ---------- diff --git a/doc/src/angle_table.rst b/doc/src/angle_table.rst index c0faa3f046..fba41db045 100644 --- a/doc/src/angle_table.rst +++ b/doc/src/angle_table.rst @@ -59,9 +59,12 @@ format of this file is described below. ---------- -Suitable tables for use with this angle style can be created using the -Python code in the ``tools/tabulate`` folder of the LAMMPS source code -distribution. +Suitable tables for use with this angle style can be created by LAMMPS +itself from existing angle styles using the :doc:`angle_write +` command. This can be useful to have a template file for +testing the angle style settings and to build a compatible custom file. +Another option to generate tables is the Python code in the +``tools/tabulate`` folder of the LAMMPS source code distribution. The format of a tabulated file is as follows (without the parenthesized comments): @@ -154,7 +157,7 @@ for more info. Related commands """""""""""""""" -:doc:`angle_coeff ` +:doc:`angle_coeff `, :doc:`angle_write ` Default """"""" diff --git a/doc/src/angle_write.rst b/doc/src/angle_write.rst new file mode 100644 index 0000000000..1541a7120a --- /dev/null +++ b/doc/src/angle_write.rst @@ -0,0 +1,99 @@ +.. index:: angle_write + +angle_write command +=================== + +Syntax +"""""" + +.. code-block:: LAMMPS + + angle_write atype N file keyword + +* atype = angle type +* N = # of values +* file = name of file to write values to +* keyword = section name in file for this set of tabulated values + +Examples +"""""""" + +.. code-block:: LAMMPS + + angle_write 1 500 table.txt Harmonic_1 + angle_write 3 1000 table.txt Harmonic_3 + +Description +""""""""""" + +.. versionadded:: TBD + +Write energy and force values to a file as a function of angle for the +currently defined angle potential. Force in this context means the +force with respect to the angle, not the force on individual atoms. +This is useful for plotting the potential function or otherwise +debugging its values. The resulting file can also be used as input for +use with :doc:`angle style table `. + +If the file already exists, the table of values is appended to the end +of the file to allow multiple tables of energy and force to be included +in one file. The individual sections may be identified by the *keyword*. + +The energy and force values are computed for angles ranging from 0 +degrees to 180 degrees for 3 interacting atoms forming an angle type +atype, using the appropriate :doc:`angle_coeff ` +coefficients. N evenly spaced angles are used. + +For example, for N = 6, values are computed at :math:`\theta = 0, 36, +72, 108, 144, 180`. + +The file is written in the format used as input for the +:doc:`angle_style table ` option with *keyword* as the +section name. Each line written to the file lists an index number +(1-N), an angle (in degrees), an energy (in energy units), and a force +(in force units per radians^2). In case a new file is created, the +first line will be a comment with a "DATE:" and "UNITS:" tag with the +current date and :doc:`units ` settings. For subsequent +invocations of the *angle_write* command for the same file, data will be +appended and the current units settings will be compared to the data +from the header, if present. The *angle_write* will refuse to add a +table to an existing file if the units are not the same. + +Restrictions +"""""""""""" + +All force field coefficients for angle and other kinds of interactions +must be set before this command can be invoked. + +The table of the angle energy and force data data is created by using a +separate, internally created, new LAMMPS instance with a dummy system of +3 atoms for which the angle potential energy is computed after +transferring the angle style and coefficients and arranging the 3 atoms +into the corresponding geometries. The angle force is then determined +from the potential energies through numerical differentiation. As a +consequence of this approach, not all angle styles are compatible. The +following conditions must be met: + +- The angle style must be able to write its coefficients to a data file. + This condition excludes for example :doc:`angle style hybrid ` and + :doc:`angle style table `. +- The potential function must not have any terms that depend on geometry + properties other than the angle. This condition excludes for example + :doc:`angle style class2 ` all angle types for + :doc:`angle style charmm ` that have non-zero + Urey-Bradley terms. Please note that the *write_angle* command has no + way of checking for this condition, so the resulting tables may be + bogus if the requirement is not met. It is thus recommended to make + careful tests for any created tables. + +Related commands +"""""""""""""""" + +:doc:`angle_style table `, :doc:`bond_write `, +:doc:`dihedral_write `, :doc:`angle_style `, +:doc:`angle_coeff ` + +Default +""""""" + +none diff --git a/doc/src/bond_write.rst b/doc/src/bond_write.rst index 47982303ee..43015e25e7 100644 --- a/doc/src/bond_write.rst +++ b/doc/src/bond_write.rst @@ -70,7 +70,7 @@ be specified even if the potential has a finite value at r = 0.0. Related commands """""""""""""""" -:doc:`bond_style table `, +:doc:`bond_style table `, `angle_write `, :doc:`bond_style `, :doc:`bond_coeff ` Default diff --git a/doc/src/commands_list.rst b/doc/src/commands_list.rst index ff2502189d..cea237f14e 100644 --- a/doc/src/commands_list.rst +++ b/doc/src/commands_list.rst @@ -6,6 +6,7 @@ Commands angle_coeff angle_style + angle_write atom_modify atom_style balance @@ -27,6 +28,7 @@ Commands dielectric dihedral_coeff dihedral_style + dihedral_write dimension displace_atoms dump diff --git a/doc/src/dihedral_write.rst b/doc/src/dihedral_write.rst new file mode 100644 index 0000000000..94fa3da0fa --- /dev/null +++ b/doc/src/dihedral_write.rst @@ -0,0 +1,101 @@ +.. index:: dihedral_write + +dihedral_write command +====================== + +Syntax +"""""" + +.. code-block:: LAMMPS + + dihedral_write dtype N file keyword + +* dtype = dihedral type +* N = # of values +* file = name of file to write values to +* keyword = section name in file for this set of tabulated values + +Examples +"""""""" + +.. code-block:: LAMMPS + + dihedral_write 1 500 table.txt Harmonic_1 + dihedral_write 3 1000 table.txt Harmonic_3 + +Description +""""""""""" + +.. versionadded:: TBD + +Write energy and force values to a file as a function of the dihedral +angle for the currently defined dihedral potential. Force in this +context means the force with respect to the dihedral angle, not the +force on individual atoms. This is useful for plotting the potential +function or otherwise debugging its values. The resulting file can also +be used as input for use with :doc:`dihedral style table +`. + +If the file already exists, the table of values is appended to the end +of the file to allow multiple tables of energy and force to be included +in one file. The individual sections may be identified by the *keyword*. + +The energy and force values are computed for dihedrals ranging from 0 +degrees to 360 degrees for 4 interacting atoms forming an dihedral type +dtype, using the appropriate :doc:`dihedral_coeff ` +coefficients. N evenly spaced dihedrals are used. Since 0 and 360 +degrees are the same dihedral angle, the latter entry is skipped. + +For example, for N = 6, values would be computed at +:math:`\phi = 0, 60, 120, 180, 240, 300`. + +The file is written in the format used as input for the +:doc:`dihedral_style table ` option with *keyword* as +the section name. Each line written to the file lists an index number +(1-N), an dihedral angle (in degrees), an energy (in energy units), and +a force (in force units per radians^2). In case a new file is created, +the first line will be a comment with a "DATE:" and "UNITS:" tag with +the current date and :doc:`units ` settings. For subsequent +invocations of the *dihedral_write* command for the same file, data will +be appended and the current units settings will be compared to the data +from the header, if present. The *dihedral_write* will refuse to add a +table to an existing file if the units are not the same. + +Restrictions +"""""""""""" + +All force field coefficients for dihedrals and other kinds of interactions +must be set before this command can be invoked. + +The table of the dihedral energy and force data data is created by using a +separate, internally created, new LAMMPS instance with a dummy system of +4 atoms for which the dihedral potential energy is computed after +transferring the dihedral style and coefficients and arranging the 4 atoms +into the corresponding geometries. The dihedral force is then determined +from the potential energies through numerical differentiation. As a +consequence of this approach, not all dihedral styles are compatible. The +following conditions must be met: + +- The dihedral style must be able to write its coefficients to a data file. + This condition excludes for example :doc:`dihedral style hybrid ` and + :doc:`dihedral style table `. +- The potential function must not have any terms that depend on geometry + properties other than the dihedral. This condition excludes for + example :doc:`dihedral style class2 `. Please note + that the *write_dihedral* command has no way of checking for this + condition. It will check the style name against an internal list of + known to be incompatible styles. The resulting tables may be bogus + for unlisted dihedral styles if the requirement is not met. It is + thus recommended to make careful tests for any created tables. + +Related commands +"""""""""""""""" + +:doc:`dihedral_style table `, :doc:`bond_write `, +:doc:`angle_write `, :doc:`dihedral_style `, +:doc:`dihedral_coeff ` + +Default +""""""" + +none diff --git a/doc/src/fix_bond_react.rst b/doc/src/fix_bond_react.rst index 5385bec5b9..af3ee0fd48 100644 --- a/doc/src/fix_bond_react.rst +++ b/doc/src/fix_bond_react.rst @@ -123,6 +123,17 @@ using this fix is (4) create a map that relates the template-atom-IDs of each atom between pre- and post-reaction molecule templates (5) fill a simulation box with molecules and run a simulation with fix bond/react. +.. note:: + + .. versionadded:: 15Sep2022 + + :doc:`Type labels ` allow for molecule templates + and data files to use alphanumeric atom types that match those of + a force field. Input files that use type labels are inherently + compatible with each other and portable between different + simulations. Therefore, it is highly recommended to use type labels + to specify atom, bond, etc. types when using fix bond/react. + Only one 'fix bond/react' command can be used at a time. Multiple reactions can be simultaneously applied by specifying multiple *react* arguments to a single 'fix bond/react' command. This syntax is @@ -228,18 +239,18 @@ pairs are identified within the cutoff distance: initiator partners, these two atoms are identified as the initiator atom pair of the reaction site. -Note that it can be helpful to select -unique atom types for the initiator atoms: if an initiator atom pair -is identified, as described in the previous steps, but it does not -correspond to the same pair specified in the pre-reaction template, an -otherwise eligible reaction could be prevented from occurring. Once -this unique initiator atom pair is identified for each reaction, there -could be two or more reactions that involve the same atom on the same -time step. If this is the case, only one such reaction is permitted to -occur. This reaction is chosen randomly from all potential reactions -involving the overlapping atom. This capability allows, for example, -different reaction pathways to proceed from identical reaction sites -with user-specified probabilities. +Note that it can be helpful to select unique atom types for the +initiator atoms: if an initiator atom pair is identified, as described +in the previous steps, but it does not correspond to the same pair +specified in the pre-reaction template, an otherwise eligible reaction +could be prevented from occurring. Once this unique initiator atom +pair is identified for each reaction, there could be two or more +reactions that involve the same atom on the same time step. If this is +the case, only one such reaction is permitted to occur. This reaction +is chosen randomly from all potential reactions involving the +overlapping atom. This capability allows, for example, different +reaction pathways to proceed from identical reaction sites with +user-specified probabilities. The pre-reacted molecule template is specified by a molecule command. This molecule template file contains a sample reaction site and its @@ -280,7 +291,10 @@ for a given simulation. All atom types in the pre-reacted template must be the same as those of a potential reaction site in the simulation. A detailed discussion of matching molecule template atom types with the simulation is provided on the :doc:`molecule ` -command page. +command page. It is highly recommended to use :doc:`Type labels ` +(added in version 15Sep2022) in both molecule templates and data +files, which automates the process of syncing atom types between +different input files. The post-reacted molecule template contains a sample of the reaction site and its surrounding topology after the reaction has occurred. It diff --git a/doc/src/fix_pair.rst b/doc/src/fix_pair.rst index abb44718cd..44c91f18ee 100644 --- a/doc/src/fix_pair.rst +++ b/doc/src/fix_pair.rst @@ -1,7 +1,7 @@ .. index:: fix pair fix pair command -======================= +================ Syntax """""" @@ -47,7 +47,12 @@ These are example use cases: The *N* argument determines how often the fix is invoked. The *pstyle* argument is the name of the pair style. It can be a -sub-style used in a :doc:`pair_style hybrid ` command. +sub-style used in a :doc:`pair_style hybrid ` command. If +there are multiple sub-styles using the same pair style, then *pstyle* +should be specified as "style:N", where *N* is the number of the +instance of the pair style you wish monitor (e.g., the first or second). +For example, *pstyle* could be specified as "pace/extrapolation" or +"amoeba" or "eam:1" or "eam:2". One or more *name/flag* pairs of arguments follow. Each *name* is a per-atom quantity which the pair style must recognize as an extraction diff --git a/doc/src/pair_pace.rst b/doc/src/pair_pace.rst index 697a9965b6..01f7df63f6 100644 --- a/doc/src/pair_pace.rst +++ b/doc/src/pair_pace.rst @@ -1,6 +1,7 @@ .. index:: pair_style pace .. index:: pair_style pace/kk .. index:: pair_style pace/extrapolation +.. index:: pair_style pace/extrapolation/kk pair_style pace command ======================= @@ -127,6 +128,9 @@ but not more often than every 20 steps. On all other steps `pair_style pace recursive` will be used. +When using the pair style *pace/extrapolation* with the KOKKOS package on GPUs +product B-basis evaluator is always used and only *linear* ASI is supported. + ---------- See the :doc:`pair_coeff ` page for alternate ways @@ -186,4 +190,4 @@ recursive, chunksize = 4096, .. _Lysogorskiy2022: -**(Lysogorskiy2022)** Lysogorskiy, Bochkarev, Mrovec, Drautz, TBS (2022). +**(Lysogorskiy2022)** Lysogorskiy, Bochkarev, Mrovec, Drautz, arXiv:2212.08716 (2022). diff --git a/doc/utils/sphinx-config/false_positives.txt b/doc/utils/sphinx-config/false_positives.txt index 647f9adbe4..3598b95805 100644 --- a/doc/utils/sphinx-config/false_positives.txt +++ b/doc/utils/sphinx-config/false_positives.txt @@ -174,6 +174,7 @@ attrac Atw Atwater atwt +atype augt AuO automagically @@ -828,6 +829,7 @@ dtemp dtgrow dtheta dtshrink +dtype du dU Ducastelle diff --git a/examples/PACKAGES/reaction/create_atoms_polystyrene/grow_styrene_post.data_template b/examples/PACKAGES/reaction/create_atoms_polystyrene/grow_styrene_post.data_template deleted file mode 100644 index 7269e3a269..0000000000 --- a/examples/PACKAGES/reaction/create_atoms_polystyrene/grow_styrene_post.data_template +++ /dev/null @@ -1,456 +0,0 @@ -molecule template: end of chain plus polymerized styrene - -46 atoms -48 bonds -81 angles -121 dihedrals -35 impropers -1 fragments - -Fragments - -create_fit 34 44 - -Types - -1 1 -2 2 -3 1 -4 5 -5 1 -6 2 -7 1 -8 2 -9 1 -10 2 -11 1 -12 2 -13 2 -14 6 -15 2 -16 2 -17 1 -18 2 -19 1 -20 5 -21 1 -22 2 -23 1 -24 2 -25 1 -26 2 -27 1 -28 2 -29 2 -30 6 -31 1 -32 2 -33 1 -34 5 -35 1 -36 2 -37 1 -38 2 -39 1 -40 2 -41 1 -42 2 -43 2 -44 6 -45 2 -46 2 - -Charges - -1 -0.129000 -2 0.123700 -3 0.026600 -4 -0.018200 -5 -0.129000 -6 0.123700 -7 -0.173400 -8 0.140300 -9 -0.113400 -10 0.128800 -11 -0.173400 -12 0.140300 -13 0.051600 -14 -0.069600 -15 0.035400 -16 0.035400 -17 -0.129000 -18 0.123700 -19 0.026600 -20 -0.018200 -21 -0.129000 -22 0.123700 -23 -0.173400 -24 0.140300 -25 -0.113400 -26 0.128800 -27 -0.173400 -28 0.140300 -29 0.051600 -30 -0.069600 -31 -0.129000 -32 0.123700 -33 0.026600 -34 -0.018200 -35 -0.129000 -36 0.123700 -37 -0.173400 -38 0.140300 -39 -0.113400 -40 0.128800 -41 -0.173400 -42 0.140300 -43 0.051600 -44 -0.069600 -45 0.035400 -46 0.035400 - -Coords - -1 24.130699 1.043900 -1.309300 -2 25.062700 1.582900 -1.309300 -3 22.900700 1.753900 -1.309300 -4 22.900700 3.253900 -1.309300 -5 21.670700 1.043900 -1.309300 -6 20.738701 1.582900 -1.309300 -7 21.670700 -0.376100 -1.309300 -8 20.738701 -0.915100 -1.309300 -9 22.900700 -1.086100 -1.309300 -10 22.900700 -2.163100 -1.309300 -11 24.130699 -0.376100 -1.309300 -12 25.062700 -0.915100 -1.309300 -13 23.766701 3.658900 -0.952300 -14 21.622700 3.802900 -1.871300 -15 21.672701 4.544900 -1.970300 -16 20.979700 2.979900 -2.165300 -17 13.465800 0.682500 -1.658900 -18 14.397800 1.221500 -1.658900 -19 12.235800 1.392500 -1.658900 -20 12.235800 2.892500 -1.658900 -21 11.005800 0.682500 -1.658900 -22 10.073800 1.221500 -1.658900 -23 11.005800 -0.737500 -1.658900 -24 10.073800 -1.276500 -1.658900 -25 12.235800 -1.447500 -1.658900 -26 12.235800 -2.524500 -1.658900 -27 13.465800 -0.737500 -1.658900 -28 14.397800 -1.276500 -1.658900 -29 13.101800 3.297500 -1.301900 -30 10.957800 3.441500 -2.220900 -31 18.663500 0.855500 -1.372100 -32 19.595501 1.394500 -1.372100 -33 17.433500 1.565500 -1.372100 -34 17.433500 3.065500 -1.372100 -35 16.203501 0.855500 -1.372100 -36 15.271500 1.394500 -1.372100 -37 16.203501 -0.564500 -1.372100 -38 15.271500 -1.103500 -1.372100 -39 17.433500 -1.274500 -1.372100 -40 17.433500 -2.351500 -1.372100 -41 18.663500 -0.564500 -1.372100 -42 19.595501 -1.103500 -1.372100 -43 18.299500 3.470500 -1.015100 -44 16.155500 3.614500 -1.934100 -45 16.205500 4.356500 -2.033100 -46 15.512500 2.791500 -2.228100 - -Bonds - -1 1 1 2 -2 2 1 3 -3 2 1 11 -4 11 3 4 -5 2 3 5 -6 12 13 4 -7 13 4 14 -8 1 5 6 -9 2 5 7 -10 1 7 8 -11 2 7 9 -12 1 9 10 -13 2 9 11 -14 1 11 12 -15 10 15 14 -16 10 16 14 -17 9 14 34 -18 1 17 18 -19 2 17 19 -20 2 17 27 -21 7 19 20 -22 2 19 21 -23 8 29 20 -24 9 30 20 -25 9 44 20 -26 1 21 22 -27 2 21 23 -28 1 23 24 -29 2 23 25 -30 1 25 26 -31 2 25 27 -32 1 27 28 -33 1 31 32 -34 2 31 33 -35 2 31 41 -36 7 33 34 -37 2 33 35 -38 8 43 34 -39 9 44 34 -40 1 35 36 -41 2 35 37 -42 1 37 38 -43 2 37 39 -44 1 39 40 -45 2 39 41 -46 1 41 42 -47 10 45 44 -48 10 46 44 - -Angles - -1 1 3 1 2 -2 1 11 1 2 -3 2 3 1 11 -4 17 1 3 4 -5 2 1 3 5 -6 17 5 3 4 -7 18 3 4 13 -8 19 3 4 14 -9 20 13 4 14 -10 1 3 5 6 -11 2 3 5 7 -12 1 7 5 6 -13 1 5 7 8 -14 2 5 7 9 -15 1 9 7 8 -16 1 7 9 10 -17 2 7 9 11 -18 1 11 9 10 -19 2 1 11 9 -20 1 1 11 12 -21 1 9 11 12 -22 21 15 14 4 -23 21 16 14 4 -24 22 4 14 34 -25 15 15 14 16 -26 14 15 14 34 -27 14 16 14 34 -28 1 19 17 18 -29 1 27 17 18 -30 2 19 17 27 -31 9 17 19 20 -32 2 17 19 21 -33 9 21 19 20 -34 10 19 20 29 -35 11 19 20 30 -36 11 19 20 44 -37 12 29 20 30 -38 12 29 20 44 -39 13 30 20 44 -40 1 19 21 22 -41 2 19 21 23 -42 1 23 21 22 -43 1 21 23 24 -44 2 21 23 25 -45 1 25 23 24 -46 1 23 25 26 -47 2 23 25 27 -48 1 27 25 26 -49 2 17 27 25 -50 1 17 27 28 -51 1 25 27 28 -52 1 33 31 32 -53 1 41 31 32 -54 2 33 31 41 -55 9 31 33 34 -56 2 31 33 35 -57 9 35 33 34 -58 11 33 34 14 -59 12 43 34 14 -60 13 14 34 44 -61 10 33 34 43 -62 11 33 34 44 -63 12 43 34 44 -64 1 33 35 36 -65 2 33 35 37 -66 1 37 35 36 -67 1 35 37 38 -68 2 35 37 39 -69 1 39 37 38 -70 1 37 39 40 -71 2 37 39 41 -72 1 41 39 40 -73 2 31 41 39 -74 1 31 41 42 -75 1 39 41 42 -76 16 20 44 34 -77 14 45 44 20 -78 14 46 44 20 -79 14 45 44 34 -80 14 46 44 34 -81 15 45 44 46 - -Dihedrals - -1 20 2 1 3 4 -2 2 5 3 1 2 -3 21 11 1 3 4 -4 4 11 1 3 5 -5 2 9 11 1 2 -6 5 2 1 11 12 -7 4 3 1 11 9 -8 2 3 1 11 12 -9 22 1 3 4 13 -10 23 1 3 4 14 -11 22 5 3 4 13 -12 23 5 3 4 14 -13 2 1 3 5 6 -14 4 1 3 5 7 -15 20 6 5 3 4 -16 21 7 5 3 4 -17 24 3 4 14 15 -18 24 3 4 14 16 -19 25 3 4 14 34 -20 26 13 4 14 15 -21 26 13 4 14 16 -22 27 13 4 14 34 -23 2 3 5 7 8 -24 4 3 5 7 9 -25 5 6 5 7 8 -26 2 9 7 5 6 -27 2 5 7 9 10 -28 4 5 7 9 11 -29 5 8 7 9 10 -30 2 11 9 7 8 -31 4 7 9 11 1 -32 2 7 9 11 12 -33 2 1 11 9 10 -34 5 10 9 11 12 -35 28 4 14 34 33 -36 29 4 14 34 43 -37 30 4 14 34 44 -38 31 15 14 34 33 -39 32 15 14 34 43 -40 33 15 14 34 44 -41 31 16 14 34 33 -42 32 16 14 34 43 -43 33 16 14 34 44 -44 10 18 17 19 20 -45 2 21 19 17 18 -46 11 27 17 19 20 -47 4 27 17 19 21 -48 2 25 27 17 18 -49 5 18 17 27 28 -50 4 19 17 27 25 -51 2 19 17 27 28 -52 12 17 19 20 29 -53 13 17 19 20 30 -54 13 17 19 20 44 -55 12 21 19 20 29 -56 13 21 19 20 30 -57 13 21 19 20 44 -58 2 17 19 21 22 -59 4 17 19 21 23 -60 10 22 21 19 20 -61 11 23 21 19 20 -62 34 34 44 20 19 -63 31 45 44 20 19 -64 31 46 44 20 19 -65 35 34 44 20 29 -66 32 45 44 20 29 -67 32 46 44 20 29 -68 36 34 44 20 30 -69 33 45 44 20 30 -70 33 46 44 20 30 -71 2 19 21 23 24 -72 4 19 21 23 25 -73 5 22 21 23 24 -74 2 25 23 21 22 -75 2 21 23 25 26 -76 4 21 23 25 27 -77 5 24 23 25 26 -78 2 27 25 23 24 -79 4 23 25 27 17 -80 2 23 25 27 28 -81 2 17 27 25 26 -82 5 26 25 27 28 -83 10 32 31 33 34 -84 2 35 33 31 32 -85 11 41 31 33 34 -86 4 41 31 33 35 -87 2 39 41 31 32 -88 5 32 31 41 42 -89 4 33 31 41 39 -90 2 33 31 41 42 -91 13 31 33 34 14 -92 12 31 33 34 43 -93 13 31 33 34 44 -94 13 35 33 34 14 -95 12 35 33 34 43 -96 13 35 33 34 44 -97 2 31 33 35 36 -98 4 31 33 35 37 -99 10 36 35 33 34 -100 11 37 35 33 34 -101 36 20 44 34 14 -102 33 45 44 34 14 -103 33 46 44 34 14 -104 34 20 44 34 33 -105 31 45 44 34 33 -106 31 46 44 34 33 -107 35 20 44 34 43 -108 32 45 44 34 43 -109 32 46 44 34 43 -110 2 33 35 37 38 -111 4 33 35 37 39 -112 5 36 35 37 38 -113 2 39 37 35 36 -114 2 35 37 39 40 -115 4 35 37 39 41 -116 5 38 37 39 40 -117 2 41 39 37 38 -118 4 37 39 41 31 -119 2 37 39 41 42 -120 2 31 41 39 40 -121 5 40 39 41 42 - -Impropers - -1 1 3 1 11 2 -2 8 1 3 5 4 -3 9 3 4 13 14 -4 1 3 5 7 6 -5 1 5 7 9 8 -6 1 7 9 11 10 -7 1 1 11 9 12 -8 1 19 17 27 18 -9 5 17 19 21 20 -10 1 19 21 23 22 -11 1 21 23 25 24 -12 1 23 25 27 26 -13 1 17 27 25 28 -14 1 33 31 41 32 -15 5 31 33 35 34 -16 1 33 35 37 36 -17 1 35 37 39 38 -18 1 37 39 41 40 -19 1 31 41 39 42 -20 1 15 14 16 4 -21 1 15 14 4 34 -22 1 16 14 4 34 -23 1 15 14 16 34 -24 1 19 20 29 30 -25 1 19 20 29 44 -26 1 19 20 30 44 -27 1 29 20 30 44 -28 1 33 34 43 14 -29 1 33 34 14 44 -30 1 43 34 14 44 -31 1 33 34 43 44 -32 1 45 44 34 20 -33 1 46 44 34 20 -34 1 45 44 46 20 -35 1 45 44 46 34 diff --git a/examples/PACKAGES/reaction/create_atoms_polystyrene/grow_styrene_post.molecule_template b/examples/PACKAGES/reaction/create_atoms_polystyrene/grow_styrene_post.molecule_template new file mode 100644 index 0000000000..62b42afd3e --- /dev/null +++ b/examples/PACKAGES/reaction/create_atoms_polystyrene/grow_styrene_post.molecule_template @@ -0,0 +1,489 @@ +molecule template: end of chain plus polymerized styrene + + 46 atoms + 48 bonds + 81 angles + 121 dihedrals + 19 impropers + 1 fragments + +Fragments + + create_fit 34 44 + +Coords + + 1 24.130699158 1.043900013 -1.309299946 + 2 25.062700272 1.582900047 -1.309299946 + 3 22.900699615 1.753900051 -1.309299946 + 4 22.900699615 3.253900051 -1.309299946 + 5 21.670700073 1.043900013 -1.309299946 + 6 20.738700867 1.582900047 -1.309299946 + 7 21.670700073 -0.376100004 -1.309299946 + 8 20.738700867 -0.915099978 -1.309299946 + 9 22.900699615 -1.086099982 -1.309299946 + 10 22.900699615 -2.163100004 -1.309299946 + 11 24.130699158 -0.376100004 -1.309299946 + 12 25.062700272 -0.915099978 -1.309299946 + 13 23.766700745 3.658900023 -0.952300012 + 14 21.622699738 3.802900076 -1.871299982 + 15 21.672700882 4.544899940 -1.970299959 + 16 20.979700089 2.979899883 -2.165299892 + 17 13.465800285 0.682500005 -1.658900023 + 18 14.397800446 1.221500039 -1.658900023 + 19 12.235799789 1.392500043 -1.658900023 + 20 12.235799789 2.892499924 -1.658900023 + 21 11.005800247 0.682500005 -1.658900023 + 22 10.073800087 1.221500039 -1.658900023 + 23 11.005800247 -0.737500012 -1.658900023 + 24 10.073800087 -1.276499987 -1.658900023 + 25 12.235799789 -1.447499990 -1.658900023 + 26 12.235799789 -2.524499893 -1.658900023 + 27 13.465800285 -0.737500012 -1.658900023 + 28 14.397800446 -1.276499987 -1.658900023 + 29 13.101799965 3.297499895 -1.301900029 + 30 10.957799911 3.441499949 -2.220900059 + 31 18.663499832 0.855499983 -1.372099996 + 32 19.595500946 1.394500017 -1.372099996 + 33 17.433500290 1.565500021 -1.372099996 + 34 17.433500290 3.065500021 -1.372099996 + 35 16.203500748 0.855499983 -1.372099996 + 36 15.271499634 1.394500017 -1.372099996 + 37 16.203500748 -0.564499974 -1.372099996 + 38 15.271499634 -1.103500009 -1.372099996 + 39 17.433500290 -1.274500012 -1.372099996 + 40 17.433500290 -2.351500034 -1.372099996 + 41 18.663499832 -0.564499974 -1.372099996 + 42 19.595500946 -1.103500009 -1.372099996 + 43 18.299499512 3.470499992 -1.015100002 + 44 16.155500412 3.614500046 -1.934100032 + 45 16.205499649 4.356500149 -2.033099890 + 46 15.512499809 2.791500092 -2.228100061 + +Types + + 1 cp + 2 hc + 3 cp + 4 c1 + 5 cp + 6 hc + 7 cp + 8 hc + 9 cp + 10 hc + 11 cp + 12 hc + 13 hc + 14 c2 + 15 hc + 16 hc + 17 cp + 18 hc + 19 cp + 20 c1 + 21 cp + 22 hc + 23 cp + 24 hc + 25 cp + 26 hc + 27 cp + 28 hc + 29 hc + 30 c2 + 31 cp + 32 hc + 33 cp + 34 c1 + 35 cp + 36 hc + 37 cp + 38 hc + 39 cp + 40 hc + 41 cp + 42 hc + 43 hc + 44 c2 + 45 hc + 46 hc + +Charges + + 1 -0.129000 + 2 0.123700 + 3 0.026600 + 4 -0.018200 + 5 -0.129000 + 6 0.123700 + 7 -0.173400 + 8 0.140300 + 9 -0.113400 + 10 0.128800 + 11 -0.173400 + 12 0.140300 + 13 0.051600 + 14 -0.069600 + 15 0.035400 + 16 0.035400 + 17 -0.129000 + 18 0.123700 + 19 0.026600 + 20 -0.018200 + 21 -0.129000 + 22 0.123700 + 23 -0.173400 + 24 0.140300 + 25 -0.113400 + 26 0.128800 + 27 -0.173400 + 28 0.140300 + 29 0.051600 + 30 -0.069600 + 31 -0.129000 + 32 0.123700 + 33 0.026600 + 34 -0.018200 + 35 -0.129000 + 36 0.123700 + 37 -0.173400 + 38 0.140300 + 39 -0.113400 + 40 0.128800 + 41 -0.173400 + 42 0.140300 + 43 0.051600 + 44 -0.069600 + 45 0.035400 + 46 0.035400 + +Molecules + + 1 1 + 2 1 + 3 1 + 4 1 + 5 1 + 6 1 + 7 1 + 8 1 + 9 1 + 10 1 + 11 1 + 12 1 + 13 1 + 14 1 + 15 1 + 16 1 + 17 1 + 18 1 + 19 1 + 20 1 + 21 1 + 22 1 + 23 1 + 24 1 + 25 1 + 26 1 + 27 1 + 28 1 + 29 1 + 30 1 + 31 1 + 32 1 + 33 1 + 34 1 + 35 1 + 36 1 + 37 1 + 38 1 + 39 1 + 40 1 + 41 1 + 42 1 + 43 1 + 44 1 + 45 1 + 46 1 + +Bonds + + 1 hc-cp 1 2 + 2 cp-cp 1 3 + 3 cp-cp 1 11 + 4 cp-c1 3 4 + 5 cp-cp 3 5 + 6 hc-c1 13 4 + 7 c1-c2 4 14 + 8 hc-cp 5 6 + 9 cp-cp 5 7 + 10 hc-cp 7 8 + 11 cp-cp 7 9 + 12 hc-cp 9 10 + 13 cp-cp 9 11 + 14 hc-cp 11 12 + 15 hc-c2 15 14 + 16 hc-c2 16 14 + 17 c1-c2 34 14 + 18 hc-cp 17 18 + 19 cp-cp 17 19 + 20 cp-cp 17 27 + 21 cp-c1 19 20 + 22 cp-cp 19 21 + 23 hc-c1 29 20 + 24 c1-c2 20 30 + 25 c1-c2 20 44 + 26 hc-cp 21 22 + 27 cp-cp 21 23 + 28 hc-cp 23 24 + 29 cp-cp 23 25 + 30 hc-cp 25 26 + 31 cp-cp 25 27 + 32 hc-cp 27 28 + 33 hc-cp 31 32 + 34 cp-cp 31 33 + 35 cp-cp 31 41 + 36 cp-c1 33 34 + 37 cp-cp 33 35 + 38 hc-c1 43 34 + 39 c1-c2 34 44 + 40 hc-cp 35 36 + 41 cp-cp 35 37 + 42 hc-cp 37 38 + 43 cp-cp 37 39 + 44 hc-cp 39 40 + 45 cp-cp 39 41 + 46 hc-cp 41 42 + 47 hc-c2 45 44 + 48 hc-c2 46 44 + +Angles + + 1 hc-cp-cp 3 1 2 + 2 hc-cp-cp 11 1 2 + 3 cp-cp-cp 3 1 11 + 4 cp-cp-c1 1 3 4 + 5 cp-cp-cp 1 3 5 + 6 cp-cp-c1 5 3 4 + 7 hc-c1-cp 3 4 13 + 8 cp-c1-c2 3 4 14 + 9 hc-c1-c2 13 4 14 + 10 hc-cp-cp 3 5 6 + 11 cp-cp-cp 3 5 7 + 12 hc-cp-cp 7 5 6 + 13 hc-cp-cp 5 7 8 + 14 cp-cp-cp 5 7 9 + 15 hc-cp-cp 9 7 8 + 16 hc-cp-cp 7 9 10 + 17 cp-cp-cp 7 9 11 + 18 hc-cp-cp 11 9 10 + 19 cp-cp-cp 1 11 9 + 20 hc-cp-cp 1 11 12 + 21 hc-cp-cp 9 11 12 + 22 hc-c2-c1 15 14 4 + 23 hc-c2-c1 16 14 4 + 24 c1-c2-c1 4 14 34 + 25 hc-c2-hc 15 14 16 + 26 hc-c2-c1 15 14 34 + 27 hc-c2-c1 16 14 34 + 28 hc-cp-cp 19 17 18 + 29 hc-cp-cp 27 17 18 + 30 cp-cp-cp 19 17 27 + 31 cp-cp-c1 17 19 20 + 32 cp-cp-cp 17 19 21 + 33 cp-cp-c1 21 19 20 + 34 hc-c1-cp 19 20 29 + 35 cp-c1-c2 19 20 30 + 36 cp-c1-c2 19 20 44 + 37 hc-c1-c2 29 20 30 + 38 hc-c1-c2 29 20 44 + 39 c2-c1-c2 30 20 44 + 40 hc-cp-cp 19 21 22 + 41 cp-cp-cp 19 21 23 + 42 hc-cp-cp 23 21 22 + 43 hc-cp-cp 21 23 24 + 44 cp-cp-cp 21 23 25 + 45 hc-cp-cp 25 23 24 + 46 hc-cp-cp 23 25 26 + 47 cp-cp-cp 23 25 27 + 48 hc-cp-cp 27 25 26 + 49 cp-cp-cp 17 27 25 + 50 hc-cp-cp 17 27 28 + 51 hc-cp-cp 25 27 28 + 52 hc-cp-cp 33 31 32 + 53 hc-cp-cp 41 31 32 + 54 cp-cp-cp 33 31 41 + 55 cp-cp-c1 31 33 34 + 56 cp-cp-cp 31 33 35 + 57 cp-cp-c1 35 33 34 + 58 cp-c1-c2 33 34 14 + 59 hc-c1-c2 43 34 14 + 60 c2-c1-c2 14 34 44 + 61 hc-c1-cp 33 34 43 + 62 cp-c1-c2 33 34 44 + 63 hc-c1-c2 43 34 44 + 64 hc-cp-cp 33 35 36 + 65 cp-cp-cp 33 35 37 + 66 hc-cp-cp 37 35 36 + 67 hc-cp-cp 35 37 38 + 68 cp-cp-cp 35 37 39 + 69 hc-cp-cp 39 37 38 + 70 hc-cp-cp 37 39 40 + 71 cp-cp-cp 37 39 41 + 72 hc-cp-cp 41 39 40 + 73 cp-cp-cp 31 41 39 + 74 hc-cp-cp 31 41 42 + 75 hc-cp-cp 39 41 42 + 76 c1-c2-c1 20 44 34 + 77 hc-c2-c1 45 44 20 + 78 hc-c2-c1 46 44 20 + 79 hc-c2-c1 45 44 34 + 80 hc-c2-c1 46 44 34 + 81 hc-c2-hc 45 44 46 + +Dihedrals + + 1 hc-cp-cp-c1 2 1 3 4 + 2 hc-cp-cp-cp 5 3 1 2 + 3 cp-cp-cp-c1 11 1 3 4 + 4 cp-cp-cp-cp 11 1 3 5 + 5 hc-cp-cp-cp 9 11 1 2 + 6 hc-cp-cp-hc 2 1 11 12 + 7 cp-cp-cp-cp 3 1 11 9 + 8 hc-cp-cp-cp 3 1 11 12 + 9 cp-cp-c1-hc 1 3 4 13 + 10 cp-cp-c1-c2 1 3 4 14 + 11 cp-cp-c1-hc 5 3 4 13 + 12 cp-cp-c1-c2 5 3 4 14 + 13 hc-cp-cp-cp 1 3 5 6 + 14 cp-cp-cp-cp 1 3 5 7 + 15 hc-cp-cp-c1 6 5 3 4 + 16 cp-cp-cp-c1 7 5 3 4 + 17 cp-c1-c2-hc 3 4 14 15 + 18 cp-c1-c2-hc 3 4 14 16 + 19 cp-c1-c2-c1 3 4 14 34 + 20 hc-c1-c2-hc 13 4 14 15 + 21 hc-c1-c2-hc 13 4 14 16 + 22 hc-c1-c2-c1 13 4 14 34 + 23 hc-cp-cp-cp 3 5 7 8 + 24 cp-cp-cp-cp 3 5 7 9 + 25 hc-cp-cp-hc 6 5 7 8 + 26 hc-cp-cp-cp 9 7 5 6 + 27 hc-cp-cp-cp 5 7 9 10 + 28 cp-cp-cp-cp 5 7 9 11 + 29 hc-cp-cp-hc 8 7 9 10 + 30 hc-cp-cp-cp 11 9 7 8 + 31 cp-cp-cp-cp 7 9 11 1 + 32 hc-cp-cp-cp 7 9 11 12 + 33 hc-cp-cp-cp 1 11 9 10 + 34 hc-cp-cp-hc 10 9 11 12 + 35 cp-c1-c2-c1 33 34 14 4 + 36 hc-c1-c2-c1 43 34 14 4 + 37 c2-c1-c2-c1 44 34 14 4 + 38 cp-c1-c2-hc 33 34 14 15 + 39 hc-c1-c2-hc 43 34 14 15 + 40 c2-c1-c2-hc 44 34 14 15 + 41 cp-c1-c2-hc 33 34 14 16 + 42 hc-c1-c2-hc 43 34 14 16 + 43 c2-c1-c2-hc 44 34 14 16 + 44 hc-cp-cp-c1 18 17 19 20 + 45 hc-cp-cp-cp 21 19 17 18 + 46 cp-cp-cp-c1 27 17 19 20 + 47 cp-cp-cp-cp 27 17 19 21 + 48 hc-cp-cp-cp 25 27 17 18 + 49 hc-cp-cp-hc 18 17 27 28 + 50 cp-cp-cp-cp 19 17 27 25 + 51 hc-cp-cp-cp 19 17 27 28 + 52 cp-cp-c1-hc 17 19 20 29 + 53 cp-cp-c1-c2 17 19 20 30 + 54 cp-cp-c1-c2 17 19 20 44 + 55 cp-cp-c1-hc 21 19 20 29 + 56 cp-cp-c1-c2 21 19 20 30 + 57 cp-cp-c1-c2 21 19 20 44 + 58 hc-cp-cp-cp 17 19 21 22 + 59 cp-cp-cp-cp 17 19 21 23 + 60 hc-cp-cp-c1 22 21 19 20 + 61 cp-cp-cp-c1 23 21 19 20 + 62 cp-c1-c2-c1 19 20 44 34 + 63 cp-c1-c2-hc 19 20 44 45 + 64 cp-c1-c2-hc 19 20 44 46 + 65 hc-c1-c2-c1 29 20 44 34 + 66 hc-c1-c2-hc 29 20 44 45 + 67 hc-c1-c2-hc 29 20 44 46 + 68 c2-c1-c2-c1 30 20 44 34 + 69 c2-c1-c2-hc 30 20 44 45 + 70 c2-c1-c2-hc 30 20 44 46 + 71 hc-cp-cp-cp 19 21 23 24 + 72 cp-cp-cp-cp 19 21 23 25 + 73 hc-cp-cp-hc 22 21 23 24 + 74 hc-cp-cp-cp 25 23 21 22 + 75 hc-cp-cp-cp 21 23 25 26 + 76 cp-cp-cp-cp 21 23 25 27 + 77 hc-cp-cp-hc 24 23 25 26 + 78 hc-cp-cp-cp 27 25 23 24 + 79 cp-cp-cp-cp 23 25 27 17 + 80 hc-cp-cp-cp 23 25 27 28 + 81 hc-cp-cp-cp 17 27 25 26 + 82 hc-cp-cp-hc 26 25 27 28 + 83 hc-cp-cp-c1 32 31 33 34 + 84 hc-cp-cp-cp 35 33 31 32 + 85 cp-cp-cp-c1 41 31 33 34 + 86 cp-cp-cp-cp 41 31 33 35 + 87 hc-cp-cp-cp 39 41 31 32 + 88 hc-cp-cp-hc 32 31 41 42 + 89 cp-cp-cp-cp 33 31 41 39 + 90 hc-cp-cp-cp 33 31 41 42 + 91 cp-cp-c1-c2 31 33 34 14 + 92 cp-cp-c1-hc 31 33 34 43 + 93 cp-cp-c1-c2 31 33 34 44 + 94 cp-cp-c1-c2 35 33 34 14 + 95 cp-cp-c1-hc 35 33 34 43 + 96 cp-cp-c1-c2 35 33 34 44 + 97 hc-cp-cp-cp 31 33 35 36 + 98 cp-cp-cp-cp 31 33 35 37 + 99 hc-cp-cp-c1 36 35 33 34 + 100 cp-cp-cp-c1 37 35 33 34 + 101 c2-c1-c2-c1 14 34 44 20 + 102 c2-c1-c2-hc 14 34 44 45 + 103 c2-c1-c2-hc 14 34 44 46 + 104 cp-c1-c2-c1 33 34 44 20 + 105 cp-c1-c2-hc 33 34 44 45 + 106 cp-c1-c2-hc 33 34 44 46 + 107 hc-c1-c2-c1 43 34 44 20 + 108 hc-c1-c2-hc 43 34 44 45 + 109 hc-c1-c2-hc 43 34 44 46 + 110 hc-cp-cp-cp 33 35 37 38 + 111 cp-cp-cp-cp 33 35 37 39 + 112 hc-cp-cp-hc 36 35 37 38 + 113 hc-cp-cp-cp 39 37 35 36 + 114 hc-cp-cp-cp 35 37 39 40 + 115 cp-cp-cp-cp 35 37 39 41 + 116 hc-cp-cp-hc 38 37 39 40 + 117 hc-cp-cp-cp 41 39 37 38 + 118 cp-cp-cp-cp 37 39 41 31 + 119 hc-cp-cp-cp 37 39 41 42 + 120 hc-cp-cp-cp 31 41 39 40 + 121 hc-cp-cp-hc 40 39 41 42 + +Impropers + + 1 hc-cp-cp-cp 3 1 11 2 + 2 cp-cp-cp-c1 1 3 5 4 + 3 hc-c1-cp-c2 3 4 13 14 + 4 hc-cp-cp-cp 3 5 7 6 + 5 hc-cp-cp-cp 5 7 9 8 + 6 hc-cp-cp-cp 7 9 11 10 + 7 hc-cp-cp-cp 1 11 9 12 + 8 hc-cp-cp-cp 19 17 27 18 + 9 cp-cp-cp-c1 17 19 21 20 + 10 hc-cp-cp-cp 19 21 23 22 + 11 hc-cp-cp-cp 21 23 25 24 + 12 hc-cp-cp-cp 23 25 27 26 + 13 hc-cp-cp-cp 17 27 25 28 + 14 hc-cp-cp-cp 33 31 41 32 + 15 cp-cp-cp-c1 31 33 35 34 + 16 hc-cp-cp-cp 33 35 37 36 + 17 hc-cp-cp-cp 35 37 39 38 + 18 hc-cp-cp-cp 37 39 41 40 + 19 hc-cp-cp-cp 31 41 39 42 diff --git a/examples/PACKAGES/reaction/create_atoms_polystyrene/grow_styrene_pre.data_template b/examples/PACKAGES/reaction/create_atoms_polystyrene/grow_styrene_pre.data_template deleted file mode 100644 index d04fefccf5..0000000000 --- a/examples/PACKAGES/reaction/create_atoms_polystyrene/grow_styrene_pre.data_template +++ /dev/null @@ -1,294 +0,0 @@ -molecule template: end of styrene chain - -30 atoms -31 bonds -51 angles -73 dihedrals -21 impropers - -Types - -1 2 -2 2 -3 6 -4 2 -5 2 -6 1 -7 2 -8 1 -9 2 -10 1 -11 2 -12 1 -13 5 -14 1 -15 2 -16 1 -17 1 -18 2 -19 1 -20 5 -21 1 -22 2 -23 1 -24 2 -25 1 -26 2 -27 1 -28 2 -29 2 -30 6 - -Coords - -1 59.89981112372972 62.733697275315585 59.09884284578856 -2 61.41970248324232 63.42116581894993 59.52874545893742 -3 60.864754970096406 62.91724243011892 59.559720865992695 -4 62.139819000186826 61.41011937002877 60.81065044071466 -5 60.036455711425084 57.160029629288026 60.31958663310848 -6 59.734195751174056 58.18706337912225 60.20562410798949 -7 57.64574781117771 57.712432799329 59.860109977091554 -8 58.37408644866664 58.50134169314242 59.94422053768215 -9 56.94300092269842 60.093170109004795 59.5955638127831 -10 57.974275786582744 59.85577775892068 59.793714995577716 -11 58.63231375134033 61.922969938852454 59.79065033121885 -12 58.934573711591355 60.89593618901822 59.904612856337835 -13 61.30908151524225 61.68041745837013 60.28316188676589 -14 60.29468229868386 60.58165855333751 60.16601625920239 -15 61.725768540066994 58.98982945913568 60.51467315154424 -16 60.69449367618267 59.2272218092198 60.31652196874961 -17 56.90935800040509 62.609851248143706 59.150831390216375 -18 57.940632148874506 62.37245957639904 59.3489824055682 -19 56.509546622906285 63.96428799226142 59.00032568066915 -20 57.52394583946467 65.06304689729403 59.11747130823266 -21 55.14943732039887 64.27856630628159 58.738922110361806 -22 54.84717807556275 65.30559937777636 58.62495975268562 -23 54.18913939539026 63.23840787618404 58.62802424960169 -24 53.15786524692084 63.4757995479287 58.42987323424986 -25 54.58895077288906 61.88397113206633 58.77852995914891 -26 53.86061213540014 61.09506223825291 58.69441939855832 -27 55.94906007539648 61.56969281804616 59.039933529456256 -28 56.2513193202326 60.54265974655139 59.15389588713244 -29 58.35468332440925 64.79274880895268 59.64495986218142 -30 57.07961929431883 66.29987186904283 58.394030287459465 - -Charges - -1 0.0354 -2 0.0354 -3 -0.0696 -4 0.0516 -5 0.1403 -6 -0.1734 -7 0.1288 -8 -0.1134 -9 0.1403 -10 -0.1734 -11 0.1237 -12 -0.129 -13 -0.0182 -14 0.0266 -15 0.1237 -16 -0.129 -17 -0.129 -18 0.1237 -19 0.0266 -20 -0.0182 -21 -0.129 -22 0.1237 -23 -0.1734 -24 0.1403 -25 -0.1134 -26 0.1288 -27 -0.1734 -28 0.1403 -29 0.0516 -30 -0.0696 - -Bonds - -1 10 1 3 -2 10 2 3 -3 8 4 13 -4 1 6 5 -5 1 8 7 -6 2 8 6 -7 1 10 9 -8 2 10 8 -9 1 12 11 -10 2 12 10 -11 9 13 3 -12 7 14 13 -13 2 14 12 -14 1 16 15 -15 2 16 14 -16 2 16 6 -17 1 17 18 -18 2 17 19 -19 2 17 27 -20 7 19 20 -21 2 19 21 -22 9 20 30 -23 9 20 3 -24 1 21 22 -25 2 21 23 -26 1 23 24 -27 2 23 25 -28 1 25 26 -29 2 25 27 -30 1 27 28 -31 8 29 20 - -Angles - -1 16 20 3 13 -2 14 2 3 20 -3 14 1 3 20 -4 14 2 3 13 -5 14 1 3 13 -6 15 2 3 1 -7 2 16 6 8 -8 1 16 6 5 -9 1 8 6 5 -10 1 10 8 7 -11 2 10 8 6 -12 1 6 8 7 -13 1 12 10 9 -14 2 12 10 8 -15 1 8 10 9 -16 1 14 12 11 -17 2 14 12 10 -18 1 10 12 11 -19 10 14 13 4 -20 11 14 13 3 -21 12 4 13 3 -22 9 16 14 13 -23 2 16 14 12 -24 9 12 14 13 -25 1 14 16 15 -26 1 6 16 15 -27 2 14 16 6 -28 1 19 17 18 -29 1 27 17 18 -30 2 19 17 27 -31 9 17 19 20 -32 2 17 19 21 -33 9 21 19 20 -34 10 19 20 29 -35 11 19 20 30 -36 11 19 20 3 -37 12 29 20 30 -38 12 29 20 3 -39 13 30 20 3 -40 1 19 21 22 -41 2 19 21 23 -42 1 23 21 22 -43 1 21 23 24 -44 2 21 23 25 -45 1 25 23 24 -46 1 23 25 26 -47 2 23 25 27 -48 1 27 25 26 -49 2 17 27 25 -50 1 17 27 28 -51 1 25 27 28 - -Dihedrals - -1 2 8 6 16 15 -2 2 16 6 8 7 -3 2 6 8 10 9 -4 4 10 8 6 16 -5 2 10 8 6 5 -6 5 7 8 6 5 -7 2 8 10 12 11 -8 2 12 10 8 7 -9 4 12 10 8 6 -10 5 9 10 8 7 -11 10 11 12 14 13 -12 11 10 12 14 13 -13 2 14 12 10 9 -14 4 14 12 10 8 -15 5 11 12 10 9 -16 17 14 13 3 20 -17 14 14 13 3 2 -18 14 14 13 3 1 -19 18 4 13 3 20 -20 15 4 13 3 2 -21 15 4 13 3 1 -22 2 12 14 16 15 -23 12 16 14 13 4 -24 13 16 14 13 3 -25 12 12 14 13 4 -26 13 12 14 13 3 -27 2 16 14 12 11 -28 4 16 14 12 10 -29 10 15 16 14 13 -30 11 6 16 14 13 -31 4 6 16 14 12 -32 5 15 16 6 5 -33 4 14 16 6 8 -34 2 14 16 6 5 -35 10 18 17 19 20 -36 11 27 17 19 20 -37 4 27 17 19 21 -38 5 18 17 27 28 -39 4 19 17 27 25 -40 2 19 17 27 28 -41 2 21 19 17 18 -42 12 17 19 20 29 -43 13 17 19 20 30 -44 13 17 19 20 3 -45 12 21 19 20 29 -46 13 21 19 20 30 -47 13 21 19 20 3 -48 2 17 19 21 22 -49 4 17 19 21 23 -50 17 19 20 3 13 -51 14 19 20 3 2 -52 14 19 20 3 1 -53 18 29 20 3 13 -54 15 29 20 3 2 -55 15 29 20 3 1 -56 19 30 20 3 13 -57 16 30 20 3 2 -58 16 30 20 3 1 -59 10 22 21 19 20 -60 11 23 21 19 20 -61 2 19 21 23 24 -62 4 19 21 23 25 -63 5 22 21 23 24 -64 2 25 23 21 22 -65 2 21 23 25 26 -66 4 21 23 25 27 -67 5 24 23 25 26 -68 2 27 25 23 24 -69 4 23 25 27 17 -70 2 23 25 27 28 -71 5 26 25 27 28 -72 2 25 27 17 18 -73 2 17 27 25 26 - -Impropers - -1 1 2 3 13 20 -2 1 1 3 13 20 -3 1 2 3 1 20 -4 1 2 3 1 13 -5 1 16 6 8 5 -6 1 10 8 6 7 -7 1 12 10 8 9 -8 1 14 12 10 11 -9 7 14 13 4 3 -10 5 16 14 12 13 -11 1 14 16 6 15 -12 1 19 17 27 18 -13 5 17 19 21 20 -14 1 19 20 29 30 -15 1 19 20 29 3 -16 1 19 20 30 3 -17 1 29 20 30 3 -18 1 19 21 23 22 -19 1 21 23 25 24 -20 1 23 25 27 26 -21 1 17 27 25 28 diff --git a/examples/PACKAGES/reaction/create_atoms_polystyrene/grow_styrene_pre.molecule_template b/examples/PACKAGES/reaction/create_atoms_polystyrene/grow_styrene_pre.molecule_template new file mode 100644 index 0000000000..2ef1453d72 --- /dev/null +++ b/examples/PACKAGES/reaction/create_atoms_polystyrene/grow_styrene_pre.molecule_template @@ -0,0 +1,319 @@ +molecule template: end of styrene chain + + 30 atoms + 31 bonds + 51 angles + 73 dihedrals + 13 impropers + +Coords + + 1 59.899810791 62.733695984 59.098842621 + 2 61.419700623 63.421165466 59.528743744 + 3 60.864753723 62.917243958 59.559719086 + 4 62.139820099 61.410118103 60.810649872 + 5 60.036457062 57.160030365 60.319587708 + 6 59.734195709 58.187065125 60.205623627 + 7 57.645748138 57.712432861 59.860111237 + 8 58.374088287 58.501342773 59.944221497 + 9 56.943000793 60.093170166 59.595561981 + 10 57.974277496 59.855777740 59.793716431 + 11 58.632312775 61.922969818 59.790649414 + 12 58.934574127 60.895935059 59.904613495 + 13 61.309082031 61.680416107 60.283161163 + 14 60.294681549 60.581657410 60.166015625 + 15 61.725769043 58.989830017 60.514671326 + 16 60.694492340 59.227222443 60.316520691 + 17 56.909358978 62.609851837 59.150833130 + 18 57.940631866 62.372459412 59.348983765 + 19 56.509548187 63.964286804 59.000324249 + 20 57.523944855 65.063049316 59.117469788 + 21 55.149436951 64.278564453 58.738922119 + 22 54.847179413 65.305603027 58.624958038 + 23 54.189140320 63.238407135 58.628025055 + 24 53.157863617 63.475799561 58.429874420 + 25 54.588951111 61.883972168 58.778530121 + 26 53.860610962 61.095062256 58.694419861 + 27 55.949058533 61.569694519 59.039932251 + 28 56.251319885 60.542659760 59.153896332 + 29 58.354682922 64.792747498 59.644958496 + 30 57.079620361 66.299873352 58.394031525 + +Types + + 1 hc + 2 hc + 3 c2 + 4 hc + 5 hc + 6 cp + 7 hc + 8 cp + 9 hc + 10 cp + 11 hc + 12 cp + 13 c1 + 14 cp + 15 hc + 16 cp + 17 cp + 18 hc + 19 cp + 20 c1 + 21 cp + 22 hc + 23 cp + 24 hc + 25 cp + 26 hc + 27 cp + 28 hc + 29 hc + 30 c2 + +Charges + + 1 0.035400 + 2 0.035400 + 3 -0.069600 + 4 0.051600 + 5 0.140300 + 6 -0.173400 + 7 0.128800 + 8 -0.113400 + 9 0.140300 + 10 -0.173400 + 11 0.123700 + 12 -0.129000 + 13 -0.018200 + 14 0.026600 + 15 0.123700 + 16 -0.129000 + 17 -0.129000 + 18 0.123700 + 19 0.026600 + 20 -0.018200 + 21 -0.129000 + 22 0.123700 + 23 -0.173400 + 24 0.140300 + 25 -0.113400 + 26 0.128800 + 27 -0.173400 + 28 0.140300 + 29 0.051600 + 30 -0.069600 + +Molecules + + 1 1 + 2 1 + 3 1 + 4 1 + 5 1 + 6 1 + 7 1 + 8 1 + 9 1 + 10 1 + 11 1 + 12 1 + 13 1 + 14 1 + 15 1 + 16 1 + 17 1 + 18 1 + 19 1 + 20 1 + 21 1 + 22 1 + 23 1 + 24 1 + 25 1 + 26 1 + 27 1 + 28 1 + 29 1 + 30 1 + +Bonds + + 1 hc-c2 1 3 + 2 hc-c2 2 3 + 3 c1-c2 3 13 + 4 c1-c2 3 20 + 5 hc-c1 4 13 + 6 hc-cp 5 6 + 7 cp-cp 6 8 + 8 cp-cp 6 16 + 9 hc-cp 7 8 + 10 cp-cp 8 10 + 11 hc-cp 9 10 + 12 cp-cp 10 12 + 13 hc-cp 11 12 + 14 cp-cp 12 14 + 15 cp-c1 14 13 + 16 cp-cp 14 16 + 17 hc-cp 15 16 + 18 hc-cp 18 17 + 19 cp-cp 17 19 + 20 cp-cp 17 27 + 21 cp-c1 19 20 + 22 cp-cp 19 21 + 23 c1-c2 30 20 + 24 hc-c1 29 20 + 25 hc-cp 22 21 + 26 cp-cp 21 23 + 27 hc-cp 24 23 + 28 cp-cp 23 25 + 29 hc-cp 26 25 + 30 cp-cp 25 27 + 31 hc-cp 28 27 + +Angles + + 1 hc-c2-hc 1 3 2 + 2 hc-c2-c1 1 3 13 + 3 hc-c2-c1 1 3 20 + 4 hc-c2-c1 2 3 13 + 5 hc-c2-c1 2 3 20 + 6 c1-c2-c1 13 3 20 + 7 hc-cp-cp 5 6 8 + 8 hc-cp-cp 5 6 16 + 9 cp-cp-cp 8 6 16 + 10 hc-cp-cp 7 8 6 + 11 cp-cp-cp 6 8 10 + 12 hc-cp-cp 7 8 10 + 13 hc-cp-cp 9 10 8 + 14 cp-cp-cp 8 10 12 + 15 hc-cp-cp 9 10 12 + 16 hc-cp-cp 11 12 10 + 17 cp-cp-cp 10 12 14 + 18 hc-cp-cp 11 12 14 + 19 hc-c1-c2 4 13 3 + 20 cp-c1-c2 3 13 14 + 21 hc-c1-cp 4 13 14 + 22 cp-cp-c1 12 14 13 + 23 cp-cp-cp 12 14 16 + 24 cp-cp-c1 16 14 13 + 25 cp-cp-cp 6 16 14 + 26 hc-cp-cp 15 16 6 + 27 hc-cp-cp 15 16 14 + 28 hc-cp-cp 18 17 19 + 29 hc-cp-cp 18 17 27 + 30 cp-cp-cp 19 17 27 + 31 cp-cp-c1 17 19 20 + 32 cp-cp-cp 17 19 21 + 33 cp-cp-c1 21 19 20 + 34 cp-c1-c2 3 20 19 + 35 c2-c1-c2 3 20 30 + 36 hc-c1-c2 29 20 3 + 37 cp-c1-c2 30 20 19 + 38 hc-c1-cp 29 20 19 + 39 hc-c1-c2 29 20 30 + 40 hc-cp-cp 22 21 19 + 41 cp-cp-cp 19 21 23 + 42 hc-cp-cp 22 21 23 + 43 hc-cp-cp 24 23 21 + 44 cp-cp-cp 21 23 25 + 45 hc-cp-cp 24 23 25 + 46 hc-cp-cp 26 25 23 + 47 cp-cp-cp 23 25 27 + 48 hc-cp-cp 26 25 27 + 49 cp-cp-cp 17 27 25 + 50 hc-cp-cp 28 27 17 + 51 hc-cp-cp 28 27 25 + +Dihedrals + + 1 hc-c1-c2-hc 1 3 13 4 + 2 cp-c1-c2-hc 1 3 13 14 + 3 hc-c1-c2-hc 2 3 13 4 + 4 cp-c1-c2-hc 2 3 13 14 + 5 hc-c1-c2-c1 20 3 13 4 + 6 cp-c1-c2-c1 20 3 13 14 + 7 cp-c1-c2-hc 1 3 20 19 + 8 c2-c1-c2-hc 1 3 20 30 + 9 hc-c1-c2-hc 1 3 20 29 + 10 cp-c1-c2-hc 2 3 20 19 + 11 c2-c1-c2-hc 2 3 20 30 + 12 hc-c1-c2-hc 2 3 20 29 + 13 cp-c1-c2-c1 13 3 20 19 + 14 c2-c1-c2-c1 13 3 20 30 + 15 hc-c1-c2-c1 13 3 20 29 + 16 hc-cp-cp-hc 5 6 8 7 + 17 hc-cp-cp-cp 5 6 8 10 + 18 hc-cp-cp-cp 7 8 6 16 + 19 cp-cp-cp-cp 16 6 8 10 + 20 hc-cp-cp-cp 5 6 16 14 + 21 hc-cp-cp-hc 5 6 16 15 + 22 cp-cp-cp-cp 8 6 16 14 + 23 hc-cp-cp-cp 15 16 6 8 + 24 hc-cp-cp-cp 9 10 8 6 + 25 cp-cp-cp-cp 6 8 10 12 + 26 hc-cp-cp-hc 7 8 10 9 + 27 hc-cp-cp-cp 7 8 10 12 + 28 hc-cp-cp-cp 11 12 10 8 + 29 cp-cp-cp-cp 8 10 12 14 + 30 hc-cp-cp-hc 9 10 12 11 + 31 hc-cp-cp-cp 9 10 12 14 + 32 cp-cp-cp-c1 10 12 14 13 + 33 cp-cp-cp-cp 10 12 14 16 + 34 hc-cp-cp-c1 11 12 14 13 + 35 hc-cp-cp-cp 11 12 14 16 + 36 cp-cp-c1-c2 12 14 13 3 + 37 cp-cp-c1-c2 16 14 13 3 + 38 cp-cp-c1-hc 12 14 13 4 + 39 cp-cp-c1-hc 16 14 13 4 + 40 cp-cp-cp-cp 12 14 16 6 + 41 hc-cp-cp-cp 15 16 14 12 + 42 cp-cp-cp-c1 6 16 14 13 + 43 hc-cp-cp-c1 15 16 14 13 + 44 hc-cp-cp-c1 18 17 19 20 + 45 hc-cp-cp-cp 18 17 19 21 + 46 cp-cp-cp-c1 27 17 19 20 + 47 cp-cp-cp-cp 27 17 19 21 + 48 hc-cp-cp-cp 18 17 27 25 + 49 hc-cp-cp-hc 18 17 27 28 + 50 cp-cp-cp-cp 19 17 27 25 + 51 hc-cp-cp-cp 28 27 17 19 + 52 cp-cp-c1-c2 17 19 20 3 + 53 cp-cp-c1-c2 17 19 20 30 + 54 cp-cp-c1-hc 17 19 20 29 + 55 cp-cp-c1-c2 21 19 20 3 + 56 cp-cp-c1-c2 21 19 20 30 + 57 cp-cp-c1-hc 21 19 20 29 + 58 hc-cp-cp-cp 22 21 19 17 + 59 cp-cp-cp-cp 17 19 21 23 + 60 hc-cp-cp-c1 22 21 19 20 + 61 cp-cp-cp-c1 23 21 19 20 + 62 hc-cp-cp-cp 24 23 21 19 + 63 cp-cp-cp-cp 19 21 23 25 + 64 hc-cp-cp-hc 22 21 23 24 + 65 hc-cp-cp-cp 22 21 23 25 + 66 hc-cp-cp-cp 26 25 23 21 + 67 cp-cp-cp-cp 21 23 25 27 + 68 hc-cp-cp-hc 24 23 25 26 + 69 hc-cp-cp-cp 24 23 25 27 + 70 cp-cp-cp-cp 23 25 27 17 + 71 hc-cp-cp-cp 28 27 25 23 + 72 hc-cp-cp-cp 26 25 27 17 + 73 hc-cp-cp-hc 26 25 27 28 + +Impropers + + 1 hc-cp-cp-cp 5 6 8 16 + 2 hc-cp-cp-cp 7 8 6 10 + 3 hc-cp-cp-cp 9 10 8 12 + 4 hc-cp-cp-cp 11 12 10 14 + 5 hc-c1-cp-c2 4 13 3 14 + 6 cp-cp-cp-c1 12 14 16 13 + 7 hc-cp-cp-cp 15 16 14 6 + 8 hc-cp-cp-cp 18 17 19 27 + 9 cp-cp-cp-c1 17 19 21 20 + 10 hc-cp-cp-cp 22 21 19 23 + 11 hc-cp-cp-cp 24 23 21 25 + 12 hc-cp-cp-cp 26 25 23 27 + 13 hc-cp-cp-cp 28 27 25 17 diff --git a/examples/PACKAGES/reaction/create_atoms_polystyrene/in.grow_styrene b/examples/PACKAGES/reaction/create_atoms_polystyrene/in.grow_styrene index 6e34fd2a67..b17b321fe5 100644 --- a/examples/PACKAGES/reaction/create_atoms_polystyrene/in.grow_styrene +++ b/examples/PACKAGES/reaction/create_atoms_polystyrene/in.grow_styrene @@ -6,9 +6,7 @@ boundary p p p atom_style full -kspace_style pppm 1.0e-4 - -pair_style lj/class2/coul/long 8.5 +pair_style lj/class2/coul/cut 8.5 angle_style class2 @@ -27,13 +25,13 @@ read_data trimer.data & extra/improper/per/atom 25 & extra/special/per/atom 25 -molecule mol1 grow_styrene_pre.data_template -molecule mol2 grow_styrene_post.data_template +molecule mol1 grow_styrene_pre.molecule_template +molecule mol2 grow_styrene_post.molecule_template fix myrxns all bond/react stabilization yes statted_grp .03 & react rxn1 all 1 0 3.0 mol1 mol2 grow_styrene.map & modify_create fit create_fit overlap 2.0 & - stabilize_steps 100 max_rxn 30 + stabilize_steps 200 max_rxn 30 fix 1 statted_grp_REACT nvt temp $T $T 100 diff --git a/examples/PACKAGES/reaction/create_atoms_polystyrene/log.24Dec20.grow_styrene.g++.1 b/examples/PACKAGES/reaction/create_atoms_polystyrene/log.24Dec20.grow_styrene.g++.1 deleted file mode 100644 index 5f1f2c6698..0000000000 --- a/examples/PACKAGES/reaction/create_atoms_polystyrene/log.24Dec20.grow_styrene.g++.1 +++ /dev/null @@ -1,196 +0,0 @@ -LAMMPS (24 Dec 2020) -Reading data file ... - orthogonal box = (50.000000 50.000000 50.000000) to (250.00000 250.00000 250.00000) - 1 by 1 by 1 MPI processor grid - reading atoms ... - 48 atoms - reading velocities ... - 48 velocities - scanning bonds ... - 8 = max bonds/atom - scanning angles ... - 21 = max angles/atom - scanning dihedrals ... - 33 = max dihedrals/atom - scanning impropers ... - 29 = max impropers/atom - reading bonds ... - 50 bonds - reading angles ... - 84 angles - reading dihedrals ... - 127 dihedrals - reading impropers ... - 36 impropers -Finding 1-2 1-3 1-4 neighbors ... - special bond factors lj: 0 0 0 - special bond factors coul: 0 0 0 - 4 = max # of 1-2 neighbors - 8 = max # of 1-3 neighbors - 17 = max # of 1-4 neighbors - 46 = max # of special neighbors - special bonds CPU = 0.000 seconds - read_data CPU = 0.077 seconds -Read molecule template mol1: - 1 molecules - 30 atoms with max type 6 - 31 bonds with max type 10 - 51 angles with max type 16 - 73 dihedrals with max type 19 - 21 impropers with max type 7 -Read molecule template mol2: - 1 molecules - 46 atoms with max type 6 - 48 bonds with max type 13 - 81 angles with max type 22 - 121 dihedrals with max type 36 - 35 impropers with max type 9 -dynamic group bond_react_MASTER_group defined -dynamic group statted_grp_REACT defined -PPPM initialization ... -WARNING: System is not charge neutral, net charge = -0.00060000000 (../kspace.cpp:324) - using 12-bit tables for long-range coulomb (../kspace.cpp:339) - G vector (1/distance) = 0.20144813 - grid = 45 45 45 - stencil order = 5 - estimated absolute RMS force accuracy = 0.00053712952 - estimated relative force accuracy = 1.6175496e-06 - using double precision KISS FFT - 3d grid and FFT values/proc = 125000 91125 -Neighbor list info ... - update every 1 steps, delay 10 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 = 39 39 39 - 2 neighbor lists, perpetual/occasional/extra = 1 1 0 - (1) pair lj/class2/coul/long, perpetual - attributes: half, newton on - pair build: half/bin/newton - stencil: half/bin/3d/newton - bin: standard - (2) fix bond/react, occasional, copy from (1) - attributes: half, newton on - pair build: copy - stencil: none - bin: none -Setting up Verlet run ... - Unit style : real - Current step : 0 - Time step : 1 -Per MPI rank memory allocation (min/avg/max) = 48.02 | 48.02 | 48.02 Mbytes -Step Temp Press Density f_myrxns[1] - 0 496.23742 0.9983211 6.4856516e-05 0 - 100 534.05394 -0.76952227 6.4856516e-05 0 - 200 552.2225 -0.55375493 6.4856516e-05 0 - 300 857.52834 -0.4272061 8.6475354e-05 1 - 400 714.10681 1.5004615 8.6475354e-05 1 - 500 678.19171 0.21965471 8.6475354e-05 1 - 600 572.3234 0.87879933 8.6475354e-05 1 - 700 996.17398 -0.24269717 0.00010809419 2 - 800 904.50395 1.3662054 0.00010809419 2 - 900 1097.1568 -2.2909907 0.00012971303 3 - 1000 954.08892 1.7705672 0.00012971303 3 - 1100 1102.0377 -1.7018446 0.00015133187 4 - 1200 1239.785 -0.30442903 0.00015133187 4 - 1300 1388.4127 1.3301175 0.00017295071 5 - 1400 1559.3853 1.6709729 0.00017295071 5 - 1500 1471.8623 0.8268427 0.00017295071 5 - 1600 1543.6793 2.1987908 0.00019456955 6 - 1700 1694.5595 0.48852817 0.00019456955 6 - 1800 1632.7737 -1.4617692 0.00021618839 7 - 1900 1922.6502 1.1664257 0.00021618839 7 - 2000 2223.503 -0.95799878 0.00023780722 8 - 2100 2142.6035 0.88444463 0.00025942606 9 - 2200 2298.8636 3.4239313 0.00025942606 9 - 2300 2252.4355 0.82167302 0.00025942606 9 - 2400 2321.0788 1.7499714 0.00025942606 9 - 2500 2095.6715 0.55288444 0.00025942606 9 - 2600 2136.0316 -3.833114 0.00025942606 9 - 2700 2466.3134 -2.2519511 0.00025942606 9 - 2800 2294.3454 1.0637304 0.00025942606 9 - 2900 2340.3891 1.3997049 0.0002810449 10 - 3000 2272.0013 -0.27591886 0.0002810449 10 - 3100 2333.9696 -0.11772138 0.0002810449 10 - 3200 2409.0946 -1.025473 0.0002810449 10 - 3300 2148.023 1.6752329 0.0002810449 10 - 3400 2267.636 -0.45297583 0.0002810449 10 - 3500 2457.622 0.35627297 0.0002810449 10 - 3600 2288.008 -15.516626 0.00030266374 11 - 3700 2458.2681 1.4571773 0.00030266374 11 - 3800 2566.7623 -29.140553 0.00032428258 12 - 3900 2839.4062 0.64583638 0.00032428258 12 - 4000 2893.9852 -52.954497 0.00034590142 13 - 4100 3021.3611 -65.03731 0.00036752025 14 - 4200 3002.7136 1.5750081 0.00036752025 14 - 4300 3218.6248 -120.74039 0.00038913909 15 - 4400 3345.1482 -0.96545269 0.00038913909 15 - 4500 3603.2429 1.2438833 0.00038913909 15 - 4600 3129.8814 -249.91806 0.00041075793 16 - 4700 3769.052 -289.24351 0.00043237677 17 - 4800 3560.4714 -3.1655406 0.00043237677 17 - 4900 3452.2717 -2.1270765 0.00043237677 17 - 5000 3594.3247 -523.48506 0.00045399561 18 - 5100 3578.4199 1.0009097 0.00045399561 18 - 5200 3822.1566 1.0526914 0.00047561445 19 - 5300 3901.8883 -0.14607602 0.00047561445 19 - 5400 4059.3644 -1.7789927 0.00049723329 20 - 5500 4163.6847 1.0240127 0.00049723329 20 - 5600 4109.1649 0.80199787 0.00049723329 20 - 5700 4391.2091 2.8730036 0.00049723329 20 - 5800 4279.6579 -0.36499822 0.00051885212 21 - 5900 4296.2695 -1.3064528 0.00051885212 21 - 6000 4065.3758 -2.0483224 0.00051885212 21 - 6100 4772.5362 -2.6814694 0.00054047096 22 - 6200 4627.029 2.999215 0.0005620898 23 - 6300 5120.7881 0.65372968 0.00058370864 24 - 6400 4588.9559 3.7570705 0.00058370864 24 - 6500 5008.7814 2.3595833 0.00060532748 25 - 6600 5195.0053 1.4641612 0.00060532748 25 - 6700 5622.293 -0.33396047 0.00062694632 26 - 6800 5515.1957 -4.234874 0.00062694632 26 - 6900 5156.7455 0.40171954 0.00064856516 27 - 7000 5120.1639 -1.6065245 0.00064856516 27 - 7100 5650.0327 0.94436323 0.00067018399 28 - 7200 5985.1115 -3.8940347 0.00069180283 29 - 7300 5983.197 0.5293568 0.00069180283 29 - 7400 6001.1559 -0.13712834 0.00071342167 30 - 7500 5889.2134 0.17230892 0.00071342167 30 - 7600 5797.31 2.0920058 0.00071342167 30 - 7700 5865.2783 -0.18556395 0.00071342167 30 - 7800 6207.0659 -5.6237083 0.00071342167 30 - 7900 5627.5108 -2.3718942 0.00071342167 30 - 8000 5823.9502 -0.85418578 0.00071342167 30 -Loop time of 184.87 on 1 procs for 8000 steps with 528 atoms - -Performance: 3.739 ns/day, 6.419 hours/ns, 43.274 timesteps/s -99.9% CPU use with 1 MPI tasks x no OpenMP threads - -MPI task timing breakdown: -Section | min time | avg time | max time |%varavg| %total ---------------------------------------------------------------- -Pair | 3.3043 | 3.3043 | 3.3043 | 0.0 | 1.79 -Bond | 8.0003 | 8.0003 | 8.0003 | 0.0 | 4.33 -Kspace | 168.33 | 168.33 | 168.33 | 0.0 | 91.05 -Neigh | 4.6322 | 4.6322 | 4.6322 | 0.0 | 2.51 -Comm | 0.077927 | 0.077927 | 0.077927 | 0.0 | 0.04 -Output | 0.0020548 | 0.0020548 | 0.0020548 | 0.0 | 0.00 -Modify | 0.5005 | 0.5005 | 0.5005 | 0.0 | 0.27 -Other | | 0.02483 | | | 0.01 - -Nlocal: 528.000 ave 528 max 528 min -Histogram: 1 0 0 0 0 0 0 0 0 0 -Nghost: 341.000 ave 341 max 341 min -Histogram: 1 0 0 0 0 0 0 0 0 0 -Neighs: 35111.0 ave 35111 max 35111 min -Histogram: 1 0 0 0 0 0 0 0 0 0 - -Total # of neighbors = 35111 -Ave neighs/atom = 66.498106 -Ave special neighs/atom = 11.409091 -Neighbor list builds = 8000 -Dangerous builds = 0 - -Please see the log.cite file for references relevant to this simulation - -Total wall time: 0:03:05 diff --git a/examples/PACKAGES/reaction/create_atoms_polystyrene/log.24Dec20.grow_styrene.g++.4 b/examples/PACKAGES/reaction/create_atoms_polystyrene/log.24Dec20.grow_styrene.g++.4 deleted file mode 100644 index 8daa6d8161..0000000000 --- a/examples/PACKAGES/reaction/create_atoms_polystyrene/log.24Dec20.grow_styrene.g++.4 +++ /dev/null @@ -1,196 +0,0 @@ -LAMMPS (24 Dec 2020) -Reading data file ... - orthogonal box = (50.000000 50.000000 50.000000) to (250.00000 250.00000 250.00000) - 1 by 2 by 2 MPI processor grid - reading atoms ... - 48 atoms - reading velocities ... - 48 velocities - scanning bonds ... - 8 = max bonds/atom - scanning angles ... - 21 = max angles/atom - scanning dihedrals ... - 33 = max dihedrals/atom - scanning impropers ... - 29 = max impropers/atom - reading bonds ... - 50 bonds - reading angles ... - 84 angles - reading dihedrals ... - 127 dihedrals - reading impropers ... - 36 impropers -Finding 1-2 1-3 1-4 neighbors ... - special bond factors lj: 0 0 0 - special bond factors coul: 0 0 0 - 4 = max # of 1-2 neighbors - 8 = max # of 1-3 neighbors - 17 = max # of 1-4 neighbors - 46 = max # of special neighbors - special bonds CPU = 0.000 seconds - read_data CPU = 0.007 seconds -Read molecule template mol1: - 1 molecules - 30 atoms with max type 6 - 31 bonds with max type 10 - 51 angles with max type 16 - 73 dihedrals with max type 19 - 21 impropers with max type 7 -Read molecule template mol2: - 1 molecules - 46 atoms with max type 6 - 48 bonds with max type 13 - 81 angles with max type 22 - 121 dihedrals with max type 36 - 35 impropers with max type 9 -dynamic group bond_react_MASTER_group defined -dynamic group statted_grp_REACT defined -PPPM initialization ... -WARNING: System is not charge neutral, net charge = -0.00060000000 (../kspace.cpp:324) - using 12-bit tables for long-range coulomb (../kspace.cpp:339) - G vector (1/distance) = 0.20144813 - grid = 45 45 45 - stencil order = 5 - estimated absolute RMS force accuracy = 0.00053712952 - estimated relative force accuracy = 1.6175496e-06 - using double precision KISS FFT - 3d grid and FFT values/proc = 39200 24300 -Neighbor list info ... - update every 1 steps, delay 10 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 = 39 39 39 - 2 neighbor lists, perpetual/occasional/extra = 1 1 0 - (1) pair lj/class2/coul/long, perpetual - attributes: half, newton on - pair build: half/bin/newton - stencil: half/bin/3d/newton - bin: standard - (2) fix bond/react, occasional, copy from (1) - attributes: half, newton on - pair build: copy - stencil: none - bin: none -Setting up Verlet run ... - Unit style : real - Current step : 0 - Time step : 1 -Per MPI rank memory allocation (min/avg/max) = 38.70 | 38.92 | 39.43 Mbytes -Step Temp Press Density f_myrxns[1] - 0 496.23742 0.9983211 6.4856516e-05 0 - 100 534.05394 -0.76952227 6.4856516e-05 0 - 200 552.2225 -0.55375493 6.4856516e-05 0 - 300 857.52834 -0.4272061 8.6475354e-05 1 - 400 714.10681 1.5004615 8.6475354e-05 1 - 500 678.19171 0.21965471 8.6475354e-05 1 - 600 572.3234 0.87879933 8.6475354e-05 1 - 700 996.17398 -0.24269717 0.00010809419 2 - 800 904.50395 1.3662054 0.00010809419 2 - 900 1097.1568 -2.2909907 0.00012971303 3 - 1000 954.08892 1.7705672 0.00012971303 3 - 1100 1102.0377 -1.7018446 0.00015133187 4 - 1200 1239.785 -0.30442903 0.00015133187 4 - 1300 1388.4127 1.3301175 0.00017295071 5 - 1400 1559.3853 1.6709729 0.00017295071 5 - 1500 1471.8623 0.8268427 0.00017295071 5 - 1600 1543.6793 2.1987908 0.00019456955 6 - 1700 1694.5595 0.48852817 0.00019456955 6 - 1800 1632.7737 -1.4617692 0.00021618839 7 - 1900 1922.6502 1.1664257 0.00021618839 7 - 2000 2223.503 -0.95799878 0.00023780722 8 - 2100 2142.6035 0.88444463 0.00025942606 9 - 2200 2298.8636 3.4239313 0.00025942606 9 - 2300 2252.4355 0.82167302 0.00025942606 9 - 2400 2321.0788 1.7499714 0.00025942606 9 - 2500 2095.6715 0.55288444 0.00025942606 9 - 2600 2136.0316 -3.833114 0.00025942606 9 - 2700 2466.3134 -2.2519511 0.00025942606 9 - 2800 2294.3454 1.0637304 0.00025942606 9 - 2900 2340.3891 1.3997049 0.0002810449 10 - 3000 2272.0013 -0.27591886 0.0002810449 10 - 3100 2333.9696 -0.11772138 0.0002810449 10 - 3200 2409.0946 -1.025473 0.0002810449 10 - 3300 2148.023 1.6752329 0.0002810449 10 - 3400 2267.636 -0.45297583 0.0002810449 10 - 3500 2457.622 0.35627297 0.0002810449 10 - 3600 2288.008 -15.516626 0.00030266374 11 - 3700 2458.2681 1.4571773 0.00030266374 11 - 3800 2566.7623 -29.140553 0.00032428258 12 - 3900 2839.4062 0.64583638 0.00032428258 12 - 4000 2893.2204 -53.187892 0.00034590142 13 - 4100 3024.6375 -65.068146 0.00036752025 14 - 4200 3004.6784 1.4155214 0.00036752025 14 - 4300 3033.1895 1.8572273 0.00036752025 14 - 4400 3157.2542 -0.92462977 0.00036752025 14 - 4500 3557.7137 -194.46498 0.00038913909 15 - 4600 3096.485 -1.830492 0.00038913909 15 - 4700 3488.088 -286.81055 0.00041075793 16 - 4800 3390.5493 -372.77818 0.00043237677 17 - 4900 3773.7226 -446.58574 0.00045399561 18 - 5000 3703.0159 -0.81188551 0.00045399561 18 - 5100 4051.3067 1.2567439 0.00045399561 18 - 5200 3813.3682 0.92945737 0.00047561445 19 - 5300 4036.0078 -2.5336258 0.00049723329 20 - 5400 4219.803 -0.96928261 0.00049723329 20 - 5500 4433.7447 -0.026762463 0.00051885212 21 - 5600 4477.4505 -1.417316 0.00054047096 22 - 5700 4500.0306 -1.0551443 0.00054047096 22 - 5800 4600.3507 -4.9580056 0.00054047096 22 - 5900 4765.4978 -2.2546941 0.0005620898 23 - 6000 5442.6193 0.91161284 0.00058370864 24 - 6100 5086.8047 -0.9875332 0.00060532748 25 - 6200 5485.3437 -2.8296626 0.00062694632 26 - 6300 4988.0396 -0.15179023 0.00064856516 27 - 6400 5597.3703 4.2941885 0.00067018399 28 - 6500 5677.0263 -2.8611595 0.00069180283 29 - 6600 6058.0009 1.4111778 0.00071342167 30 - 6700 5859.0817 -2.5782466 0.00071342167 30 - 6800 5879.3941 -4.5681807 0.00071342167 30 - 6900 6398.288 2.5259412 0.00071342167 30 - 7000 6250.1096 -2.6049627 0.00071342167 30 - 7100 5849.651 -0.44062578 0.00071342167 30 - 7200 5778.6532 -0.27299118 0.00071342167 30 - 7300 5977.6661 4.2483639 0.00071342167 30 - 7400 5862.4231 1.0289519 0.00071342167 30 - 7500 6482.376 7.5412373 0.00071342167 30 - 7600 5810.4325 1.0343075 0.00071342167 30 - 7700 5916.7304 2.304302 0.00071342167 30 - 7800 5869.9504 -0.5946555 0.00071342167 30 - 7900 5804.0522 -4.1207689 0.00071342167 30 - 8000 6077.1704 0.52211243 0.00071342167 30 -Loop time of 60.5603 on 4 procs for 8000 steps with 528 atoms - -Performance: 11.413 ns/day, 2.103 hours/ns, 132.100 timesteps/s -99.9% CPU use with 4 MPI tasks x no OpenMP threads - -MPI task timing breakdown: -Section | min time | avg time | max time |%varavg| %total ---------------------------------------------------------------- -Pair | 0.0041695 | 0.90113 | 2.3423 | 102.8 | 1.49 -Bond | 0.011606 | 2.1188 | 5.8107 | 163.9 | 3.50 -Kspace | 47.987 | 52.817 | 55.679 | 43.7 | 87.21 -Neigh | 3.5961 | 3.6262 | 3.6496 | 1.2 | 5.99 -Comm | 0.11097 | 0.16569 | 0.26369 | 15.3 | 0.27 -Output | 0.0020366 | 0.0023427 | 0.0032469 | 1.1 | 0.00 -Modify | 0.62302 | 0.91659 | 1.1227 | 21.5 | 1.51 -Other | | 0.0126 | | | 0.02 - -Nlocal: 132.000 ave 295 max 0 min -Histogram: 2 0 0 0 0 0 0 1 0 1 -Nghost: 133.000 ave 349 max 0 min -Histogram: 2 0 0 0 0 1 0 0 0 1 -Neighs: 8383.50 ave 20143 max 0 min -Histogram: 2 0 0 0 0 0 1 0 0 1 - -Total # of neighbors = 33534 -Ave neighs/atom = 63.511364 -Ave special neighs/atom = 11.409091 -Neighbor list builds = 8000 -Dangerous builds = 0 - -Please see the log.cite file for references relevant to this simulation - -Total wall time: 0:01:00 diff --git a/examples/PACKAGES/reaction/create_atoms_polystyrene/log.4Nov2022.grow_styrene.g++.1 b/examples/PACKAGES/reaction/create_atoms_polystyrene/log.4Nov2022.grow_styrene.g++.1 new file mode 100644 index 0000000000..fb9b22d134 --- /dev/null +++ b/examples/PACKAGES/reaction/create_atoms_polystyrene/log.4Nov2022.grow_styrene.g++.1 @@ -0,0 +1,256 @@ +LAMMPS (4 Nov 2022) +# use bond/react 'create atoms' feature to add 30 new styrene monomers to chain + +units real + +boundary p p p + +atom_style full + +pair_style lj/class2/coul/cut 8.5 + +angle_style class2 + +bond_style class2 + +dihedral_style class2 + +improper_style class2 + +variable T equal 530 + +read_data trimer.data extra/bond/per/atom 5 extra/angle/per/atom 15 extra/dihedral/per/atom 15 extra/improper/per/atom 25 extra/special/per/atom 25 +Reading data file ... + orthogonal box = (-200 -200 -200) to (200 200 200) + 1 by 1 by 1 MPI processor grid + reading atom labelmap ... + reading bond labelmap ... + reading angle labelmap ... + reading dihedral labelmap ... + reading improper labelmap ... + reading atoms ... + 48 atoms + scanning bonds ... + 8 = max bonds/atom + scanning angles ... + 21 = max angles/atom + scanning dihedrals ... + 33 = max dihedrals/atom + scanning impropers ... + 26 = max impropers/atom + reading bonds ... + 50 bonds + reading angles ... + 84 angles + reading dihedrals ... + 127 dihedrals + reading impropers ... + 20 impropers +Finding 1-2 1-3 1-4 neighbors ... + special bond factors lj: 0 0 0 + special bond factors coul: 0 0 0 + 4 = max # of 1-2 neighbors + 8 = max # of 1-3 neighbors + 17 = max # of 1-4 neighbors + 46 = max # of special neighbors + special bonds CPU = 0.000 seconds + read_data CPU = 0.011 seconds + +molecule mol1 grow_styrene_pre.molecule_template +Read molecule template mol1: + 1 molecules + 0 fragments + 30 atoms with max type 4 + 31 bonds with max type 6 + 51 angles with max type 10 + 73 dihedrals with max type 13 + 13 impropers with max type 3 +molecule mol2 grow_styrene_post.molecule_template +Read molecule template mol2: + 1 molecules + 1 fragments + 46 atoms with max type 4 + 48 bonds with max type 6 + 81 angles with max type 10 + 121 dihedrals with max type 13 + 19 impropers with max type 3 + +fix myrxns all bond/react stabilization yes statted_grp .03 react rxn1 all 1 0 3.0 mol1 mol2 grow_styrene.map modify_create fit create_fit overlap 2.0 stabilize_steps 200 max_rxn 30 +dynamic group bond_react_MASTER_group defined +dynamic group statted_grp_REACT defined + +fix 1 statted_grp_REACT nvt temp $T $T 100 +fix 1 statted_grp_REACT nvt temp 530 $T 100 +fix 1 statted_grp_REACT nvt temp 530 530 100 + +fix 4 bond_react_MASTER_group temp/rescale 1 $T $T 1 1 +fix 4 bond_react_MASTER_group temp/rescale 1 530 $T 1 1 +fix 4 bond_react_MASTER_group temp/rescale 1 530 530 1 1 + +thermo_style custom step temp press density f_myrxns[1] + +thermo 100 + +dump 1 all xyz 1 test_vis.xyz + +run 8000 + +CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE + +Your simulation uses code contributions which should be cited: + +- fix bond/react: reacter.org doi:10.1016/j.polymer.2017.09.038, doi:10.1021/acs.macromol.0c02012 + +@Article{Gissinger17, + author = {J. R. Gissinger and B. D. Jensen and K. E. Wise}, + title = {Modeling Chemical Reactions in Classical Molecular Dynamics Simulations}, + journal = {Polymer}, + year = 2017, + volume = 128, + pages = {211--217} +} + +@Article{Gissinger20, + author = {J. R. Gissinger, B. D. Jensen, K. E. Wise}, + title = {{REACTER}: A Heuristic Method for Reactive Molecular Dynamics}, + journal = {Macromolecules}, + year = 2020, + volume = 53, + number = 22, + pages = {9953--9961} +} + +CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE + +Generated 6 of 6 mixed pair_coeff terms from sixthpower/geometric mixing rule +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 = 77 77 77 + 2 neighbor lists, perpetual/occasional/extra = 1 1 0 + (1) pair lj/class2/coul/cut, perpetual + attributes: half, newton on + pair build: half/bin/newton + stencil: half/bin/3d + bin: standard + (2) fix bond/react, occasional, copy from (1) + attributes: half, newton on + pair build: copy + stencil: none + bin: none +Per MPI rank memory allocation (min/avg/max) = 36.99 | 36.99 | 36.99 Mbytes + Step Temp Press Density f_myrxns[1] + 0 0 0.076588866 8.1070333e-06 0 + 100 598.41967 -0.1670029 1.0809378e-05 1 + 200 696.77845 0.11857422 1.0809378e-05 1 + 300 932.97222 -0.058615676 1.3511722e-05 2 + 400 1016.3732 0.062233715 1.3511722e-05 2 + 500 1006.451 -0.17987841 1.6214067e-05 3 + 600 1143.8859 0.33297898 1.6214067e-05 3 + 700 1209.6144 -0.22743773 1.8916411e-05 4 + 800 1429.1639 0.14048255 1.8916411e-05 4 + 900 1375.0968 -0.04016551 2.1618755e-05 5 + 1000 1583.6696 -0.23364852 2.1618755e-05 5 + 1100 1811.0697 -0.054436797 2.43211e-05 6 + 1200 1928.4658 0.012242837 2.43211e-05 6 + 1300 1666.6176 0.057157656 2.43211e-05 6 + 1400 1686.18 -28.442814 2.7023444e-05 7 + 1500 1704.6248 -0.16861218 2.7023444e-05 7 + 1600 2171.7628 -33.6156 2.9725789e-05 8 + 1700 1991.2922 -0.11813381 2.9725789e-05 8 + 1800 2037.4991 -40.015612 3.2428133e-05 9 + 1900 2143.9447 -0.090964375 3.2428133e-05 9 + 2000 1927.9564 0.29856007 3.2428133e-05 9 + 2100 2255.5877 -4.9166327 3.5130478e-05 10 + 2200 2512.5193 0.00044804842 3.5130478e-05 10 + 2300 2336.1503 -45.094726 3.7832822e-05 11 + 2400 2508.9655 -0.1024684 3.7832822e-05 11 + 2500 2747.7344 -53.939212 4.0535167e-05 12 + 2600 2790.5736 0.07042181 4.0535167e-05 12 + 2700 3014.7092 -0.0025387793 4.0535167e-05 12 + 2800 2745.0295 -0.099361314 4.3237511e-05 13 + 2900 2952.1281 -0.13667582 4.3237511e-05 13 + 3000 3032.5298 0.28882784 4.5939855e-05 14 + 3100 3149.992 0.55269076 4.5939855e-05 14 + 3200 3422.5233 -0.11794908 4.86422e-05 15 + 3300 3040.2691 -0.067532834 4.86422e-05 15 + 3400 3323.3263 0.049969149 5.1344544e-05 16 + 3500 3539.0877 -0.065546641 5.1344544e-05 16 + 3600 3894.6897 -0.24222461 5.4046889e-05 17 + 3700 3689.3513 0.21366533 5.4046889e-05 17 + 3800 3924.799 -0.60817646 5.6749233e-05 18 + 3900 3713.1947 -0.024834682 5.6749233e-05 18 + 4000 3887.6151 0.052787631 5.9451578e-05 19 + 4100 3868.2877 0.42532898 5.9451578e-05 19 + 4200 3784.9874 -0.12018512 5.9451578e-05 19 + 4300 4169.9997 0.19652089 6.2153922e-05 20 + 4400 4112.291 -0.084839982 6.2153922e-05 20 + 4500 3974.2226 -0.13641761 6.2153922e-05 20 + 4600 4064.3852 0.16435039 6.2153922e-05 20 + 4700 3880.0044 -0.42874552 6.2153922e-05 20 + 4800 4508.2324 0.20208091 6.2153922e-05 20 + 4900 4364.033 -0.56300441 6.2153922e-05 20 + 5000 4030.4642 -0.29006515 6.2153922e-05 20 + 5100 4010.9518 0.32060145 6.2153922e-05 20 + 5200 4058.5072 0.088924924 6.2153922e-05 20 + 5300 4529.9866 -0.38882748 6.4856266e-05 21 + 5400 4305.9161 0.24046553 6.4856266e-05 21 + 5500 4556.8628 -0.014044879 6.4856266e-05 21 + 5600 4730.2206 0.1526293 6.4856266e-05 21 + 5700 4810.9968 -17.600253 6.7558611e-05 22 + 5800 4655.651 -0.25941928 6.7558611e-05 22 + 5900 4507.1045 -0.084691005 6.7558611e-05 22 + 6000 4516.0965 0.092662842 7.0260955e-05 23 + 6100 4592.4068 0.10403004 7.0260955e-05 23 + 6200 4583.9491 0.1692786 7.29633e-05 24 + 6300 4512.226 0.32590723 7.29633e-05 24 + 6400 4885.9205 -0.24208842 7.5665644e-05 25 + 6500 5250.5008 0.4135064 7.5665644e-05 25 + 6600 5216.9452 0.00059199905 7.8367989e-05 26 + 6700 5302.2925 0.50452368 7.8367989e-05 26 + 6800 4931.7328 -0.064719953 8.1070333e-05 27 + 6900 5549.8746 0.55101191 8.1070333e-05 27 + 7000 5472.9107 0.31358281 8.3772677e-05 28 + 7100 5559.9339 0.14034743 8.3772677e-05 28 + 7200 5726.4492 -0.39732059 8.6475022e-05 29 + 7300 5869.324 0.18989804 8.6475022e-05 29 + 7400 6109.5519 0.11206572 8.9177366e-05 30 + 7500 5966.7085 0.2059557 8.9177366e-05 30 + 7600 6051.2064 0.025316679 8.9177366e-05 30 + 7700 5719.6669 0.16548544 8.9177366e-05 30 + 7800 6118.8183 -0.20036999 8.9177366e-05 30 + 7900 6477.1901 0.10308473 8.9177366e-05 30 + 8000 6241.9498 0.090165102 8.9177366e-05 30 +Loop time of 17.4848 on 1 procs for 8000 steps with 528 atoms + +Performance: 39.531 ns/day, 0.607 hours/ns, 457.540 timesteps/s, 241.581 katom-step/s +97.6% CPU use with 1 MPI tasks x no OpenMP threads + +MPI task timing breakdown: +Section | min time | avg time | max time |%varavg| %total +--------------------------------------------------------------- +Pair | 3.0991 | 3.0991 | 3.0991 | 0.0 | 17.72 +Bond | 7.6807 | 7.6807 | 7.6807 | 0.0 | 43.93 +Neigh | 1.6906 | 1.6906 | 1.6906 | 0.0 | 9.67 +Comm | 0.019091 | 0.019091 | 0.019091 | 0.0 | 0.11 +Output | 4.5095 | 4.5095 | 4.5095 | 0.0 | 25.79 +Modify | 0.46277 | 0.46277 | 0.46277 | 0.0 | 2.65 +Other | | 0.02296 | | | 0.13 + +Nlocal: 528 ave 528 max 528 min +Histogram: 1 0 0 0 0 0 0 0 0 0 +Nghost: 0 ave 0 max 0 min +Histogram: 1 0 0 0 0 0 0 0 0 0 +Neighs: 35904 ave 35904 max 35904 min +Histogram: 1 0 0 0 0 0 0 0 0 0 + +Total # of neighbors = 35904 +Ave neighs/atom = 68 +Ave special neighs/atom = 11.409091 +Neighbor list builds = 1836 +Dangerous builds = 0 + +# write_data final.data nofix +Total wall time: 0:00:17 diff --git a/examples/PACKAGES/reaction/create_atoms_polystyrene/log.4Nov2022.grow_styrene.g++.4 b/examples/PACKAGES/reaction/create_atoms_polystyrene/log.4Nov2022.grow_styrene.g++.4 new file mode 100644 index 0000000000..b14ff6c8d0 --- /dev/null +++ b/examples/PACKAGES/reaction/create_atoms_polystyrene/log.4Nov2022.grow_styrene.g++.4 @@ -0,0 +1,256 @@ +LAMMPS (4 Nov 2022) +# use bond/react 'create atoms' feature to add 30 new styrene monomers to chain + +units real + +boundary p p p + +atom_style full + +pair_style lj/class2/coul/cut 8.5 + +angle_style class2 + +bond_style class2 + +dihedral_style class2 + +improper_style class2 + +variable T equal 530 + +read_data trimer.data extra/bond/per/atom 5 extra/angle/per/atom 15 extra/dihedral/per/atom 15 extra/improper/per/atom 25 extra/special/per/atom 25 +Reading data file ... + orthogonal box = (-200 -200 -200) to (200 200 200) + 1 by 2 by 2 MPI processor grid + reading atom labelmap ... + reading bond labelmap ... + reading angle labelmap ... + reading dihedral labelmap ... + reading improper labelmap ... + reading atoms ... + 48 atoms + scanning bonds ... + 8 = max bonds/atom + scanning angles ... + 21 = max angles/atom + scanning dihedrals ... + 33 = max dihedrals/atom + scanning impropers ... + 26 = max impropers/atom + reading bonds ... + 50 bonds + reading angles ... + 84 angles + reading dihedrals ... + 127 dihedrals + reading impropers ... + 20 impropers +Finding 1-2 1-3 1-4 neighbors ... + special bond factors lj: 0 0 0 + special bond factors coul: 0 0 0 + 4 = max # of 1-2 neighbors + 8 = max # of 1-3 neighbors + 17 = max # of 1-4 neighbors + 46 = max # of special neighbors + special bonds CPU = 0.000 seconds + read_data CPU = 0.007 seconds + +molecule mol1 grow_styrene_pre.molecule_template +Read molecule template mol1: + 1 molecules + 0 fragments + 30 atoms with max type 4 + 31 bonds with max type 6 + 51 angles with max type 10 + 73 dihedrals with max type 13 + 13 impropers with max type 3 +molecule mol2 grow_styrene_post.molecule_template +Read molecule template mol2: + 1 molecules + 1 fragments + 46 atoms with max type 4 + 48 bonds with max type 6 + 81 angles with max type 10 + 121 dihedrals with max type 13 + 19 impropers with max type 3 + +fix myrxns all bond/react stabilization yes statted_grp .03 react rxn1 all 1 0 3.0 mol1 mol2 grow_styrene.map modify_create fit create_fit overlap 2.0 stabilize_steps 200 max_rxn 30 +dynamic group bond_react_MASTER_group defined +dynamic group statted_grp_REACT defined + +fix 1 statted_grp_REACT nvt temp $T $T 100 +fix 1 statted_grp_REACT nvt temp 530 $T 100 +fix 1 statted_grp_REACT nvt temp 530 530 100 + +fix 4 bond_react_MASTER_group temp/rescale 1 $T $T 1 1 +fix 4 bond_react_MASTER_group temp/rescale 1 530 $T 1 1 +fix 4 bond_react_MASTER_group temp/rescale 1 530 530 1 1 + +thermo_style custom step temp press density f_myrxns[1] + +thermo 100 + +dump 1 all xyz 1 test_vis.xyz + +run 8000 + +CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE + +Your simulation uses code contributions which should be cited: + +- fix bond/react: reacter.org doi:10.1016/j.polymer.2017.09.038, doi:10.1021/acs.macromol.0c02012 + +@Article{Gissinger17, + author = {J. R. Gissinger and B. D. Jensen and K. E. Wise}, + title = {Modeling Chemical Reactions in Classical Molecular Dynamics Simulations}, + journal = {Polymer}, + year = 2017, + volume = 128, + pages = {211--217} +} + +@Article{Gissinger20, + author = {J. R. Gissinger, B. D. Jensen, K. E. Wise}, + title = {{REACTER}: A Heuristic Method for Reactive Molecular Dynamics}, + journal = {Macromolecules}, + year = 2020, + volume = 53, + number = 22, + pages = {9953--9961} +} + +CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE + +Generated 6 of 6 mixed pair_coeff terms from sixthpower/geometric mixing rule +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 = 77 77 77 + 2 neighbor lists, perpetual/occasional/extra = 1 1 0 + (1) pair lj/class2/coul/cut, perpetual + attributes: half, newton on + pair build: half/bin/newton + stencil: half/bin/3d + bin: standard + (2) fix bond/react, occasional, copy from (1) + attributes: half, newton on + pair build: copy + stencil: none + bin: none +Per MPI rank memory allocation (min/avg/max) = 35.37 | 35.56 | 36.15 Mbytes + Step Temp Press Density f_myrxns[1] + 0 0 0.076588866 8.1070333e-06 0 + 100 598.29879 -0.17888669 1.0809378e-05 1 + 200 699.08337 0.11172183 1.0809378e-05 1 + 300 931.85797 -0.13923465 1.3511722e-05 2 + 400 893.78126 0.14680427 1.3511722e-05 2 + 500 1001.0848 -0.021703999 1.6214067e-05 3 + 600 989.24943 0.04641672 1.6214067e-05 3 + 700 1244.794 -0.19464667 1.8916411e-05 4 + 800 1210.997 -0.06710628 1.8916411e-05 4 + 900 1310.0005 0.099408095 2.1618755e-05 5 + 1000 1640.5956 -0.05975911 2.1618755e-05 5 + 1100 1380.7273 -0.025206389 2.1618755e-05 5 + 1200 1637.6542 0.057149266 2.43211e-05 6 + 1300 1757.3409 0.3232123 2.43211e-05 6 + 1400 1664.5048 -0.29656858 2.7023444e-05 7 + 1500 1578.9691 0.21997047 2.7023444e-05 7 + 1600 1848.9227 -0.11783672 2.9725789e-05 8 + 1700 1981.1695 0.28374154 2.9725789e-05 8 + 1800 2330.8852 -0.082109894 3.2428133e-05 9 + 1900 2177.4096 0.23853778 3.2428133e-05 9 + 2000 2095.1618 -1.5405667 3.5130478e-05 10 + 2100 2272.2653 0.05572226 3.5130478e-05 10 + 2200 2599.5994 -2.2307507 3.7832822e-05 11 + 2300 2457.7904 0.40228312 3.7832822e-05 11 + 2400 2372.9736 -3.3415973 4.0535167e-05 12 + 2500 2427.4613 -0.16211888 4.0535167e-05 12 + 2600 3022.2608 -4.3278098 4.3237511e-05 13 + 2700 3115.6526 0.013828954 4.3237511e-05 13 + 2800 2841.7091 -6.4163443 4.5939855e-05 14 + 2900 3047.8436 0.16052429 4.5939855e-05 14 + 3000 3373.7997 -7.7904706 4.86422e-05 15 + 3100 3381.6653 0.35152687 4.86422e-05 15 + 3200 3589.5561 -10.754027 5.1344544e-05 16 + 3300 3473.4415 -0.13274479 5.1344544e-05 16 + 3400 3696.3283 -13.75504 5.4046889e-05 17 + 3500 3486.5442 -0.31091832 5.4046889e-05 17 + 3600 3647.0818 0.34662993 5.4046889e-05 17 + 3700 3636.7138 -0.041981737 5.4046889e-05 17 + 3800 3427.6532 0.42008936 5.6749233e-05 18 + 3900 3574.0094 -0.05475272 5.6749233e-05 18 + 4000 4158.9339 0.14426361 5.9451578e-05 19 + 4100 3862.5026 0.094232438 5.9451578e-05 19 + 4200 3969.4378 -0.10602108 6.2153922e-05 20 + 4300 3840.0126 0.29190336 6.2153922e-05 20 + 4400 4365.9912 -36.954812 6.4856266e-05 21 + 4500 4565.3708 0.061879092 6.4856266e-05 21 + 4600 4565.491 -70.588435 6.7558611e-05 22 + 4700 4570.2702 -0.56661378 6.7558611e-05 22 + 4800 4445.786 0.20534323 6.7558611e-05 22 + 4900 4782.6436 0.012783481 7.0260955e-05 23 + 5000 4777.2132 0.092416308 7.0260955e-05 23 + 5100 4944.0402 0.11614993 7.29633e-05 24 + 5200 5139.165 -0.23180938 7.29633e-05 24 + 5300 4647.2328 0.13570142 7.5665644e-05 25 + 5400 4982.7355 -0.25477884 7.5665644e-05 25 + 5500 5400.5924 0.19902824 7.8367989e-05 26 + 5600 5761.3552 0.083102065 7.8367989e-05 26 + 5700 5723.8581 0.039332796 8.1070333e-05 27 + 5800 5548.0789 -0.14511631 8.1070333e-05 27 + 5900 5358.5431 -0.099694264 8.3772677e-05 28 + 6000 5591.2678 9.9924655e-05 8.3772677e-05 28 + 6100 6101.8008 0.26538732 8.6475022e-05 29 + 6200 5848.9979 0.091137862 8.6475022e-05 29 + 6300 5582.1828 -0.039900602 8.9177366e-05 30 + 6400 6077.0548 0.3191104 8.9177366e-05 30 + 6500 5794.6827 0.69322336 8.9177366e-05 30 + 6600 5610.4331 0.080420058 8.9177366e-05 30 + 6700 5615.3492 0.12810868 8.9177366e-05 30 + 6800 5900.9749 -0.31704866 8.9177366e-05 30 + 6900 6233.9524 0.010288514 8.9177366e-05 30 + 7000 5972.7488 -1.0442089 8.9177366e-05 30 + 7100 6258.1332 0.56270399 8.9177366e-05 30 + 7200 6172.5919 -0.19595153 8.9177366e-05 30 + 7300 5898.7547 0.020862491 8.9177366e-05 30 + 7400 5815.1659 -0.0020680171 8.9177366e-05 30 + 7500 6003.867 -0.12288131 8.9177366e-05 30 + 7600 5966.0609 -0.1504333 8.9177366e-05 30 + 7700 6274.3331 -0.62752757 8.9177366e-05 30 + 7800 6051.0914 0.22821201 8.9177366e-05 30 + 7900 5981.5209 -0.19623554 8.9177366e-05 30 + 8000 5835.4657 0.3602475 8.9177366e-05 30 +Loop time of 13.936 on 4 procs for 8000 steps with 528 atoms + +Performance: 49.598 ns/day, 0.484 hours/ns, 574.051 timesteps/s, 303.099 katom-step/s +99.4% CPU use with 4 MPI tasks x no OpenMP threads + +MPI task timing breakdown: +Section | min time | avg time | max time |%varavg| %total +--------------------------------------------------------------- +Pair | 0.001058 | 0.78388 | 3.1317 | 153.1 | 5.62 +Bond | 0.0031874 | 2.0525 | 8.1984 | 247.7 | 14.73 +Neigh | 0.53495 | 0.53527 | 0.53551 | 0.0 | 3.84 +Comm | 0.01177 | 0.012451 | 0.013306 | 0.5 | 0.09 +Output | 1.3336 | 1.4735 | 1.7322 | 13.2 | 10.57 +Modify | 0.55142 | 9.0568 | 12.031 | 163.3 | 64.99 +Other | | 0.02159 | | | 0.15 + +Nlocal: 132 ave 528 max 0 min +Histogram: 3 0 0 0 0 0 0 0 0 1 +Nghost: 0 ave 0 max 0 min +Histogram: 4 0 0 0 0 0 0 0 0 0 +Neighs: 9115.75 ave 36463 max 0 min +Histogram: 3 0 0 0 0 0 0 0 0 1 + +Total # of neighbors = 36463 +Ave neighs/atom = 69.058712 +Ave special neighs/atom = 11.409091 +Neighbor list builds = 771 +Dangerous builds = 0 + +# write_data final.data nofix +Total wall time: 0:00:13 diff --git a/examples/PACKAGES/reaction/create_atoms_polystyrene/trimer.data b/examples/PACKAGES/reaction/create_atoms_polystyrene/trimer.data index b3ad132f03..2608a0ed10 100644 --- a/examples/PACKAGES/reaction/create_atoms_polystyrene/trimer.data +++ b/examples/PACKAGES/reaction/create_atoms_polystyrene/trimer.data @@ -1,796 +1,585 @@ polystyrene trimer -48 atoms -7 atom types -50 bonds -13 bond types -84 angles -22 angle types -127 dihedrals -36 dihedral types -36 impropers -9 improper types + 48 atoms + 50 bonds + 84 angles + 127 dihedrals + 20 impropers -50 250 xlo xhi -50 250 ylo yhi -50 250 zlo zhi + 4 atom types + 6 bond types + 10 angle types + 13 dihedral types + 4 improper types + + -200 200 xlo xhi + -200 200 ylo yhi + -200 200 zlo zhi + +Atom Type Labels + + 1 hc + 2 cp + 3 c1 + 4 c2 + +Bond Type Labels + + 1 hc-cp + 2 cp-cp + 3 hc-c2 + 4 c1-c2 + 5 cp-c1 + 6 hc-c1 + +Angle Type Labels + + 1 hc-cp-cp + 2 cp-cp-cp + 3 cp-c1-c2 + 4 hc-c1-c2 + 5 hc-c1-cp + 6 hc-c2-c1 + 7 hc-c2-hc + 8 c1-c2-c1 + 9 cp-cp-c1 + 10 c2-c1-c2 + +Dihedral Type Labels + + 1 hc-cp-cp-hc + 2 hc-cp-cp-cp + 3 cp-cp-cp-cp + 4 cp-cp-cp-c1 + 5 hc-cp-cp-c1 + 6 cp-c1-c2-hc + 7 cp-c1-c2-c1 + 8 hc-c1-c2-hc + 9 hc-c1-c2-c1 + 10 cp-cp-c1-c2 + 11 cp-cp-c1-hc + 12 c2-c1-c2-hc + 13 c2-c1-c2-c1 + +Improper Type Labels + + 1 hc-cp-cp-cp + 2 hc-c1-cp-c2 + 3 cp-cp-cp-c1 + 4 hc-c2-hc-c1 Masses -1 12.0112 -2 1.00797 -3 12.0112 -4 12.0112 -5 12.0112 -6 12.0112 -7 12.0112 + 1 1.007970 # hc + 2 12.011150 # cp + 3 12.011150 # c1 + 4 12.011150 # c2 Pair Coeffs # lj/class2/coul/long -1 0.064 4.01 -2 0.02 2.7 -3 0.064 4.01 -4 0.064 3.9 -5 0.054 4.01 -6 0.054 4.01 -7 0.054 4.01 + 1 0.0200000000 2.7000000000 + 2 0.0640000000 4.0100000000 + 3 0.0540000000 4.0100000000 + 4 0.0540000000 4.0100000000 Bond Coeffs # class2 -1 1.0982 372.825 -803.453 894.317 -2 1.417 470.836 -627.618 1327.63 -3 1.501 321.902 -521.821 572.163 -4 1.0883 365.768 -725.54 781.662 -5 1.34 543.99 -1238.2 1644.03 -6 1.0883 365.768 -725.54 781.662 -7 1.501 321.902 -521.821 572.163 -8 1.101 345 -691.89 844.6 -9 1.53 299.67 -501.77 679.81 -10 1.101 345 -691.89 844.6 -11 1.501 321.902 -521.821 572.163 -12 1.101 345 -691.89 844.6 -13 1.53 299.67 -501.77 679.81 + 1 1.0982 372.8251 -803.4526 894.3173 + 2 1.4170 470.8361 -627.6179 1327.6345 + 3 1.1010 345.0000 -691.8900 844.6000 + 4 1.5300 299.6700 -501.7700 679.8100 + 5 1.5010 321.9021 -521.8208 572.1628 + 6 1.1010 345.0000 -691.8900 844.6000 Angle Coeffs # class2 -1 117.94 35.1558 -12.4682 0 -2 118.9 61.0226 -34.9931 0 -3 120.05 44.7148 -22.7352 0 -4 111 44.3234 -9.4454 0 -5 108.4 43.9594 -8.3924 -9.3379 -6 124.88 35.2766 -17.774 -1.6215 -7 124.88 35.2766 -17.774 -1.6215 -8 115.49 29.6363 -12.4853 -6.2218 -9 120.05 44.7148 -22.7352 0 -10 111 44.3234 -9.4454 0 -11 108.4 43.9594 -8.3924 -9.3379 -12 110.77 41.453 -10.604 5.129 -13 112.67 39.516 -7.443 -9.5583 -14 110.77 41.453 -10.604 5.129 -15 107.66 39.641 -12.921 -2.4318 -16 112.67 39.516 -7.443 -9.5583 -17 120.05 44.7148 -22.7352 0 -18 111 44.3234 -9.4454 0 -19 108.4 43.9594 -8.3924 -9.3379 -20 110.77 41.453 -10.604 5.129 -21 110.77 41.453 -10.604 5.129 -22 112.67 39.516 -7.443 -9.5583 - -BondBond Coeffs - -1 1.0795 1.417 1.0982 -2 68.2856 1.417 1.417 -3 12.0676 1.417 1.501 -4 2.9168 1.501 1.0883 -5 0 1.501 1.34 -6 10.1047 1.0883 1.34 -7 10.1047 1.0883 1.34 -8 4.8506 1.0883 1.0883 -9 12.0676 1.417 1.501 -10 2.9168 1.501 1.101 -11 0 1.501 1.53 -12 3.3872 1.101 1.53 -13 0 1.53 1.53 -14 3.3872 1.101 1.53 -15 5.3316 1.101 1.101 -16 0 1.53 1.53 -17 12.0676 1.417 1.501 -18 2.9168 1.501 1.101 -19 0 1.501 1.53 -20 3.3872 1.101 1.53 -21 3.3872 1.101 1.53 -22 0 1.53 1.53 - -BondAngle Coeffs - -1 20.0033 24.2183 1.417 1.0982 -2 28.8708 28.8708 1.417 1.417 -3 31.0771 47.0579 1.417 1.501 -4 26.4608 11.7717 1.501 1.0883 -5 0 0 1.501 1.34 -6 19.0592 23.3588 1.0883 1.34 -7 19.0592 23.3588 1.0883 1.34 -8 17.9795 17.9795 1.0883 1.0883 -9 31.0771 47.0579 1.417 1.501 -10 26.4608 11.7717 1.501 1.101 -11 0 0 1.501 1.53 -12 11.421 20.754 1.101 1.53 -13 8.016 8.016 1.53 1.53 -14 11.421 20.754 1.101 1.53 -15 18.103 18.103 1.101 1.101 -16 8.016 8.016 1.53 1.53 -17 31.0771 47.0579 1.417 1.501 -18 26.4608 11.7717 1.501 1.101 -19 0 0 1.501 1.53 -20 11.421 20.754 1.101 1.53 -21 11.421 20.754 1.101 1.53 -22 8.016 8.016 1.53 1.53 + 1 117.9400 35.1558 -12.4682 0.0000 + 2 118.9000 61.0226 -34.9931 0.0000 + 3 108.4000 43.9594 -8.3924 -9.3379 + 4 110.7700 41.4530 -10.6040 5.1290 + 5 111.0000 44.3234 -9.4454 0.0000 + 6 110.7700 41.4530 -10.6040 5.1290 + 7 107.6600 39.6410 -12.9210 -2.4318 + 8 112.6700 39.5160 -7.4430 -9.5583 + 9 120.0500 44.7148 -22.7352 0.0000 + 10 112.6700 39.5160 -7.4430 -9.5583 Dihedral Coeffs # class2 -1 0 0 1.559 0 0 0 -2 0 0 3.9661 0 0 0 -3 0 0 4.4072 0 0 0 -4 8.3667 0 1.1932 0 0 0 -5 0 0 1.8769 0 0 0 -6 0 0 0 0 0 0 -7 0 0 0 0 0 0 -8 0 0 0 0 0 0 -9 0 0 4.8974 0 0 0 -10 0 0 1.559 0 0 0 -11 0 0 4.4072 0 0 0 -12 -0.2801 0 -0.0678 0 -0.0122 0 -13 -0.2802 0 -0.0678 0 -0.0122 0 -14 -0.0228 0 0.028 0 -0.1863 0 -15 -0.1432 0 0.0617 0 -0.1083 0 -16 0 0 0.0316 0 -0.1681 0 -17 0 0 0 0 0 0 -18 0 0 0.0316 0 -0.1681 0 -19 0 0 0.0514 0 -0.143 0 -20 0 0 1.559 0 0 0 -21 0 0 4.4072 0 0 0 -22 -0.2801 0 -0.0678 0 -0.0122 0 -23 -0.2802 0 -0.0678 0 -0.0122 0 -24 -0.0228 0 0.028 0 -0.1863 0 -25 0 0 0 0 0 0 -26 -0.1432 0 0.0617 0 -0.1083 0 -27 0 0 0.0316 0 -0.1681 0 -28 0 0 0 0 0 0 -29 0 0 0.0316 0 -0.1681 0 -30 0 0 0.0514 0 -0.143 0 -31 -0.0228 0 0.028 0 -0.1863 0 -32 -0.1432 0 0.0617 0 -0.1083 0 -33 0 0 0.0316 0 -0.1681 0 -34 0 0 0 0 0 0 -35 0 0 0.0316 0 -0.1681 0 -36 0 0 0.0514 0 -0.143 0 - -AngleAngleTorsion Coeffs - -1 4.4444 117.94 120.05 -2 -4.8141 118.9 117.94 -3 -14.4097 118.9 120.05 -4 0 118.9 118.9 -5 0.3598 117.94 117.94 -6 0 120.05 111 -7 0 120.05 108.4 -8 0 108.4 124.88 -9 -7.0058 124.88 124.88 -10 4.4444 117.94 120.05 -11 -14.4097 118.9 120.05 -12 -5.8888 120.05 111 -13 0 120.05 108.4 -14 0 108.4 110.77 -15 -12.564 110.77 110.77 -16 -16.164 112.67 110.77 -17 0 108.4 112.67 -18 -16.164 110.77 112.67 -19 -22.045 112.67 112.67 -20 4.4444 117.94 120.05 -21 -14.4097 118.9 120.05 -22 -5.8888 120.05 111 -23 0 120.05 108.4 -24 0 108.4 110.77 -25 0 108.4 112.67 -26 -12.564 110.77 110.77 -27 -16.164 110.77 112.67 -28 0 112.67 108.4 -29 -16.164 112.67 110.77 -30 -22.045 112.67 112.67 -31 0 110.77 108.4 -32 -12.564 110.77 110.77 -33 -16.164 110.77 112.67 -34 0 112.67 108.4 -35 -16.164 112.67 110.77 -36 -22.045 112.67 112.67 - -EndBondTorsion Coeffs - -1 0 -0.4879 0 0 -1.797 0 1.0982 1.501 -2 0 -6.8958 0 0 -0.4669 0 1.417 1.0982 -3 0 -0.6918 0 0 0.2421 0 1.417 1.501 -4 -0.1185 6.3204 0 -0.1185 6.3204 0 1.417 1.417 -5 0 -0.689 0 0 -0.689 0 1.0982 1.0982 -6 0 0 0 0 0 0 1.417 1.0883 -7 0 0 0 0 0 0 1.417 1.34 -8 0 0 0 0 0 0 1.501 1.0883 -9 0.7129 0.5161 0 0.7129 0.5161 0 1.0883 1.0883 -10 0 -0.4879 0 0 -1.797 0 1.0982 1.501 -11 0 -0.6918 0 0 0.2421 0 1.417 1.501 -12 -0.5835 1.122 0.3978 1.3997 0.7756 0 1.417 1.101 -13 0 0 0 0 0 0 1.417 1.53 -14 0 0 0 0 0 0 1.501 1.101 -15 0.213 0.312 0.0777 0.213 0.312 0.0777 1.101 1.101 -16 0.2486 0.2422 -0.0925 0.0814 0.0591 0.2219 1.53 1.101 -17 0 0 0 0 0 0 1.501 1.53 -18 0.0814 0.0591 0.2219 0.2486 0.2422 -0.0925 1.101 1.53 -19 -0.0732 0 0 -0.0732 0 0 1.53 1.53 -20 0 -0.4879 0 0 -1.797 0 1.0982 1.501 -21 0 -0.6918 0 0 0.2421 0 1.417 1.501 -22 -0.5835 1.122 0.3978 1.3997 0.7756 0 1.417 1.101 -23 0 0 0 0 0 0 1.417 1.53 -24 0 0 0 0 0 0 1.501 1.101 -25 0 0 0 0 0 0 1.501 1.53 -26 0.213 0.312 0.0777 0.213 0.312 0.0777 1.101 1.101 -27 0.0814 0.0591 0.2219 0.2486 0.2422 -0.0925 1.101 1.53 -28 0 0 0 0 0 0 1.53 1.501 -29 0.2486 0.2422 -0.0925 0.0814 0.0591 0.2219 1.53 1.101 -30 -0.0732 0 0 -0.0732 0 0 1.53 1.53 -31 0 0 0 0 0 0 1.101 1.501 -32 0.213 0.312 0.0777 0.213 0.312 0.0777 1.101 1.101 -33 0.0814 0.0591 0.2219 0.2486 0.2422 -0.0925 1.101 1.53 -34 0 0 0 0 0 0 1.53 1.501 -35 0.2486 0.2422 -0.0925 0.0814 0.0591 0.2219 1.53 1.101 -36 -0.0732 0 0 -0.0732 0 0 1.53 1.53 - -MiddleBondTorsion Coeffs - -1 0 3.9421 0 1.417 -2 0 -1.1521 0 1.417 -3 0 9.1792 0 1.417 -4 27.5989 -2.312 0 1.417 -5 0 4.8228 0 1.417 -6 0 0 0 1.501 -7 0 0 0 1.501 -8 0 0 0 1.34 -9 0.8558 6.3911 0 1.34 -10 0 3.9421 0 1.417 -11 0 9.1792 0 1.417 -12 -5.5679 1.4083 0.301 1.501 -13 0 0 0 1.501 -14 0 0 0 1.53 -15 -14.261 -0.5322 -0.4864 1.53 -16 -14.879 -3.6581 -0.3138 1.53 -17 0 0 0 1.53 -18 -14.879 -3.6581 -0.3138 1.53 -19 -17.787 -7.1877 0 1.53 -20 0 3.9421 0 1.417 -21 0 9.1792 0 1.417 -22 -5.5679 1.4083 0.301 1.501 -23 0 0 0 1.501 -24 0 0 0 1.53 -25 0 0 0 1.53 -26 -14.261 -0.5322 -0.4864 1.53 -27 -14.879 -3.6581 -0.3138 1.53 -28 0 0 0 1.53 -29 -14.879 -3.6581 -0.3138 1.53 -30 -17.787 -7.1877 0 1.53 -31 0 0 0 1.53 -32 -14.261 -0.5322 -0.4864 1.53 -33 -14.879 -3.6581 -0.3138 1.53 -34 0 0 0 1.53 -35 -14.879 -3.6581 -0.3138 1.53 -36 -17.787 -7.1877 0 1.53 - -BondBond13 Coeffs - -1 0.8743 1.0982 1.501 -2 -6.2741 1.417 1.0982 -3 2.5085 1.417 1.501 -4 53 1.417 1.417 -5 -1.7077 1.0982 1.0982 -6 0 1.417 1.0883 -7 0 1.417 1.34 -8 0 1.501 1.0883 -9 0 1.0883 1.0883 -10 0.8743 1.0982 1.501 -11 2.5085 1.417 1.501 -12 -3.4826 1.417 1.101 -13 0 1.417 1.53 -14 0 1.501 1.101 -15 0 1.101 1.101 -16 0 1.53 1.101 -17 0 1.501 1.53 -18 0 1.101 1.53 -19 0 1.53 1.53 -20 0.8743 1.0982 1.501 -21 2.5085 1.417 1.501 -22 -3.4826 1.417 1.101 -23 0 1.417 1.53 -24 0 1.501 1.101 -25 0 1.501 1.53 -26 0 1.101 1.101 -27 0 1.101 1.53 -28 0 1.53 1.501 -29 0 1.53 1.101 -30 0 1.53 1.53 -31 0 1.101 1.501 -32 0 1.101 1.101 -33 0 1.101 1.53 -34 0 1.53 1.501 -35 0 1.53 1.101 -36 0 1.53 1.53 - -AngleTorsion Coeffs - -1 0 3.4601 0 0 -0.1242 0 117.94 120.05 -2 0 2.5014 0 0 2.7147 0 118.9 117.94 -3 0 3.8987 0 0 -4.4683 0 118.9 120.05 -4 1.9767 1.0239 0 1.9767 1.0239 0 118.9 118.9 -5 0 2.4501 0 0 2.4501 0 117.94 117.94 -6 0 0 0 0 0 0 120.05 111 -7 0 0 0 0 0 0 120.05 108.4 -8 0 0 0 0 0 0 108.4 124.88 -9 -1.8911 3.254 0 -1.8911 3.254 0 124.88 124.88 -10 0 3.4601 0 0 -0.1242 0 117.94 120.05 -11 0 3.8987 0 0 -4.4683 0 118.9 120.05 -12 0.2251 0.6548 0.1237 4.6266 0.1632 0.0461 120.05 111 -13 0 0 0 0 0 0 120.05 108.4 -14 0 0 0 0 0 0 108.4 110.77 -15 -0.8085 0.5569 -0.2466 -0.8085 0.5569 -0.2466 110.77 110.77 -16 -0.2454 0 -0.1136 0.3113 0.4516 -0.1988 112.67 110.77 -17 0 0 0 0 0 0 108.4 112.67 -18 0.3113 0.4516 -0.1988 -0.2454 0 -0.1136 110.77 112.67 -19 0.3886 -0.3139 0.1389 0.3886 -0.3139 0.1389 112.67 112.67 -20 0 3.4601 0 0 -0.1242 0 117.94 120.05 -21 0 3.8987 0 0 -4.4683 0 118.9 120.05 -22 0.2251 0.6548 0.1237 4.6266 0.1632 0.0461 120.05 111 -23 0 0 0 0 0 0 120.05 108.4 -24 0 0 0 0 0 0 108.4 110.77 -25 0 0 0 0 0 0 108.4 112.67 -26 -0.8085 0.5569 -0.2466 -0.8085 0.5569 -0.2466 110.77 110.77 -27 0.3113 0.4516 -0.1988 -0.2454 0 -0.1136 110.77 112.67 -28 0 0 0 0 0 0 112.67 108.4 -29 -0.2454 0 -0.1136 0.3113 0.4516 -0.1988 112.67 110.77 -30 0.3886 -0.3139 0.1389 0.3886 -0.3139 0.1389 112.67 112.67 -31 0 0 0 0 0 0 110.77 108.4 -32 -0.8085 0.5569 -0.2466 -0.8085 0.5569 -0.2466 110.77 110.77 -33 0.3113 0.4516 -0.1988 -0.2454 0 -0.1136 110.77 112.67 -34 0 0 0 0 0 0 112.67 108.4 -35 -0.2454 0 -0.1136 0.3113 0.4516 -0.1988 112.67 110.77 -36 0.3886 -0.3139 0.1389 0.3886 -0.3139 0.1389 112.67 112.67 + 1 0.0000 0.0000 1.8769 0.0000 0.0000 0.0000 + 2 0.0000 0.0000 3.9661 0.0000 0.0000 0.0000 + 3 8.3667 0.0000 1.1932 0.0000 0.0000 0.0000 + 4 0.0000 0.0000 4.4072 0.0000 0.0000 0.0000 + 5 0.0000 0.0000 1.5590 0.0000 0.0000 0.0000 + 6 -0.0228 0.0000 0.0280 0.0000 -0.1863 0.0000 + 7 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 + 8 -0.1432 0.0000 0.0617 0.0000 -0.1083 0.0000 + 9 0.0000 0.0000 0.0316 0.0000 -0.1681 0.0000 + 10 -0.2802 0.0000 -0.0678 0.0000 -0.0122 0.0000 + 11 -0.2801 0.0000 -0.0678 0.0000 -0.0122 0.0000 + 12 0.0000 0.0000 0.0316 0.0000 -0.1681 0.0000 + 13 0.0000 0.0000 0.0514 0.0000 -0.1430 0.0000 Improper Coeffs # class2 -1 4.8912 0 -2 7.8153 0 -3 0 0 -4 2.8561 0 -5 7.8153 0 -6 0 0 -7 0 0 -8 7.8153 0 -9 0 0 + 1 4.8912 0.0000 + 2 0.0000 0.0000 + 3 7.8153 0.0000 + 4 0.0000 0.0000 + +BondBond Coeffs + + 1 1.0795 1.0982 1.4170 + 2 68.2856 1.4170 1.4170 + 3 0.0000 1.5010 1.5300 + 4 3.3872 1.1010 1.5300 + 5 2.9168 1.1010 1.5010 + 6 3.3872 1.1010 1.5300 + 7 5.3316 1.1010 1.1010 + 8 0.0000 1.5300 1.5300 + 9 12.0676 1.4170 1.5010 + 10 0.0000 1.5300 1.5300 + +BondAngle Coeffs + + 1 24.2183 20.0033 1.0982 1.4170 + 2 28.8708 28.8708 1.4170 1.4170 + 3 0.0000 0.0000 1.5010 1.5300 + 4 11.4210 20.7540 1.1010 1.5300 + 5 11.7717 26.4608 1.1010 1.5010 + 6 11.4210 20.7540 1.1010 1.5300 + 7 18.1030 18.1030 1.1010 1.1010 + 8 8.0160 8.0160 1.5300 1.5300 + 9 31.0771 47.0579 1.4170 1.5010 + 10 8.0160 8.0160 1.5300 1.5300 AngleAngle Coeffs -1 0 0 0 118.9 117.94 117.94 -2 0 0 0 118.9 120.05 120.05 -3 0 0 0 111 124.88 108.4 -4 0 0 0 115.49 124.88 124.88 -5 0 0 0 118.9 120.05 120.05 -6 0 0 0 107.66 110.77 110.77 -7 0 0 0 111 110.77 108.4 -8 0 0 0 118.9 120.05 120.05 -9 0 0 0 111 110.77 108.4 + 1 0.0000 0.0000 0.0000 117.9400 118.9000 117.9400 + 2 0.0000 0.0000 0.0000 111.0000 108.4000 110.7700 + 3 0.0000 0.0000 0.0000 118.9000 120.0500 120.0500 + 4 0.0000 0.0000 0.0000 107.6600 110.7700 110.7700 + +AngleAngleTorsion Coeffs + + 1 0.3598 117.9400 117.9400 + 2 -4.8141 117.9400 118.9000 + 3 0.0000 118.9000 118.9000 + 4 -14.4097 118.9000 120.0500 + 5 4.4444 117.9400 120.0500 + 6 0.0000 108.4000 110.7700 + 7 0.0000 108.4000 112.6700 + 8 -12.5640 110.7700 110.7700 + 9 -16.1640 110.7700 112.6700 + 10 0.0000 120.0500 108.4000 + 11 -5.8888 120.0500 111.0000 + 12 -16.1640 112.6700 110.7700 + 13 -22.0450 112.6700 112.6700 + +EndBondTorsion Coeffs + +1 0.0000 -0.6890 0.0000 0.0000 -0.6890 0.0000 1.0982 1.0982 +2 0.0000 -0.4669 0.0000 0.0000 -6.8958 0.0000 1.0982 1.4170 +3 -0.1185 6.3204 0.0000 -0.1185 6.3204 0.0000 1.4170 1.4170 +4 0.0000 -0.6918 0.0000 0.0000 0.2421 0.0000 1.4170 1.5010 +5 0.0000 -0.4879 0.0000 0.0000 -1.7970 0.0000 1.0982 1.5010 +6 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.5010 1.1010 +7 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.5010 1.5300 +8 0.2130 0.3120 0.0777 0.2130 0.3120 0.0777 1.1010 1.1010 +9 0.0814 0.0591 0.2219 0.2486 0.2422 -0.0925 1.1010 1.5300 +10 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.4170 1.5300 +11 -0.5835 1.1220 0.3978 1.3997 0.7756 0.0000 1.4170 1.1010 +12 0.2486 0.2422 -0.0925 0.0814 0.0591 0.2219 1.5300 1.1010 +13 -0.0732 0.0000 0.0000 -0.0732 0.0000 0.0000 1.5300 1.5300 + +MiddleBondTorsion Coeffs + + 1 0.0000 4.8228 0.0000 1.4170 + 2 0.0000 -1.1521 0.0000 1.4170 + 3 27.5989 -2.3120 0.0000 1.4170 + 4 0.0000 9.1792 0.0000 1.4170 + 5 0.0000 3.9421 0.0000 1.4170 + 6 0.0000 0.0000 0.0000 1.5300 + 7 0.0000 0.0000 0.0000 1.5300 + 8 -14.2610 -0.5322 -0.4864 1.5300 + 9 -14.8790 -3.6581 -0.3138 1.5300 + 10 0.0000 0.0000 0.0000 1.5010 + 11 -5.5679 1.4083 0.3010 1.5010 + 12 -14.8790 -3.6581 -0.3138 1.5300 + 13 -17.7870 -7.1877 0.0000 1.5300 + +BondBond13 Coeffs + + 1 -1.7077 1.0982 1.0982 + 2 -6.2741 1.0982 1.4170 + 3 53.0000 1.4170 1.4170 + 4 2.5085 1.4170 1.5010 + 5 0.8743 1.0982 1.5010 + 6 0.0000 1.5010 1.1010 + 7 0.0000 1.5010 1.5300 + 8 0.0000 1.1010 1.1010 + 9 0.0000 1.1010 1.5300 + 10 0.0000 1.4170 1.5300 + 11 -3.4826 1.4170 1.1010 + 12 0.0000 1.5300 1.1010 + 13 0.0000 1.5300 1.5300 + +AngleTorsion Coeffs + + 1 0.0000 2.4501 0.0000 0.0000 2.4501 0.0000 117.9400 117.9400 + 2 0.0000 2.7147 0.0000 0.0000 2.5014 0.0000 117.9400 118.9000 + 3 1.9767 1.0239 0.0000 1.9767 1.0239 0.0000 118.9000 118.9000 + 4 0.0000 3.8987 0.0000 0.0000 -4.4683 0.0000 118.9000 120.0500 + 5 0.0000 3.4601 0.0000 0.0000 -0.1242 0.0000 117.9400 120.0500 + 6 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 108.4000 110.7700 + 7 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 108.4000 112.6700 + 8 -0.8085 0.5569 -0.2466 -0.8085 0.5569 -0.2466 110.7700 110.7700 + 9 0.3113 0.4516 -0.1988 -0.2454 0.0000 -0.1136 110.7700 112.6700 + 10 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 120.0500 108.4000 + 11 0.2251 0.6548 0.1237 4.6266 0.1632 0.0461 120.0500 111.0000 + 12 -0.2454 0.0000 -0.1136 0.3113 0.4516 -0.1988 112.6700 110.7700 + 13 0.3886 -0.3139 0.1389 0.3886 -0.3139 0.1389 112.6700 112.6700 Atoms # full -44 1 2 3.5400000000000001e-02 6.1476397222913839e+01 8.2376490601205234e+01 6.0906939115836181e+01 -45 1276 2 3.5400000000000001e-02 5.8398688202244472e+01 8.0172948526664996e+01 6.2115536813582672e+01 -46 1276 6 -6.9599999999999995e-02 5.9489073989392523e+01 8.0264057167571636e+01 6.1984002598976552e+01 -48 1276 2 3.5400000000000001e-02 5.9675170230342431e+01 8.0048052449390738e+01 6.0920159395372401e+01 -47 1276 2 1.2370000000000000e-01 5.9297455513100488e+01 8.3187777608476154e+01 5.9645157256520122e+01 -18 1 5 -1.8200000000000001e-02 6.2426251430535707e+01 8.2055473568260709e+01 6.2971661388612958e+01 -19 1 6 -6.9599999999999995e-02 6.1399255844467369e+01 8.1794665295860213e+01 6.1821819828185660e+01 -21 1 1 -1.2900000000000000e-01 6.4032918371445831e+01 8.0190179089286701e+01 6.3021564712316334e+01 -22 1 1 2.6599999999999999e-02 6.3672975135915053e+01 8.1418558650051665e+01 6.2448012627881994e+01 -23 1 2 3.5400000000000001e-02 6.1545198223694939e+01 8.0836309422842305e+01 6.1349823957467130e+01 -27 1276 2 5.1600000000000000e-02 5.9809503696580933e+01 8.1831265916389881e+01 6.3253745193271065e+01 -28 1276 5 -1.8200000000000001e-02 5.9900307947967441e+01 8.1677453781363639e+01 6.2190757403657820e+01 -31 1276 2 1.2370000000000000e-01 5.8050043823867973e+01 8.2698312265456622e+01 6.3667111329534436e+01 -38 1 2 1.2370000000000000e-01 6.3754126973935612e+01 7.9931147303963002e+01 6.4022259163067275e+01 -20 1 2 1.2370000000000000e-01 6.4070158368422781e+01 8.2950071388392274e+01 6.1042631212883315e+01 -24 1 1 -1.2900000000000000e-01 6.4337973861569580e+01 8.1916618276489871e+01 6.1387866780102470e+01 -37 1 2 1.4030000000000001e-01 6.5360115866618415e+01 7.8586112104863830e+01 6.3004997314380716e+01 -39 1 1 -1.7340000000000000e-01 6.5018338085325610e+01 7.9478260591306125e+01 6.2440745569712817e+01 -40 1 1 -1.1340000000000000e-01 6.5628759887796605e+01 7.9941156332165264e+01 6.1248476296558067e+01 -41 1 1 -1.7340000000000000e-01 6.5247995680260402e+01 8.1172439250598345e+01 6.0753045571239831e+01 -42 1 2 1.2880000000000000e-01 6.6569600059599281e+01 7.9514748976494360e+01 6.0810611807135601e+01 -43 1 2 1.4030000000000001e-01 6.5780165393063371e+01 8.1570974991007958e+01 5.9850915261812396e+01 -9 1276 2 1.2880000000000000e-01 5.5651795605743445e+01 8.5074472139235127e+01 6.1094480497979262e+01 -30 1276 2 1.4030000000000001e-01 5.6082982679196888e+01 8.3912863624076010e+01 6.3351889697403472e+01 -33 1276 1 -1.7340000000000000e-01 5.6718133911388506e+01 8.3758479063002000e+01 6.2493293749545209e+01 -34 1276 1 -1.1340000000000000e-01 5.6498352105218459e+01 8.4426576393179090e+01 6.1290147608586011e+01 -6 3822 1 -1.7340000000000000e-01 6.3308103537340351e+01 8.7713509787622499e+01 6.4643082313868433e+01 -7 3822 1 -1.2900000000000000e-01 6.3010291684764312e+01 8.6423650045069493e+01 6.4252844241495922e+01 -8 3822 2 1.2370000000000000e-01 6.2089199187020355e+01 8.6309198636296912e+01 6.3711263099850854e+01 -10 1276 2 1.4030000000000001e-01 5.7266131308654970e+01 8.4599328362003035e+01 5.9281511478144402e+01 -11 3822 2 3.5400000000000001e-02 6.1694306618059791e+01 8.3823470438280594e+01 6.3778953909925114e+01 -12 3822 5 -1.8200000000000001e-02 6.3814926998838651e+01 8.3900077798460728e+01 6.4108991789590448e+01 -13 3822 6 -6.9599999999999995e-02 6.2604540882379787e+01 8.3491998603381077e+01 6.3249610918984622e+01 -14 3822 2 1.2370000000000000e-01 6.5739253131027880e+01 8.4813736128157771e+01 6.5351692111169555e+01 -15 3822 1 -1.2900000000000000e-01 6.5071144269009466e+01 8.5646783550482454e+01 6.5086813218945636e+01 -16 3822 1 2.6599999999999999e-02 6.3957099792282079e+01 8.5375816595044753e+01 6.4385073943729708e+01 -17 1 2 5.1600000000000000e-02 6.2256484483973310e+01 8.1576962161157596e+01 6.3963984654065122e+01 -26 3822 2 5.1600000000000000e-02 6.4196825763126355e+01 8.3291442832977836e+01 6.4907094488854057e+01 -29 1276 1 2.6599999999999999e-02 5.8784742332505303e+01 8.2766055380197670e+01 6.1667239692876961e+01 -32 1276 1 -1.2900000000000000e-01 5.7836199787435064e+01 8.3005060229118428e+01 6.2669788306756018e+01 -35 1276 1 -1.2900000000000000e-01 5.8572661840325132e+01 8.3404075689965083e+01 6.0443288532625175e+01 -36 1276 1 -1.7340000000000000e-01 5.7380616699226330e+01 8.4134680429976896e+01 6.0248710539932475e+01 -25 3822 2 3.5400000000000001e-02 6.2750675036816460e+01 8.3891633300878468e+01 6.2249429178485677e+01 -5 3822 2 1.4030000000000001e-01 6.2626160082050376e+01 8.8416565740835182e+01 6.4093918967496805e+01 -1 3822 2 1.2880000000000000e-01 6.4863557606529355e+01 8.9096029197548390e+01 6.5342927535537825e+01 -2 3822 1 -1.1340000000000000e-01 6.4627442641031166e+01 8.8047381925321190e+01 6.5138073202291650e+01 -3 3822 2 1.4030000000000001e-01 6.6470254992065406e+01 8.6991893750821745e+01 6.5857474890608984e+01 -4 3822 1 -1.7340000000000000e-01 6.5416488888088338e+01 8.6963894801200169e+01 6.5357641085394278e+01 - -Velocities - -44 -1.1274099342391698e-02 2.8614364731871914e-02 7.8116535486555949e-03 -45 2.3164382404151666e-03 3.9815732957733160e-03 -2.9971878581527899e-02 -46 -7.1653099619954563e-03 4.5491360587300133e-04 4.9898614093692017e-03 -48 9.8069086061434527e-03 4.0008139512159270e-03 6.2934259772882122e-03 -47 2.2646445306743783e-03 1.3029071608409702e-03 4.2232440120174040e-02 -18 7.0040064100195757e-03 3.2877451206009701e-03 -3.5376010407568422e-04 -19 -1.3998188760009689e-02 7.2238210565990146e-03 7.7956220633332383e-03 -21 3.1954292320462373e-03 -2.9717583309420764e-03 -3.1753395094325522e-03 -22 5.2997643939121201e-03 -2.9646963088534335e-03 -4.1351926198204894e-03 -23 7.6443400078766528e-03 4.0358953976530103e-02 -2.6684706183248367e-02 -27 1.9261652416455359e-03 -1.1632914130150688e-02 1.0061732021630769e-02 -28 -8.2251676802878315e-03 -1.5111873066969876e-04 1.3808893565582731e-02 -31 5.2475840572179860e-03 1.8266996572138715e-02 2.3453280610166885e-03 -38 -2.0343905130199073e-02 3.2815536859276281e-02 3.6511922534330152e-03 -20 2.2914549087537126e-02 1.4424503744223915e-02 2.1708279654645496e-03 -24 -2.4717233344142471e-03 1.2966123098719246e-02 8.1261459853411936e-03 -37 -2.4547379584186218e-02 -3.0213966592845171e-02 -3.1437442951939183e-02 -39 2.5476117829076835e-03 1.2743160680987653e-03 1.8775880208113892e-03 -40 -6.9216508143939990e-03 1.0986173624795060e-02 8.4543093049661480e-03 -41 -6.9641432145561661e-03 3.4497795547843439e-03 -6.5914679936187716e-03 -42 -1.6682931637687005e-02 -7.9952140358728052e-03 -5.4993265930488526e-02 -43 -1.2747392921213267e-03 -8.9033092043203244e-03 -1.4285400545629027e-02 -9 -4.6235166357676289e-03 -1.3071850427027999e-02 -1.4097407987100977e-02 -30 -1.0949617396609294e-02 2.8255703113196974e-03 1.7171748232322353e-02 -33 -6.1375812469323665e-03 -2.4748644899411924e-03 -9.4761978149296138e-03 -34 1.3676079846441525e-03 5.6076140293943458e-03 4.3217204641336267e-03 -6 -1.0264635053701928e-02 6.5278337056107680e-03 7.0056151148588212e-04 -7 -8.7519451205145676e-03 -4.6476440106580945e-03 2.5970484253527112e-03 -8 2.1377395557690311e-02 -3.3261274153819453e-03 -1.0112266596677577e-02 -10 -3.5793767912309253e-02 -4.7139872292323019e-02 -1.6709528481405608e-02 -11 8.5071485795589590e-03 9.9402848610678270e-03 -3.8088596341056854e-03 -12 -7.1678159384257103e-04 -6.9164463557228907e-04 -6.4073519808107186e-03 -13 -4.8443902657902991e-03 -1.1919190682985097e-03 6.3946846087726637e-03 -14 1.4810157483257907e-02 1.9829623839419017e-03 -2.7393844990063056e-02 -15 2.4171850935506777e-03 8.5003135180758520e-03 -1.4373227798951704e-03 -16 2.7567342910947553e-03 4.7168484476890456e-03 -5.5131873288712992e-03 -17 -3.8456662730386774e-02 2.0220106671151108e-02 -1.3822049134399602e-02 -26 2.7415414728694614e-02 1.4392155257037418e-03 -6.7281635499082748e-03 -29 2.8284983560440745e-03 2.8809942505517976e-03 -9.0489583066552114e-04 -32 -3.8543634697614316e-03 4.6751647301899795e-03 4.2171867397204537e-03 -35 -8.6957974827209118e-03 -4.4615282666186267e-04 -2.6571026120482824e-03 -36 9.4881057996863086e-04 -7.5665878069688429e-03 2.0333670960646154e-03 -25 1.8105924111310519e-02 -8.6933495274689535e-03 -1.9695291360338044e-04 -5 -5.0447438383189585e-03 -4.5665146331657552e-02 1.0653751333175230e-02 -1 -1.7372868398038824e-02 -2.3625357536259349e-03 1.2220266128368908e-02 -2 3.7050246021929395e-03 -1.0236943515935205e-03 7.2206774682170580e-03 -3 2.3669435799326944e-02 2.7891427939155597e-02 -6.7091036888174346e-03 -4 3.4910623999263577e-03 2.6370880132825258e-03 -6.4694788112864129e-03 + 1 3 1 0.128800 64.863555908 89.096031189 65.342926025 0 0 0 # hc + 2 3 2 -0.113400 64.627441406 88.047378540 65.138076782 0 0 0 # cp + 3 3 1 0.140300 66.470252991 86.991889954 65.857475281 0 0 0 # hc + 4 3 2 -0.173400 65.416488647 86.963897705 65.357643127 0 0 0 # cp + 5 3 1 0.140300 62.626159668 88.416564941 64.093917847 0 0 0 # hc + 6 3 2 -0.173400 63.308101654 87.713508606 64.643081665 0 0 0 # cp + 7 3 2 -0.129000 63.010292053 86.423652649 64.252845764 0 0 0 # cp + 8 3 1 0.123700 62.089199066 86.309196472 63.711261749 0 0 0 # hc + 9 2 1 0.128800 55.651794434 85.074470520 61.094478607 0 0 0 # hc + 10 2 1 0.140300 57.266132355 84.599327087 59.281513214 0 0 0 # hc + 11 3 1 0.035400 61.694305420 83.823471069 63.778953552 0 0 0 # hc + 12 3 3 -0.018200 63.814926147 83.900077820 64.108993530 0 0 0 # c1 + 13 3 4 -0.069600 62.604541779 83.491996765 63.249610901 0 0 0 # c2 + 14 3 1 0.123700 65.739250183 84.813735962 65.351692200 0 0 0 # hc + 15 3 2 -0.129000 65.071144104 85.646781921 65.086814880 0 0 0 # cp + 16 3 2 0.026600 63.957099915 85.375816345 64.385070801 0 0 0 # cp + 17 1 1 0.051600 62.256484985 81.576965332 63.963985443 0 0 0 # hc + 18 1 3 -0.018200 62.426250458 82.055473328 62.971660614 0 0 0 # c1 + 19 1 4 -0.069600 61.399257660 81.794662476 61.821819305 0 0 0 # c2 + 20 1 1 0.123700 64.070159912 82.950073242 61.042633057 0 0 0 # hc + 21 1 2 -0.129000 64.032920837 80.190177917 63.021564484 0 0 0 # cp + 22 1 2 0.026600 63.672973633 81.418556213 62.448013306 0 0 0 # cp + 23 1 1 0.035400 61.545196533 80.836311340 61.349822998 0 0 0 # hc + 24 1 2 -0.129000 64.337974548 81.916618347 61.387866974 0 0 0 # cp + 25 3 1 0.035400 62.750675201 83.891632080 62.249427795 0 0 0 # hc + 26 3 1 0.051600 64.196823120 83.291442871 64.907096863 0 0 0 # hc + 27 2 1 0.051600 59.809505463 81.831268311 63.253746033 0 0 0 # hc + 28 2 3 -0.018200 59.900306702 81.677452087 62.190757751 0 0 0 # c1 + 29 2 2 0.026600 58.784740448 82.766052246 61.667240143 0 0 0 # cp + 30 2 1 0.140300 56.082981110 83.912864685 63.351890564 0 0 0 # hc + 31 2 1 0.123700 58.050045013 82.698310852 63.667110443 0 0 0 # hc + 32 2 2 -0.129000 57.836200714 83.005058289 62.669788361 0 0 0 # cp + 33 2 2 -0.173400 56.718132019 83.758476257 62.493293762 0 0 0 # cp + 34 2 2 -0.113400 56.498352051 84.426574707 61.290145874 0 0 0 # cp + 35 2 2 -0.129000 58.572662354 83.404075623 60.443286896 0 0 0 # cp + 36 2 2 -0.173400 57.380615234 84.134681702 60.248710632 0 0 0 # cp + 37 1 1 0.140300 65.360115051 78.586112976 63.004997253 0 0 0 # hc + 38 1 1 0.123700 63.754127502 79.931144714 64.022262573 0 0 0 # hc + 39 1 2 -0.173400 65.018341064 79.478263855 62.440746307 0 0 0 # cp + 40 1 2 -0.113400 65.628761292 79.941154480 61.248477936 0 0 0 # cp + 41 1 2 -0.173400 65.247993469 81.172439575 60.753044128 0 0 0 # cp + 42 1 1 0.128800 66.569602966 79.514747620 60.810611725 0 0 0 # hc + 43 1 1 0.140300 65.780166626 81.570976257 59.850914001 0 0 0 # hc + 44 1 1 0.035400 61.476398468 82.376487732 60.906940460 0 0 0 # hc + 45 2 1 0.035400 58.398689270 80.172950745 62.115535736 0 0 0 # hc + 46 2 4 -0.069600 59.489074707 80.264060974 61.984001160 0 0 0 # c2 + 47 2 1 0.123700 59.297454834 83.187774658 59.645156860 0 0 0 # hc + 48 2 1 0.035400 59.675170898 80.048049927 60.920158386 0 0 0 # hc Bonds -1 10 44 19 -2 10 45 46 -3 10 48 46 -4 9 19 18 -5 1 21 38 -6 2 21 22 -7 2 21 39 -8 7 22 18 -9 2 22 24 -10 10 23 19 -11 8 27 28 -12 9 28 46 -13 9 28 19 -14 1 24 20 -15 2 24 41 -16 1 39 37 -17 1 40 42 -18 2 40 39 -19 1 41 43 -20 2 41 40 -21 1 33 30 -22 1 34 9 -23 2 34 33 -24 1 6 5 -25 2 6 2 -26 1 7 8 -27 2 7 6 -28 10 11 13 -29 13 12 13 -30 9 13 18 -31 1 15 14 -32 2 15 16 -33 2 15 4 -34 11 16 12 -35 2 16 7 -36 8 17 18 -37 12 26 12 -38 7 29 28 -39 2 29 35 -40 1 32 31 -41 2 32 29 -42 2 32 33 -43 1 35 47 -44 2 35 36 -45 1 36 10 -46 2 36 34 -47 10 25 13 -48 1 2 1 -49 2 2 4 -50 1 4 3 + 1 1 1 2 + 2 2 2 6 + 3 2 2 4 + 4 1 3 4 + 5 2 4 15 + 6 1 5 6 + 7 2 6 7 + 8 1 8 7 + 9 2 7 16 + 10 1 9 34 + 11 1 10 36 + 12 3 11 13 + 13 4 12 13 + 14 5 16 12 + 15 6 26 12 + 16 4 18 13 + 17 3 25 13 + 18 1 14 15 + 19 2 15 16 + 20 6 17 18 + 21 4 18 19 + 22 5 22 18 + 23 3 44 19 + 24 3 23 19 + 25 4 28 19 + 26 1 20 24 + 27 1 38 21 + 28 2 21 22 + 29 2 21 39 + 30 2 22 24 + 31 2 24 41 + 32 6 27 28 + 33 4 28 46 + 34 5 29 28 + 35 2 29 35 + 36 2 29 32 + 37 1 30 33 + 38 1 31 32 + 39 2 32 33 + 40 2 33 34 + 41 2 34 36 + 42 1 47 35 + 43 2 35 36 + 44 1 37 39 + 45 2 39 40 + 46 1 42 40 + 47 2 40 41 + 48 1 43 41 + 49 3 45 46 + 50 3 48 46 Angles -1 14 45 46 28 -2 14 48 46 28 -3 15 45 46 48 -4 11 22 18 13 -5 12 17 18 13 -6 13 13 18 19 -7 10 22 18 17 -8 11 22 18 19 -9 12 17 18 19 -10 16 28 19 18 -11 14 44 19 28 -12 14 23 19 28 -13 14 44 19 18 -14 14 23 19 18 -15 15 44 19 23 -16 1 22 21 38 -17 1 39 21 38 -18 2 22 21 39 -19 9 21 22 18 -20 2 21 22 24 -21 9 24 22 18 -22 10 29 28 27 -23 11 29 28 46 -24 11 29 28 19 -25 12 27 28 46 -26 12 27 28 19 -27 13 46 28 19 -28 1 22 24 20 -29 2 22 24 41 -30 1 41 24 20 -31 2 21 39 40 -32 1 21 39 37 -33 1 40 39 37 -34 1 41 40 42 -35 2 41 40 39 -36 1 39 40 42 -37 1 24 41 43 -38 2 24 41 40 -39 1 40 41 43 -40 2 32 33 34 -41 1 32 33 30 -42 1 34 33 30 -43 1 36 34 9 -44 2 36 34 33 -45 1 33 34 9 -46 1 7 6 5 -47 2 7 6 2 -48 1 2 6 5 -49 1 16 7 8 -50 2 16 7 6 -51 1 6 7 8 -52 18 16 12 26 -53 19 16 12 13 -54 20 26 12 13 -55 21 25 13 12 -56 21 11 13 12 -57 22 12 13 18 -58 15 25 13 11 -59 14 25 13 18 -60 14 11 13 18 -61 1 16 15 14 -62 1 4 15 14 -63 2 16 15 4 -64 17 15 16 12 -65 2 15 16 7 -66 17 7 16 12 -67 9 32 29 28 -68 2 32 29 35 -69 9 35 29 28 -70 1 29 32 31 -71 1 33 32 31 -72 2 29 32 33 -73 1 29 35 47 -74 2 29 35 36 -75 1 36 35 47 -76 1 35 36 10 -77 2 35 36 34 -78 1 34 36 10 -79 1 6 2 1 -80 2 6 2 4 -81 1 4 2 1 -82 2 15 4 2 -83 1 15 4 3 -84 1 2 4 3 + 1 1 1 2 6 + 2 1 1 2 4 + 3 2 6 2 4 + 4 1 3 4 2 + 5 2 2 4 15 + 6 1 3 4 15 + 7 1 5 6 2 + 8 2 2 6 7 + 9 1 5 6 7 + 10 1 8 7 6 + 11 2 6 7 16 + 12 1 8 7 16 + 13 3 16 12 13 + 14 4 26 12 13 + 15 5 26 12 16 + 16 6 11 13 12 + 17 6 11 13 18 + 18 7 11 13 25 + 19 8 12 13 18 + 20 6 25 13 12 + 21 6 25 13 18 + 22 1 14 15 4 + 23 2 4 15 16 + 24 1 14 15 16 + 25 9 7 16 12 + 26 2 7 16 15 + 27 9 15 16 12 + 28 4 17 18 13 + 29 10 13 18 19 + 30 3 22 18 13 + 31 4 17 18 19 + 32 5 17 18 22 + 33 3 22 18 19 + 34 6 44 19 18 + 35 6 23 19 18 + 36 8 18 19 28 + 37 7 44 19 23 + 38 6 44 19 28 + 39 6 23 19 28 + 40 1 38 21 22 + 41 1 38 21 39 + 42 2 22 21 39 + 43 9 21 22 18 + 44 9 24 22 18 + 45 2 21 22 24 + 46 1 20 24 22 + 47 1 20 24 41 + 48 2 22 24 41 + 49 4 27 28 19 + 50 10 19 28 46 + 51 3 29 28 19 + 52 4 27 28 46 + 53 5 27 28 29 + 54 3 29 28 46 + 55 9 35 29 28 + 56 9 32 29 28 + 57 2 35 29 32 + 58 1 31 32 29 + 59 2 29 32 33 + 60 1 31 32 33 + 61 1 30 33 32 + 62 1 30 33 34 + 63 2 32 33 34 + 64 1 9 34 33 + 65 1 9 34 36 + 66 2 33 34 36 + 67 1 47 35 29 + 68 2 29 35 36 + 69 1 47 35 36 + 70 1 10 36 34 + 71 1 10 36 35 + 72 2 34 36 35 + 73 1 37 39 21 + 74 2 21 39 40 + 75 1 37 39 40 + 76 1 42 40 39 + 77 2 39 40 41 + 78 1 42 40 41 + 79 2 24 41 40 + 80 1 43 41 24 + 81 1 43 41 40 + 82 6 45 46 28 + 83 6 48 46 28 + 84 7 45 46 48 Dihedrals -1 34 18 19 28 29 -2 31 44 19 28 29 -3 31 23 19 28 29 -4 35 18 19 28 27 -5 32 44 19 28 27 -6 32 23 19 28 27 -7 36 18 19 28 46 -8 33 44 19 28 46 -9 33 23 19 28 46 -10 36 28 19 18 13 -11 33 44 19 18 13 -12 33 23 19 18 13 -13 34 28 19 18 22 -14 31 44 19 18 22 -15 31 23 19 18 22 -16 35 28 19 18 17 -17 32 44 19 18 17 -18 32 23 19 18 17 -19 10 38 21 22 18 -20 11 39 21 22 18 -21 4 39 21 22 24 -22 5 38 21 39 37 -23 4 22 21 39 40 -24 2 22 21 39 37 -25 2 24 22 21 38 -26 13 21 22 18 13 -27 12 21 22 18 17 -28 13 21 22 18 19 -29 13 24 22 18 13 -30 12 24 22 18 17 -31 13 24 22 18 19 -32 2 21 22 24 20 -33 4 21 22 24 41 -34 14 29 28 46 45 -35 14 29 28 46 48 -36 15 27 28 46 45 -37 15 27 28 46 48 -38 16 19 28 46 45 -39 16 19 28 46 48 -40 10 20 24 22 18 -41 11 41 24 22 18 -42 2 22 24 41 43 -43 4 22 24 41 40 -44 5 20 24 41 43 -45 2 40 39 21 38 -46 2 21 39 40 42 -47 2 39 40 41 43 -48 4 41 40 39 21 -49 2 41 40 39 37 -50 5 42 40 39 37 -51 2 40 41 24 20 -52 2 24 41 40 42 -53 4 24 41 40 39 -54 5 43 41 40 42 -55 2 34 33 32 31 -56 2 32 33 34 9 -57 2 33 34 36 10 -58 4 36 34 33 32 -59 2 36 34 33 30 -60 5 9 34 33 30 -61 2 2 6 7 8 -62 2 7 6 2 1 -63 4 7 6 2 4 -64 5 5 6 2 1 -65 20 8 7 16 12 -66 21 6 7 16 12 -67 2 16 7 6 5 -68 4 16 7 6 2 -69 5 8 7 6 5 -70 24 16 12 13 25 -71 24 16 12 13 11 -72 25 16 12 13 18 -73 26 26 12 13 25 -74 26 26 12 13 11 -75 27 26 12 13 18 -76 28 12 13 18 22 -77 29 12 13 18 17 -78 30 12 13 18 19 -79 31 25 13 18 22 -80 32 25 13 18 17 -81 33 25 13 18 19 -82 31 11 13 18 22 -83 32 11 13 18 17 -84 33 11 13 18 19 -85 20 14 15 16 12 -86 21 4 15 16 12 -87 4 4 15 16 7 -88 5 14 15 4 3 -89 4 16 15 4 2 -90 2 16 15 4 3 -91 2 7 16 15 14 -92 22 15 16 12 26 -93 23 15 16 12 13 -94 22 7 16 12 26 -95 23 7 16 12 13 -96 2 15 16 7 8 -97 4 15 16 7 6 -98 2 35 29 32 31 -99 12 32 29 28 27 -100 13 32 29 28 46 -101 13 32 29 28 19 -102 12 35 29 28 27 -103 13 35 29 28 46 -104 13 35 29 28 19 -105 2 32 29 35 47 -106 4 32 29 35 36 -107 10 31 32 29 28 -108 11 33 32 29 28 -109 4 33 32 29 35 -110 5 31 32 33 30 -111 4 29 32 33 34 -112 2 29 32 33 30 -113 10 47 35 29 28 -114 11 36 35 29 28 -115 2 29 35 36 10 -116 4 29 35 36 34 -117 5 47 35 36 10 -118 2 34 36 35 47 -119 2 35 36 34 9 -120 4 35 36 34 33 -121 5 10 36 34 9 -122 2 4 2 6 5 -123 4 6 2 4 15 -124 2 6 2 4 3 -125 5 1 2 4 3 -126 2 2 4 15 14 -127 2 15 4 2 1 + 1 1 1 2 6 5 + 2 2 1 2 6 7 + 3 2 5 6 2 4 + 4 3 4 2 6 7 + 5 1 1 2 4 3 + 6 2 1 2 4 15 + 7 2 3 4 2 6 + 8 3 6 2 4 15 + 9 2 14 15 4 2 + 10 3 2 4 15 16 + 11 1 3 4 15 14 + 12 2 3 4 15 16 + 13 2 8 7 6 2 + 14 3 2 6 7 16 + 15 1 5 6 7 8 + 16 2 5 6 7 16 + 17 4 6 7 16 12 + 18 3 6 7 16 15 + 19 5 8 7 16 12 + 20 2 8 7 16 15 + 21 6 16 12 13 11 + 22 7 16 12 13 18 + 23 6 16 12 13 25 + 24 8 26 12 13 11 + 25 9 26 12 13 18 + 26 8 26 12 13 25 + 27 10 7 16 12 13 + 28 10 15 16 12 13 + 29 11 7 16 12 26 + 30 11 15 16 12 26 + 31 8 17 18 13 11 + 32 12 19 18 13 11 + 33 6 22 18 13 11 + 34 9 17 18 13 12 + 35 13 19 18 13 12 + 36 7 22 18 13 12 + 37 8 17 18 13 25 + 38 12 19 18 13 25 + 39 6 22 18 13 25 + 40 3 4 15 16 7 + 41 4 4 15 16 12 + 42 2 14 15 16 7 + 43 5 14 15 16 12 + 44 12 13 18 19 44 + 45 12 13 18 19 23 + 46 13 13 18 19 28 + 47 8 17 18 19 44 + 48 8 17 18 19 23 + 49 9 17 18 19 28 + 50 6 22 18 19 44 + 51 6 22 18 19 23 + 52 7 22 18 19 28 + 53 10 21 22 18 13 + 54 10 24 22 18 13 + 55 11 21 22 18 17 + 56 11 24 22 18 17 + 57 10 21 22 18 19 + 58 10 24 22 18 19 + 59 9 27 28 19 18 + 60 13 46 28 19 18 + 61 7 29 28 19 18 + 62 8 27 28 19 44 + 63 12 46 28 19 44 + 64 6 29 28 19 44 + 65 8 27 28 19 23 + 66 12 46 28 19 23 + 67 6 29 28 19 23 + 68 5 38 21 22 18 + 69 2 38 21 22 24 + 70 4 39 21 22 18 + 71 3 39 21 22 24 + 72 1 38 21 39 37 + 73 2 38 21 39 40 + 74 2 37 39 21 22 + 75 3 22 21 39 40 + 76 5 20 24 22 18 + 77 4 41 24 22 18 + 78 2 20 24 22 21 + 79 3 21 22 24 41 + 80 2 20 24 41 40 + 81 1 20 24 41 43 + 82 3 22 24 41 40 + 83 2 43 41 24 22 + 84 12 19 28 46 45 + 85 12 19 28 46 48 + 86 8 27 28 46 45 + 87 8 27 28 46 48 + 88 6 29 28 46 45 + 89 6 29 28 46 48 + 90 10 35 29 28 19 + 91 10 32 29 28 19 + 92 11 35 29 28 27 + 93 11 32 29 28 27 + 94 10 35 29 28 46 + 95 10 32 29 28 46 + 96 5 47 35 29 28 + 97 4 36 35 29 28 + 98 2 47 35 29 32 + 99 3 32 29 35 36 + 100 5 31 32 29 28 + 101 4 33 32 29 28 + 102 2 31 32 29 35 + 103 3 35 29 32 33 + 104 2 30 33 32 29 + 105 3 29 32 33 34 + 106 1 31 32 33 30 + 107 2 31 32 33 34 + 108 1 30 33 34 9 + 109 2 30 33 34 36 + 110 2 9 34 33 32 + 111 3 32 33 34 36 + 112 1 9 34 36 10 + 113 2 9 34 36 35 + 114 2 10 36 34 33 + 115 3 33 34 36 35 + 116 2 10 36 35 29 + 117 3 29 35 36 34 + 118 1 47 35 36 10 + 119 2 47 35 36 34 + 120 2 42 40 39 21 + 121 3 21 39 40 41 + 122 1 37 39 40 42 + 123 2 37 39 40 41 + 124 3 39 40 41 24 + 125 2 43 41 40 39 + 126 2 42 40 41 24 + 127 1 42 40 41 43 Impropers -1 6 45 46 48 28 -2 1 22 18 17 13 -3 1 22 18 13 19 -4 1 17 18 13 19 -5 1 22 18 17 19 -6 1 44 19 18 28 -7 1 23 19 18 28 -8 1 44 19 23 28 -9 1 44 19 23 18 -10 1 22 21 39 38 -11 5 21 22 24 18 -12 1 29 28 27 46 -13 1 29 28 27 19 -14 1 29 28 46 19 -15 1 27 28 46 19 -16 1 22 24 41 20 -17 1 21 39 40 37 -18 1 41 40 39 42 -19 1 24 41 40 43 -20 1 32 33 34 30 -21 1 36 34 33 9 -22 1 7 6 2 5 -23 1 16 7 6 8 -24 9 16 12 26 13 -25 1 25 13 11 12 -26 1 25 13 12 18 -27 1 11 13 12 18 -28 1 25 13 11 18 -29 1 16 15 4 14 -30 8 15 16 7 12 -31 5 32 29 35 28 -32 1 29 32 33 31 -33 1 29 35 36 47 -34 1 35 36 34 10 -35 1 6 2 4 1 -36 1 15 4 2 3 + 1 1 1 2 6 4 + 2 1 3 4 2 15 + 3 1 5 6 2 7 + 4 1 8 7 6 16 + 5 2 26 12 16 13 + 6 1 14 15 4 16 + 7 3 7 16 15 12 + 8 1 38 21 22 39 + 9 3 21 22 24 18 + 10 1 20 24 22 41 + 11 3 35 29 32 28 + 12 1 31 32 29 33 + 13 1 30 33 32 34 + 14 1 9 34 33 36 + 15 1 47 35 29 36 + 16 1 10 36 34 35 + 17 1 37 39 21 40 + 18 1 42 40 39 41 + 19 1 43 41 40 24 + 20 4 45 46 48 28 diff --git a/examples/PACKAGES/reaction/nylon,6-6_melt/in.large_nylon_melt b/examples/PACKAGES/reaction/nylon,6-6_melt/in.large_nylon_melt index 3982da799d..6fbf46f844 100644 --- a/examples/PACKAGES/reaction/nylon,6-6_melt/in.large_nylon_melt +++ b/examples/PACKAGES/reaction/nylon,6-6_melt/in.large_nylon_melt @@ -18,14 +18,19 @@ dihedral_style class2 improper_style class2 -read_data large_nylon_melt.data.gz +read_data large_nylon_melt.data.gz & + extra/bond/per/atom 5 & + extra/angle/per/atom 15 & + extra/dihedral/per/atom 15 & + extra/improper/per/atom 25 & + extra/special/per/atom 25 velocity all create 800.0 4928459 dist gaussian -molecule mol1 rxn1_stp1_unreacted.data_template -molecule mol2 rxn1_stp1_reacted.data_template -molecule mol3 rxn1_stp2_unreacted.data_template -molecule mol4 rxn1_stp2_reacted.data_template +molecule mol1 rxn1_stp1_unreacted.molecule_template +molecule mol2 rxn1_stp1_reacted.molecule_template +molecule mol3 rxn1_stp2_unreacted.molecule_template +molecule mol4 rxn1_stp2_reacted.molecule_template thermo 50 diff --git a/examples/PACKAGES/reaction/nylon,6-6_melt/large_nylon_melt.data.gz b/examples/PACKAGES/reaction/nylon,6-6_melt/large_nylon_melt.data.gz index c620b879a8..e1ec3079f7 100644 Binary files a/examples/PACKAGES/reaction/nylon,6-6_melt/large_nylon_melt.data.gz and b/examples/PACKAGES/reaction/nylon,6-6_melt/large_nylon_melt.data.gz differ diff --git a/examples/PACKAGES/reaction/nylon,6-6_melt/log.20Apr18.large_nylon_melt.g++.1 b/examples/PACKAGES/reaction/nylon,6-6_melt/log.20Apr18.large_nylon_melt.g++.1 deleted file mode 100644 index 653c7582f8..0000000000 --- a/examples/PACKAGES/reaction/nylon,6-6_melt/log.20Apr18.large_nylon_melt.g++.1 +++ /dev/null @@ -1,175 +0,0 @@ -LAMMPS (20 Apr 2018) -OMP_NUM_THREADS environment is not set. Defaulting to 1 thread. (../comm.cpp:90) - using 1 OpenMP thread(s) per MPI task -# 35,000 atom nylon melt example - -units real - -boundary p p p - -atom_style full - -kspace_style pppm 1.0e-4 - -pair_style lj/class2/coul/long 8.5 - -angle_style class2 - -bond_style class2 - -dihedral_style class2 - -improper_style class2 - -read_data large_nylon_melt.data.gz - orthogonal box = (-2.68344 -2.06791 -2.21988) to (73.4552 73.2448 73.4065) - 1 by 1 by 1 MPI processor grid - reading atoms ... - 35200 atoms - reading velocities ... - 35200 velocities - scanning bonds ... - 9 = max bonds/atom - scanning angles ... - 21 = max angles/atom - scanning dihedrals ... - 31 = max dihedrals/atom - scanning impropers ... - 29 = max impropers/atom - reading bonds ... - 33600 bonds - reading angles ... - 59200 angles - reading dihedrals ... - 80000 dihedrals - reading impropers ... - 35200 impropers - 4 = max # of 1-2 neighbors - 6 = max # of 1-3 neighbors - 12 = max # of 1-4 neighbors - 41 = max # of special neighbors - -velocity all create 800.0 4928459 dist gaussian - -molecule mol1 rxn1_stp1_unreacted.data_template -Read molecule mol1: - 18 atoms with max type 8 - 16 bonds with max type 12 - 25 angles with max type 24 - 23 dihedrals with max type 33 - 14 impropers with max type 9 -molecule mol2 rxn1_stp1_reacted.data_template -Read molecule mol2: - 18 atoms with max type 9 - 17 bonds with max type 11 - 31 angles with max type 23 - 39 dihedrals with max type 30 - 20 impropers with max type 1 -molecule mol3 rxn1_stp2_unreacted.data_template -Read molecule mol3: - 15 atoms with max type 9 - 14 bonds with max type 11 - 25 angles with max type 23 - 30 dihedrals with max type 30 - 16 impropers with max type 1 -molecule mol4 rxn1_stp2_reacted.data_template -Read molecule mol4: - 15 atoms with max type 11 - 13 bonds with max type 13 - 19 angles with max type 25 - 16 dihedrals with max type 29 - 10 impropers with max type 11 - -thermo 50 - -# dump 1 all xyz 100 test_vis.xyz - -fix myrxns all bond/react stabilization yes statted_grp .03 react rxn1 all 1 0.0 2.9 mol1 mol2 rxn1_stp1_map react rxn2 all 1 0.0 5.0 mol3 mol4 rxn1_stp2_map -WARNING: An atom in 'react #1' changes bond connectivity but not atom type (../fix_bond_react.cpp:1489) -WARNING: An atom in 'react #2' changes bond connectivity but not atom type (../fix_bond_react.cpp:1489) -dynamic group bond_react_MASTER_group defined -dynamic group statted_grp defined -dynamic group bond_react_MASTER_group defined -dynamic group statted_grp defined - -# stable at 800K -fix 1 statted_grp nvt temp 800 800 100 - -# in order to customize behavior of reacting atoms, -# you can use the internally created 'bond_react_MASTER_group', like so: -# fix 2 bond_react_MASTER_group temp/rescale 1 800 800 10 1 - -thermo_style custom step temp press density f_myrxns[1] f_myrxns[2] # cumulative reaction counts - -# restart 100 restart1 restart2 - -run 200 -PPPM initialization ... - using 12-bit tables for long-range coulomb (../kspace.cpp:321) - G vector (1/distance) = 0.20765 - grid = 18 18 18 - stencil order = 5 - estimated absolute RMS force accuracy = 0.0333156 - estimated relative force accuracy = 0.000100329 - using double precision FFTs - 3d grid and FFT values/proc = 12167 5832 -Neighbor list info ... - update every 1 steps, delay 10 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 = 15 15 15 - 2 neighbor lists, perpetual/occasional/extra = 1 1 0 - (1) pair lj/class2/coul/long, perpetual - attributes: half, newton on - pair build: half/bin/newton - stencil: half/bin/3d/newton - bin: standard - (2) fix bond/react, occasional, copy from (1) - attributes: half, newton on - pair build: copy - stencil: none - bin: none -Per MPI rank memory allocation (min/avg/max) = 209.1 | 209.1 | 209.1 Mbytes -Step Temp Press Density f_myrxns[1] f_myrxns[2] - 0 800 3666.3948 0.80366765 0 0 - 50 673.95238 -9670.9169 0.80366765 31 0 - 100 697.22819 -4624.0512 0.80366765 57 22 - 150 723.60507 -17175.571 0.80366765 76 48 - 200 736.71277 -12961.963 0.80366765 84 64 -Loop time of 102.825 on 1 procs for 200 steps with 35200 atoms - -Performance: 0.168 ns/day, 142.812 hours/ns, 1.945 timesteps/s -99.7% CPU use with 1 MPI tasks x 1 OpenMP threads - -MPI task timing breakdown: -Section | min time | avg time | max time |%varavg| %total ---------------------------------------------------------------- -Pair | 27.193 | 27.193 | 27.193 | 0.0 | 26.45 -Bond | 11.324 | 11.324 | 11.324 | 0.0 | 11.01 -Kspace | 4.1878 | 4.1878 | 4.1878 | 0.0 | 4.07 -Neigh | 54.724 | 54.724 | 54.724 | 0.0 | 53.22 -Comm | 0.40662 | 0.40662 | 0.40662 | 0.0 | 0.40 -Output | 0.0011101 | 0.0011101 | 0.0011101 | 0.0 | 0.00 -Modify | 4.9422 | 4.9422 | 4.9422 | 0.0 | 4.81 -Other | | 0.04545 | | | 0.04 - -Nlocal: 35200 ave 35200 max 35200 min -Histogram: 1 0 0 0 0 0 0 0 0 0 -Nghost: 38403 ave 38403 max 38403 min -Histogram: 1 0 0 0 0 0 0 0 0 0 -Neighs: 6.9281e+06 ave 6.9281e+06 max 6.9281e+06 min -Histogram: 1 0 0 0 0 0 0 0 0 0 - -Total # of neighbors = 6928101 -Ave neighs/atom = 196.821 -Ave special neighs/atom = 9.83727 -Neighbor list builds = 200 -Dangerous builds = 0 - -# write_restart restart_longrun -# write_data restart_longrun.data - -Please see the log.cite file for references relevant to this simulation - -Total wall time: 0:01:43 diff --git a/examples/PACKAGES/reaction/nylon,6-6_melt/log.20Apr18.large_nylon_melt.g++.4 b/examples/PACKAGES/reaction/nylon,6-6_melt/log.20Apr18.large_nylon_melt.g++.4 deleted file mode 100644 index cc0dda60c7..0000000000 --- a/examples/PACKAGES/reaction/nylon,6-6_melt/log.20Apr18.large_nylon_melt.g++.4 +++ /dev/null @@ -1,175 +0,0 @@ -LAMMPS (20 Apr 2018) -OMP_NUM_THREADS environment is not set. Defaulting to 1 thread. (../comm.cpp:90) - using 1 OpenMP thread(s) per MPI task -# 35,000 atom nylon melt example - -units real - -boundary p p p - -atom_style full - -kspace_style pppm 1.0e-4 - -pair_style lj/class2/coul/long 8.5 - -angle_style class2 - -bond_style class2 - -dihedral_style class2 - -improper_style class2 - -read_data large_nylon_melt.data.gz - orthogonal box = (-2.68344 -2.06791 -2.21988) to (73.4552 73.2448 73.4065) - 2 by 1 by 2 MPI processor grid - reading atoms ... - 35200 atoms - reading velocities ... - 35200 velocities - scanning bonds ... - 9 = max bonds/atom - scanning angles ... - 21 = max angles/atom - scanning dihedrals ... - 31 = max dihedrals/atom - scanning impropers ... - 29 = max impropers/atom - reading bonds ... - 33600 bonds - reading angles ... - 59200 angles - reading dihedrals ... - 80000 dihedrals - reading impropers ... - 35200 impropers - 4 = max # of 1-2 neighbors - 6 = max # of 1-3 neighbors - 12 = max # of 1-4 neighbors - 41 = max # of special neighbors - -velocity all create 800.0 4928459 dist gaussian - -molecule mol1 rxn1_stp1_unreacted.data_template -Read molecule mol1: - 18 atoms with max type 8 - 16 bonds with max type 12 - 25 angles with max type 24 - 23 dihedrals with max type 33 - 14 impropers with max type 9 -molecule mol2 rxn1_stp1_reacted.data_template -Read molecule mol2: - 18 atoms with max type 9 - 17 bonds with max type 11 - 31 angles with max type 23 - 39 dihedrals with max type 30 - 20 impropers with max type 1 -molecule mol3 rxn1_stp2_unreacted.data_template -Read molecule mol3: - 15 atoms with max type 9 - 14 bonds with max type 11 - 25 angles with max type 23 - 30 dihedrals with max type 30 - 16 impropers with max type 1 -molecule mol4 rxn1_stp2_reacted.data_template -Read molecule mol4: - 15 atoms with max type 11 - 13 bonds with max type 13 - 19 angles with max type 25 - 16 dihedrals with max type 29 - 10 impropers with max type 11 - -thermo 50 - -# dump 1 all xyz 100 test_vis.xyz - -fix myrxns all bond/react stabilization yes statted_grp .03 react rxn1 all 1 0.0 2.9 mol1 mol2 rxn1_stp1_map react rxn2 all 1 0.0 5.0 mol3 mol4 rxn1_stp2_map -WARNING: An atom in 'react #1' changes bond connectivity but not atom type (../fix_bond_react.cpp:1489) -WARNING: An atom in 'react #2' changes bond connectivity but not atom type (../fix_bond_react.cpp:1489) -dynamic group bond_react_MASTER_group defined -dynamic group statted_grp defined -dynamic group bond_react_MASTER_group defined -dynamic group statted_grp defined - -# stable at 800K -fix 1 statted_grp nvt temp 800 800 100 - -# in order to customize behavior of reacting atoms, -# you can use the internally created 'bond_react_MASTER_group', like so: -# fix 2 bond_react_MASTER_group temp/rescale 1 800 800 10 1 - -thermo_style custom step temp press density f_myrxns[1] f_myrxns[2] # cumulative reaction counts - -# restart 100 restart1 restart2 - -run 200 -PPPM initialization ... - using 12-bit tables for long-range coulomb (../kspace.cpp:321) - G vector (1/distance) = 0.20765 - grid = 18 18 18 - stencil order = 5 - estimated absolute RMS force accuracy = 0.0333156 - estimated relative force accuracy = 0.000100329 - using double precision FFTs - 3d grid and FFT values/proc = 4508 1620 -Neighbor list info ... - update every 1 steps, delay 10 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 = 15 15 15 - 2 neighbor lists, perpetual/occasional/extra = 1 1 0 - (1) pair lj/class2/coul/long, perpetual - attributes: half, newton on - pair build: half/bin/newton - stencil: half/bin/3d/newton - bin: standard - (2) fix bond/react, occasional, copy from (1) - attributes: half, newton on - pair build: copy - stencil: none - bin: none -Per MPI rank memory allocation (min/avg/max) = 81.11 | 81.13 | 81.15 Mbytes -Step Temp Press Density f_myrxns[1] f_myrxns[2] - 0 800 3666.3948 0.80366765 0 0 - 50 673.95238 -9670.9169 0.80366765 31 0 - 100 697.22819 -4624.0512 0.80366765 57 22 - 150 724.40407 -17166.729 0.80366765 76 49 - 200 737.28582 -12968.224 0.80366765 84 65 -Loop time of 51.171 on 4 procs for 200 steps with 35200 atoms - -Performance: 0.338 ns/day, 71.071 hours/ns, 3.908 timesteps/s -98.4% CPU use with 4 MPI tasks x 1 OpenMP threads - -MPI task timing breakdown: -Section | min time | avg time | max time |%varavg| %total ---------------------------------------------------------------- -Pair | 12.926 | 13.247 | 13.493 | 6.7 | 25.89 -Bond | 5.2132 | 5.2733 | 5.3367 | 1.9 | 10.31 -Kspace | 2.3601 | 2.6534 | 3.0067 | 16.0 | 5.19 -Neigh | 25.93 | 25.934 | 25.937 | 0.1 | 50.68 -Comm | 0.73273 | 0.75464 | 0.78505 | 2.3 | 1.47 -Output | 0.00045228 | 0.00067407 | 0.0013323 | 0.0 | 0.00 -Modify | 3.2682 | 3.2686 | 3.2692 | 0.0 | 6.39 -Other | | 0.03995 | | | 0.08 - -Nlocal: 8800 ave 8913 max 8652 min -Histogram: 1 0 0 0 1 0 0 0 1 1 -Nghost: 18366 ave 18461 max 18190 min -Histogram: 1 0 0 0 0 0 0 1 1 1 -Neighs: 1.73203e+06 ave 1.77261e+06 max 1.68165e+06 min -Histogram: 1 0 1 0 0 0 0 0 0 2 - -Total # of neighbors = 6928132 -Ave neighs/atom = 196.822 -Ave special neighs/atom = 9.83608 -Neighbor list builds = 200 -Dangerous builds = 0 - -# write_restart restart_longrun -# write_data restart_longrun.data - -Please see the log.cite file for references relevant to this simulation - -Total wall time: 0:00:52 diff --git a/examples/PACKAGES/reaction/nylon,6-6_melt/log.4Nov2022.large_nylon_melt.g++.1 b/examples/PACKAGES/reaction/nylon,6-6_melt/log.4Nov2022.large_nylon_melt.g++.1 new file mode 100644 index 0000000000..440b2e5cf0 --- /dev/null +++ b/examples/PACKAGES/reaction/nylon,6-6_melt/log.4Nov2022.large_nylon_melt.g++.1 @@ -0,0 +1,215 @@ +LAMMPS (4 Nov 2022) +# 35,000 atom nylon melt example + +units real + +boundary p p p + +atom_style full + +kspace_style pppm 1.0e-4 + +pair_style lj/class2/coul/long 8.5 + +angle_style class2 + +bond_style class2 + +dihedral_style class2 + +improper_style class2 + +read_data large_nylon_melt.data.gz extra/bond/per/atom 5 extra/angle/per/atom 15 extra/dihedral/per/atom 15 extra/improper/per/atom 25 extra/special/per/atom 25 +Reading data file ... + orthogonal box = (-2.6834403 -2.0679138 -2.2198803) to (73.455228 73.244835 73.40648) + 1 by 1 by 1 MPI processor grid + reading atom labelmap ... + reading bond labelmap ... + reading angle labelmap ... + reading dihedral labelmap ... + reading improper labelmap ... + reading atoms ... + 35200 atoms + reading velocities ... + 35200 velocities + scanning bonds ... + 9 = max bonds/atom + scanning angles ... + 21 = max angles/atom + scanning dihedrals ... + 31 = max dihedrals/atom + scanning impropers ... + 29 = max impropers/atom + reading bonds ... + 33600 bonds + reading angles ... + 59200 angles + reading dihedrals ... + 80000 dihedrals + reading impropers ... + 35200 impropers +Finding 1-2 1-3 1-4 neighbors ... + special bond factors lj: 0 0 0 + special bond factors coul: 0 0 0 + 4 = max # of 1-2 neighbors + 6 = max # of 1-3 neighbors + 12 = max # of 1-4 neighbors + 41 = max # of special neighbors + special bonds CPU = 0.026 seconds + read_data CPU = 0.937 seconds + +velocity all create 800.0 4928459 dist gaussian + +molecule mol1 rxn1_stp1_unreacted.molecule_template +Read molecule template mol1: + 1 molecules + 0 fragments + 18 atoms with max type 8 + 16 bonds with max type 12 + 25 angles with max type 24 + 23 dihedrals with max type 33 + 2 impropers with max type 9 +molecule mol2 rxn1_stp1_reacted.molecule_template +Read molecule template mol2: + 1 molecules + 0 fragments + 18 atoms with max type 9 + 17 bonds with max type 11 + 31 angles with max type 23 + 39 dihedrals with max type 30 + 0 impropers with max type 0 +molecule mol3 rxn1_stp2_unreacted.molecule_template +Read molecule template mol3: + 1 molecules + 0 fragments + 15 atoms with max type 9 + 14 bonds with max type 11 + 25 angles with max type 23 + 30 dihedrals with max type 30 + 0 impropers with max type 0 +molecule mol4 rxn1_stp2_reacted.molecule_template +Read molecule template mol4: + 1 molecules + 0 fragments + 15 atoms with max type 11 + 13 bonds with max type 13 + 19 angles with max type 25 + 16 dihedrals with max type 29 + 2 impropers with max type 11 + +thermo 50 + +# dump 1 all xyz 100 test_vis.xyz + +fix myrxns all bond/react stabilization yes statted_grp .03 react rxn1 all 1 0.0 2.9 mol1 mol2 rxn1_stp1_map react rxn2 all 1 0.0 5.0 mol3 mol4 rxn1_stp2_map +WARNING: Fix bond/react: Atom affected by reaction rxn2 is too close to template edge (../fix_bond_react.cpp:2624) +dynamic group bond_react_MASTER_group defined +dynamic group statted_grp_REACT defined + +# stable at 800K +fix 1 statted_grp_REACT nvt temp 800 800 100 + +# in order to customize behavior of reacting atoms, +# you can use the internally created 'bond_react_MASTER_group', like so: +# fix 2 bond_react_MASTER_group temp/rescale 1 800 800 10 1 + +thermo_style custom step temp press density f_myrxns[1] f_myrxns[2] # cumulative reaction counts + +# restart 100 restart1 restart2 + +run 200 + +CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE + +Your simulation uses code contributions which should be cited: + +- fix bond/react: reacter.org doi:10.1016/j.polymer.2017.09.038, doi:10.1021/acs.macromol.0c02012 + +@Article{Gissinger17, + author = {J. R. Gissinger and B. D. Jensen and K. E. Wise}, + title = {Modeling Chemical Reactions in Classical Molecular Dynamics Simulations}, + journal = {Polymer}, + year = 2017, + volume = 128, + pages = {211--217} +} + +@Article{Gissinger20, + author = {J. R. Gissinger, B. D. Jensen, K. E. Wise}, + title = {{REACTER}: A Heuristic Method for Reactive Molecular Dynamics}, + journal = {Macromolecules}, + year = 2020, + volume = 53, + number = 22, + pages = {9953--9961} +} + +CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE + +PPPM initialization ... + using 12-bit tables for long-range coulomb (../kspace.cpp:342) + G vector (1/distance) = 0.20765034 + grid = 18 18 18 + stencil order = 5 + estimated absolute RMS force accuracy = 0.033315619 + estimated relative force accuracy = 0.000100329 + using double precision KISS FFT + 3d grid and FFT values/proc = 12167 5832 +Generated 55 of 55 mixed pair_coeff terms from sixthpower/geometric mixing rule +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 = 15 15 15 + 2 neighbor lists, perpetual/occasional/extra = 1 1 0 + (1) pair lj/class2/coul/long, perpetual + attributes: half, newton on + pair build: half/bin/newton + stencil: half/bin/3d + bin: standard + (2) fix bond/react, occasional, copy from (1) + attributes: half, newton on + pair build: copy + stencil: none + bin: none +Per MPI rank memory allocation (min/avg/max) = 209.8 | 209.8 | 209.8 Mbytes + Step Temp Press Density f_myrxns[1] f_myrxns[2] + 0 800 3666.3948 0.80366765 0 0 + 50 673.94821 -9679.5038 0.80366765 31 0 + 100 694.45718 -2104.8514 0.80366765 57 22 + 150 716.53915 -12356.83 0.80366765 77 50 + 200 723.33218 -1319.9666 0.80366765 84 67 +Loop time of 87.9809 on 1 procs for 200 steps with 35200 atoms + +Performance: 0.196 ns/day, 122.196 hours/ns, 2.273 timesteps/s, 80.017 katom-step/s +100.0% CPU use with 1 MPI tasks x no OpenMP threads + +MPI task timing breakdown: +Section | min time | avg time | max time |%varavg| %total +--------------------------------------------------------------- +Pair | 25.691 | 25.691 | 25.691 | 0.0 | 29.20 +Bond | 15.772 | 15.772 | 15.772 | 0.0 | 17.93 +Kspace | 4.611 | 4.611 | 4.611 | 0.0 | 5.24 +Neigh | 35.616 | 35.616 | 35.616 | 0.0 | 40.48 +Comm | 0.24971 | 0.24971 | 0.24971 | 0.0 | 0.28 +Output | 0.00098602 | 0.00098602 | 0.00098602 | 0.0 | 0.00 +Modify | 5.9596 | 5.9596 | 5.9596 | 0.0 | 6.77 +Other | | 0.08051 | | | 0.09 + +Nlocal: 35200 ave 35200 max 35200 min +Histogram: 1 0 0 0 0 0 0 0 0 0 +Nghost: 38403 ave 38403 max 38403 min +Histogram: 1 0 0 0 0 0 0 0 0 0 +Neighs: 6.92764e+06 ave 6.92764e+06 max 6.92764e+06 min +Histogram: 1 0 0 0 0 0 0 0 0 0 + +Total # of neighbors = 6927635 +Ave neighs/atom = 196.80781 +Ave special neighs/atom = 9.8480114 +Neighbor list builds = 128 +Dangerous builds = 0 + +# write_restart restart_longrun +# write_data restart_longrun.data +Total wall time: 0:01:29 diff --git a/examples/PACKAGES/reaction/nylon,6-6_melt/log.4Nov2022.large_nylon_melt.g++.4 b/examples/PACKAGES/reaction/nylon,6-6_melt/log.4Nov2022.large_nylon_melt.g++.4 new file mode 100644 index 0000000000..52b36325b8 --- /dev/null +++ b/examples/PACKAGES/reaction/nylon,6-6_melt/log.4Nov2022.large_nylon_melt.g++.4 @@ -0,0 +1,215 @@ +LAMMPS (4 Nov 2022) +# 35,000 atom nylon melt example + +units real + +boundary p p p + +atom_style full + +kspace_style pppm 1.0e-4 + +pair_style lj/class2/coul/long 8.5 + +angle_style class2 + +bond_style class2 + +dihedral_style class2 + +improper_style class2 + +read_data large_nylon_melt.data.gz extra/bond/per/atom 5 extra/angle/per/atom 15 extra/dihedral/per/atom 15 extra/improper/per/atom 25 extra/special/per/atom 25 +Reading data file ... + orthogonal box = (-2.6834403 -2.0679138 -2.2198803) to (73.455228 73.244835 73.40648) + 2 by 1 by 2 MPI processor grid + reading atom labelmap ... + reading bond labelmap ... + reading angle labelmap ... + reading dihedral labelmap ... + reading improper labelmap ... + reading atoms ... + 35200 atoms + reading velocities ... + 35200 velocities + scanning bonds ... + 9 = max bonds/atom + scanning angles ... + 21 = max angles/atom + scanning dihedrals ... + 31 = max dihedrals/atom + scanning impropers ... + 29 = max impropers/atom + reading bonds ... + 33600 bonds + reading angles ... + 59200 angles + reading dihedrals ... + 80000 dihedrals + reading impropers ... + 35200 impropers +Finding 1-2 1-3 1-4 neighbors ... + special bond factors lj: 0 0 0 + special bond factors coul: 0 0 0 + 4 = max # of 1-2 neighbors + 6 = max # of 1-3 neighbors + 12 = max # of 1-4 neighbors + 41 = max # of special neighbors + special bonds CPU = 0.007 seconds + read_data CPU = 0.854 seconds + +velocity all create 800.0 4928459 dist gaussian + +molecule mol1 rxn1_stp1_unreacted.molecule_template +Read molecule template mol1: + 1 molecules + 0 fragments + 18 atoms with max type 8 + 16 bonds with max type 12 + 25 angles with max type 24 + 23 dihedrals with max type 33 + 2 impropers with max type 9 +molecule mol2 rxn1_stp1_reacted.molecule_template +Read molecule template mol2: + 1 molecules + 0 fragments + 18 atoms with max type 9 + 17 bonds with max type 11 + 31 angles with max type 23 + 39 dihedrals with max type 30 + 0 impropers with max type 0 +molecule mol3 rxn1_stp2_unreacted.molecule_template +Read molecule template mol3: + 1 molecules + 0 fragments + 15 atoms with max type 9 + 14 bonds with max type 11 + 25 angles with max type 23 + 30 dihedrals with max type 30 + 0 impropers with max type 0 +molecule mol4 rxn1_stp2_reacted.molecule_template +Read molecule template mol4: + 1 molecules + 0 fragments + 15 atoms with max type 11 + 13 bonds with max type 13 + 19 angles with max type 25 + 16 dihedrals with max type 29 + 2 impropers with max type 11 + +thermo 50 + +# dump 1 all xyz 100 test_vis.xyz + +fix myrxns all bond/react stabilization yes statted_grp .03 react rxn1 all 1 0.0 2.9 mol1 mol2 rxn1_stp1_map react rxn2 all 1 0.0 5.0 mol3 mol4 rxn1_stp2_map +WARNING: Fix bond/react: Atom affected by reaction rxn2 is too close to template edge (../fix_bond_react.cpp:2624) +dynamic group bond_react_MASTER_group defined +dynamic group statted_grp_REACT defined + +# stable at 800K +fix 1 statted_grp_REACT nvt temp 800 800 100 + +# in order to customize behavior of reacting atoms, +# you can use the internally created 'bond_react_MASTER_group', like so: +# fix 2 bond_react_MASTER_group temp/rescale 1 800 800 10 1 + +thermo_style custom step temp press density f_myrxns[1] f_myrxns[2] # cumulative reaction counts + +# restart 100 restart1 restart2 + +run 200 + +CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE + +Your simulation uses code contributions which should be cited: + +- fix bond/react: reacter.org doi:10.1016/j.polymer.2017.09.038, doi:10.1021/acs.macromol.0c02012 + +@Article{Gissinger17, + author = {J. R. Gissinger and B. D. Jensen and K. E. Wise}, + title = {Modeling Chemical Reactions in Classical Molecular Dynamics Simulations}, + journal = {Polymer}, + year = 2017, + volume = 128, + pages = {211--217} +} + +@Article{Gissinger20, + author = {J. R. Gissinger, B. D. Jensen, K. E. Wise}, + title = {{REACTER}: A Heuristic Method for Reactive Molecular Dynamics}, + journal = {Macromolecules}, + year = 2020, + volume = 53, + number = 22, + pages = {9953--9961} +} + +CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE + +PPPM initialization ... + using 12-bit tables for long-range coulomb (../kspace.cpp:342) + G vector (1/distance) = 0.20765034 + grid = 18 18 18 + stencil order = 5 + estimated absolute RMS force accuracy = 0.033315619 + estimated relative force accuracy = 0.000100329 + using double precision KISS FFT + 3d grid and FFT values/proc = 4508 1620 +Generated 55 of 55 mixed pair_coeff terms from sixthpower/geometric mixing rule +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 = 15 15 15 + 2 neighbor lists, perpetual/occasional/extra = 1 1 0 + (1) pair lj/class2/coul/long, perpetual + attributes: half, newton on + pair build: half/bin/newton + stencil: half/bin/3d + bin: standard + (2) fix bond/react, occasional, copy from (1) + attributes: half, newton on + pair build: copy + stencil: none + bin: none +Per MPI rank memory allocation (min/avg/max) = 81.39 | 81.41 | 81.43 Mbytes + Step Temp Press Density f_myrxns[1] f_myrxns[2] + 0 800 3666.3948 0.80366765 0 0 + 50 673.94821 -9679.5038 0.80366765 31 0 + 100 694.36354 -2108.4881 0.80366765 57 22 + 150 716.5075 -12356.04 0.80366765 77 50 + 200 722.97306 -1308.3439 0.80366765 84 67 +Loop time of 23.1041 on 4 procs for 200 steps with 35200 atoms + +Performance: 0.748 ns/day, 32.089 hours/ns, 8.656 timesteps/s, 304.708 katom-step/s +100.0% CPU use with 4 MPI tasks x no OpenMP threads + +MPI task timing breakdown: +Section | min time | avg time | max time |%varavg| %total +--------------------------------------------------------------- +Pair | 6.6935 | 6.8618 | 7.0049 | 5.1 | 29.70 +Bond | 3.8936 | 3.9807 | 4.0626 | 3.5 | 17.23 +Kspace | 1.1828 | 1.4033 | 1.6503 | 16.6 | 6.07 +Neigh | 8.7942 | 8.7945 | 8.7946 | 0.0 | 38.06 +Comm | 0.14682 | 0.15559 | 0.16441 | 1.8 | 0.67 +Output | 0.00035959 | 0.00037472 | 0.00041627 | 0.0 | 0.00 +Modify | 1.8787 | 1.8787 | 1.8788 | 0.0 | 8.13 +Other | | 0.02917 | | | 0.13 + +Nlocal: 8800 ave 8911 max 8662 min +Histogram: 1 0 0 1 0 0 0 0 1 1 +Nghost: 18358.5 ave 18438 max 18183 min +Histogram: 1 0 0 0 0 0 0 0 1 2 +Neighs: 1.73191e+06 ave 1.77313e+06 max 1.68375e+06 min +Histogram: 1 0 1 0 0 0 0 0 0 2 + +Total # of neighbors = 6927655 +Ave neighs/atom = 196.80838 +Ave special neighs/atom = 9.8480114 +Neighbor list builds = 128 +Dangerous builds = 0 + +# write_restart restart_longrun +# write_data restart_longrun.data +Total wall time: 0:00:24 diff --git a/examples/PACKAGES/reaction/nylon,6-6_melt/rxn1_stp1_reacted.data_template b/examples/PACKAGES/reaction/nylon,6-6_melt/rxn1_stp1_reacted.data_template deleted file mode 100644 index 61c0408ce3..0000000000 --- a/examples/PACKAGES/reaction/nylon,6-6_melt/rxn1_stp1_reacted.data_template +++ /dev/null @@ -1,189 +0,0 @@ -this is a molecule template for: initial nylon crosslink, post-reacting - -18 atoms -17 bonds -31 angles -39 dihedrals -20 impropers - -Types - -1 9 -2 1 -3 1 -4 4 -5 4 -6 3 -7 3 -8 1 -9 1 -10 5 -11 8 -12 6 -13 3 -14 3 -15 7 -16 1 -17 3 -18 3 - -Charges - -1 -0.300000 -2 0.000000 -3 0.000000 -4 0.000000 -5 0.000000 -6 0.000000 -7 0.000000 -8 0.000000 -9 0.000000 -10 0.300000 -11 0.000000 -12 0.000000 -13 0.000000 -14 0.000000 -15 0.000000 -16 0.000000 -17 0.000000 -18 0.000000 - -Coords - -1 -5.522237 -0.752722 1.631158 -2 -5.170398 -0.545733 0.178130 -3 -6.469695 -0.553072 -0.648889 -4 -6.052076 -1.721152 1.744648 -5 -6.183059 0.071387 1.971497 -6 -4.489340 -1.389197 -0.173156 -7 -4.637591 0.453703 0.051252 -8 -5.618658 0.138919 4.386107 -9 -4.669492 -0.989819 3.943591 -10 -4.270194 -0.766405 2.474102 -11 -3.348470 -1.875393 2.024289 -12 -3.569794 0.564183 2.345995 -13 -5.201079 -1.993301 4.044219 -14 -3.736682 -0.984819 4.598305 -15 -4.255402 1.370923 2.679069 -16 -6.136394 -0.339866 -2.136775 -17 -6.996331 -1.555519 -0.517408 -18 -7.153308 0.284949 -0.289930 - -Bonds - -1 9 1 2 -2 10 1 4 -3 10 1 5 -4 11 1 10 -5 1 2 3 -6 2 2 6 -7 2 2 7 -8 1 3 16 -9 2 3 17 -10 2 3 18 -11 1 8 9 -12 6 9 10 -13 2 9 13 -14 2 9 14 -15 7 10 11 -16 5 10 12 -17 8 12 15 - -Angles - -1 14 2 1 4 -2 14 2 1 5 -3 15 2 1 10 -4 16 4 1 5 -5 17 4 1 10 -6 17 5 1 10 -7 18 1 2 3 -8 19 1 2 6 -9 19 1 2 7 -10 1 3 2 6 -11 1 3 2 7 -12 3 6 2 7 -13 2 2 3 16 -14 1 2 3 17 -15 1 2 3 18 -16 1 16 3 17 -17 1 16 3 18 -18 3 17 3 18 -19 12 8 9 10 -20 1 8 9 13 -21 1 8 9 14 -22 13 13 9 10 -23 13 14 9 10 -24 3 13 9 14 -25 10 9 10 11 -26 8 9 10 12 -27 20 1 10 9 -28 21 11 10 12 -29 22 1 10 11 -30 23 1 10 12 -31 11 10 12 15 - -Dihedrals - -1 16 4 1 2 3 -2 17 4 1 2 6 -3 17 4 1 2 7 -4 16 5 1 2 3 -5 17 5 1 2 6 -6 17 5 1 2 7 -7 18 10 1 2 3 -8 19 10 1 2 6 -9 19 10 1 2 7 -10 20 2 1 10 9 -11 21 2 1 10 11 -12 22 2 1 10 12 -13 23 4 1 10 9 -14 24 4 1 10 11 -15 25 4 1 10 12 -16 23 5 1 10 9 -17 24 5 1 10 11 -18 25 5 1 10 12 -19 26 1 2 3 16 -20 27 1 2 3 17 -21 27 1 2 3 18 -22 4 16 3 2 6 -23 2 6 2 3 17 -24 2 6 2 3 18 -25 4 16 3 2 7 -26 2 7 2 3 17 -27 2 7 2 3 18 -28 14 8 9 10 11 -29 12 8 9 10 12 -30 28 8 9 10 1 -31 15 13 9 10 11 -32 13 13 9 10 12 -33 29 13 9 10 1 -34 15 14 9 10 11 -35 13 14 9 10 12 -36 29 14 9 10 1 -37 10 9 10 12 15 -38 11 11 10 12 15 -39 30 1 10 12 15 - -Impropers - -1 1 2 1 4 5 -2 1 2 1 4 10 -3 1 2 1 5 10 -4 1 4 1 5 10 -5 1 1 2 3 6 -6 1 1 2 3 7 -7 1 1 2 6 7 -8 1 3 2 6 7 -9 1 2 3 16 17 -10 1 2 3 16 18 -11 1 2 3 17 18 -12 1 16 3 17 18 -13 1 8 9 13 10 -14 1 8 9 14 10 -15 1 8 9 13 14 -16 1 13 9 14 10 -17 1 9 10 11 12 -18 1 1 10 9 11 -19 1 1 10 9 12 -20 1 1 10 11 12 diff --git a/examples/PACKAGES/reaction/nylon,6-6_melt/rxn1_stp1_reacted.molecule_template b/examples/PACKAGES/reaction/nylon,6-6_melt/rxn1_stp1_reacted.molecule_template new file mode 100644 index 0000000000..40f3aa8276 --- /dev/null +++ b/examples/PACKAGES/reaction/nylon,6-6_melt/rxn1_stp1_reacted.molecule_template @@ -0,0 +1,187 @@ +this is a molecule template for: initial nylon crosslink, post-reacting + + 18 atoms + 17 bonds + 31 angles + 39 dihedrals + 0 impropers + +Coords + + 1 -5.522237178 -0.752722499 1.631158408 + 2 -5.170398325 -0.545733378 0.178129978 + 3 -6.469694974 -0.553071841 -0.648889109 + 4 -6.052075697 -1.721152483 1.744647858 + 5 -6.183058842 0.071386755 1.971497329 + 6 -4.489339595 -1.389196844 -0.173156276 + 7 -4.637590712 0.453703382 0.051251954 + 8 -5.618657658 0.138918810 4.386106928 + 9 -4.669491736 -0.989818781 3.943591338 + 10 -4.270193542 -0.766405234 2.474102239 + 11 -3.348470373 -1.875393291 2.024289246 + 12 -3.569793683 0.564183226 2.345995471 + 13 -5.201078949 -1.993301389 4.044218837 + 14 -3.736681607 -0.984819193 4.598304847 + 15 -4.255401979 1.370923174 2.679069013 + 16 -6.136393628 -0.339866195 -2.136774990 + 17 -6.996331494 -1.555519161 -0.517408063 + 18 -7.153308038 0.284949373 -0.289930394 + +Types + + 1 n + 2 c2 + 3 c2 + 4 hn + 5 hn + 6 hc + 7 hc + 8 c2 + 9 c2 + 10 c_1 + 11 o_1 + 12 o + 13 hc + 14 hc + 15 ho + 16 c2 + 17 hc + 18 hc + +Charges + + 1 -0.300000 + 2 0.000000 + 3 0.000000 + 4 0.000000 + 5 0.000000 + 6 0.000000 + 7 0.000000 + 8 0.000000 + 9 0.000000 + 10 0.300000 + 11 0.000000 + 12 0.000000 + 13 0.000000 + 14 0.000000 + 15 0.000000 + 16 0.000000 + 17 0.000000 + 18 0.000000 + +Molecules + + 1 1 + 2 1 + 3 1 + 4 1 + 5 1 + 6 1 + 7 1 + 8 1 + 9 1 + 10 1 + 11 1 + 12 1 + 13 1 + 14 1 + 15 1 + 16 1 + 17 1 + 18 1 + +Bonds + + 1 n-c2 1 2 + 2 n-hn 1 4 + 3 n-hn 1 5 + 4 n-c_1 1 10 + 5 c2-c2 2 3 + 6 c2-hc 2 6 + 7 c2-hc 2 7 + 8 c2-c2 3 16 + 9 c2-hc 3 17 + 10 c2-hc 3 18 + 11 c2-c2 8 9 + 12 c2-c_1 9 10 + 13 c2-hc 9 13 + 14 c2-hc 9 14 + 15 c_1-o_1 10 11 + 16 c_1-o 10 12 + 17 o-ho 12 15 + +Angles + + 1 c2-n-hn 2 1 4 + 2 c2-n-hn 2 1 5 + 3 c2-n-c_1 2 1 10 + 4 hn-n-hn 4 1 5 + 5 hn-n-c_1 4 1 10 + 6 hn-n-c_1 5 1 10 + 7 n-c2-c2 1 2 3 + 8 n-c2-hc 1 2 6 + 9 n-c2-hc 1 2 7 + 10 c2-c2-hc 3 2 6 + 11 c2-c2-hc 3 2 7 + 12 hc-c2-hc 6 2 7 + 13 c2-c2-c2 2 3 16 + 14 c2-c2-hc 2 3 17 + 15 c2-c2-hc 2 3 18 + 16 c2-c2-hc 16 3 17 + 17 c2-c2-hc 16 3 18 + 18 hc-c2-hc 17 3 18 + 19 c2-c2-c_1 8 9 10 + 20 c2-c2-hc 8 9 13 + 21 c2-c2-hc 8 9 14 + 22 hc-c2-c_1 13 9 10 + 23 hc-c2-c_1 14 9 10 + 24 hc-c2-hc 13 9 14 + 25 c2-c_1-o_1 9 10 11 + 26 c2-c_1-o 9 10 12 + 27 n-c_1-c2 1 10 9 + 28 o_1-c_1-o 11 10 12 + 29 n-c_1-o_1 1 10 11 + 30 n-c_1-o 1 10 12 + 31 c_1-o-ho 10 12 15 + +Dihedrals + + 1 hn-n-c2-c2 4 1 2 3 + 2 hn-n-c2-hc 4 1 2 6 + 3 hn-n-c2-hc 4 1 2 7 + 4 hn-n-c2-c2 5 1 2 3 + 5 hn-n-c2-hc 5 1 2 6 + 6 hn-n-c2-hc 5 1 2 7 + 7 c_1-n-c2-c2 10 1 2 3 + 8 c_1-n-c2-hc 10 1 2 6 + 9 c_1-n-c2-hc 10 1 2 7 + 10 c2-n-c_1-c2 2 1 10 9 + 11 c2-n-c_1-o_1 2 1 10 11 + 12 c2-n-c_1-o 2 1 10 12 + 13 hn-n-c_1-c2 4 1 10 9 + 14 hn-n-c_1-o_1 4 1 10 11 + 15 hn-n-c_1-o 4 1 10 12 + 16 hn-n-c_1-c2 5 1 10 9 + 17 hn-n-c_1-o_1 5 1 10 11 + 18 hn-n-c_1-o 5 1 10 12 + 19 n-c2-c2-c2 1 2 3 16 + 20 n-c2-c2-hc 1 2 3 17 + 21 n-c2-c2-hc 1 2 3 18 + 22 c2-c2-c2-hc 16 3 2 6 + 23 hc-c2-c2-hc 6 2 3 17 + 24 hc-c2-c2-hc 6 2 3 18 + 25 c2-c2-c2-hc 16 3 2 7 + 26 hc-c2-c2-hc 7 2 3 17 + 27 hc-c2-c2-hc 7 2 3 18 + 28 c2-c2-c_1-o_1 8 9 10 11 + 29 c2-c2-c_1-o 8 9 10 12 + 30 c2-c2-c_1-n 8 9 10 1 + 31 hc-c2-c_1-o_1 13 9 10 11 + 32 hc-c2-c_1-o 13 9 10 12 + 33 hc-c2-c_1-n 13 9 10 1 + 34 hc-c2-c_1-o_1 14 9 10 11 + 35 hc-c2-c_1-o 14 9 10 12 + 36 hc-c2-c_1-n 14 9 10 1 + 37 c2-c_1-o-ho 9 10 12 15 + 38 o_1-c_1-o-ho 11 10 12 15 + 39 n-c_1-o-ho 1 10 12 15 diff --git a/examples/PACKAGES/reaction/nylon,6-6_melt/rxn1_stp1_unreacted.data_template b/examples/PACKAGES/reaction/nylon,6-6_melt/rxn1_stp1_unreacted.data_template deleted file mode 100644 index 944d6918c5..0000000000 --- a/examples/PACKAGES/reaction/nylon,6-6_melt/rxn1_stp1_unreacted.data_template +++ /dev/null @@ -1,160 +0,0 @@ -this is a molecule template for: initial nylon crosslink, pre-reacting - -18 atoms -16 bonds -25 angles -23 dihedrals -14 impropers - -Types - -1 2 -2 1 -3 1 -4 4 -5 4 -6 3 -7 3 -8 1 -9 1 -10 5 -11 8 -12 6 -13 3 -14 3 -15 7 -16 1 -17 3 -18 3 - -Charges - -1 -0.300000 -2 0.000000 -3 0.000000 -4 0.000000 -5 0.000000 -6 0.000000 -7 0.000000 -8 0.000000 -9 0.000000 -10 0.300000 -11 0.000000 -12 0.000000 -13 0.000000 -14 0.000000 -15 0.000000 -16 0.000000 -17 0.000000 -18 0.000000 - -Coords - -1 -4.922858 -0.946982 1.146055 -2 -5.047195 -0.935267 -0.358173 -3 -6.526281 -0.755366 -0.743523 -4 -5.282604 0.020447 1.552710 -5 -3.860697 -1.095850 1.428305 -6 -4.662382 -1.920900 -0.781524 -7 -4.433977 -0.072765 -0.784071 -8 -5.506279 0.202610 4.825816 -9 -4.449177 -0.844592 4.423366 -10 -4.103916 -0.749629 2.925195 -11 -3.376249 -1.886171 2.245643 -12 -4.493235 0.477214 2.137199 -13 -4.849053 -1.888877 4.663994 -14 -3.491823 -0.662913 5.018510 -15 -5.020777 1.189745 2.805427 -16 -3.964987 2.900602 -1.551341 -17 -4.460694 2.836102 0.668882 -18 -4.828494 3.219656 -0.122111 - -Bonds - -1 12 1 2 -2 4 1 4 -3 4 1 5 -4 1 2 3 -5 2 2 6 -6 2 2 7 -7 1 3 16 -8 2 3 17 -9 2 3 18 -10 1 8 9 -11 6 9 10 -12 2 9 13 -13 2 9 14 -14 7 10 11 -15 5 10 12 -16 8 12 15 - -Angles - -1 6 2 1 4 -2 6 2 1 5 -3 7 4 1 5 -4 24 1 2 3 -5 5 1 2 6 -6 5 1 2 7 -7 1 3 2 6 -8 1 3 2 7 -9 3 6 2 7 -10 2 2 3 16 -11 1 2 3 17 -12 1 2 3 18 -13 1 16 3 17 -14 1 16 3 18 -15 3 17 3 18 -16 12 8 9 10 -17 1 8 9 13 -18 1 8 9 14 -19 13 13 9 10 -20 13 14 9 10 -21 3 13 9 14 -22 10 9 10 11 -23 8 9 10 12 -24 21 11 10 12 -25 11 10 12 15 - -Dihedrals - -1 31 4 1 2 3 -2 32 4 1 2 6 -3 32 4 1 2 7 -4 31 5 1 2 3 -5 32 5 1 2 6 -6 32 5 1 2 7 -7 33 1 2 3 16 -8 1 1 2 3 17 -9 1 1 2 3 18 -10 4 16 3 2 6 -11 2 6 2 3 17 -12 2 6 2 3 18 -13 4 16 3 2 7 -14 2 7 2 3 17 -15 2 7 2 3 18 -16 14 8 9 10 11 -17 12 8 9 10 12 -18 15 13 9 10 11 -19 13 13 9 10 12 -20 15 14 9 10 11 -21 13 14 9 10 12 -22 10 9 10 12 15 -23 11 11 10 12 15 - -Impropers - -1 1 2 1 4 5 -2 9 9 10 11 12 -3 1 1 2 3 6 -4 1 1 2 3 7 -5 1 1 2 6 7 -6 1 3 2 6 7 -7 1 2 3 16 17 -8 1 2 3 16 18 -9 1 2 3 17 18 -10 1 16 3 17 18 -11 1 8 9 13 10 -12 1 8 9 14 10 -13 1 8 9 13 14 -14 1 13 9 14 10 diff --git a/examples/PACKAGES/reaction/nylon,6-6_melt/rxn1_stp1_unreacted.molecule_template b/examples/PACKAGES/reaction/nylon,6-6_melt/rxn1_stp1_unreacted.molecule_template new file mode 100644 index 0000000000..7de7512f1c --- /dev/null +++ b/examples/PACKAGES/reaction/nylon,6-6_melt/rxn1_stp1_unreacted.molecule_template @@ -0,0 +1,169 @@ +this is a molecule template for: initial nylon crosslink, pre-reacting + + 18 atoms + 16 bonds + 25 angles + 23 dihedrals + 2 impropers + +Coords + + 1 -4.922858499 -0.946981747 1.146055346 + 2 -5.047194816 -0.935266843 -0.358172771 + 3 -6.526281447 -0.755365854 -0.743523227 + 4 -5.282604074 0.020446894 1.552710361 + 5 -3.860696509 -1.095850190 1.428304925 + 6 -4.662381862 -1.920899862 -0.781524026 + 7 -4.433976540 -0.072765142 -0.784070641 + 8 -5.506279186 0.202610302 4.825815562 + 9 -4.449176624 -0.844592213 4.423366146 + 10 -4.103915981 -0.749628655 2.925195217 + 11 -3.376248536 -1.886171498 2.245643443 + 12 -4.493235430 0.477213651 2.137199034 + 13 -4.849052953 -1.888876753 4.663993750 + 14 -3.491822950 -0.662913310 5.018510248 + 15 -5.020776528 1.189745133 2.805427194 + 16 -3.964987378 2.900602044 -1.551341170 + 17 -4.460693773 2.836101897 0.668881952 + 18 -4.828494000 3.219655862 -0.122111278 + +Types + + 1 na + 2 c2 + 3 c2 + 4 hn + 5 hn + 6 hc + 7 hc + 8 c2 + 9 c2 + 10 c_1 + 11 o_1 + 12 o + 13 hc + 14 hc + 15 ho + 16 c2 + 17 hc + 18 hc + +Charges + + 1 -0.300000 + 2 0.000000 + 3 0.000000 + 4 0.000000 + 5 0.000000 + 6 0.000000 + 7 0.000000 + 8 0.000000 + 9 0.000000 + 10 0.300000 + 11 0.000000 + 12 0.000000 + 13 0.000000 + 14 0.000000 + 15 0.000000 + 16 0.000000 + 17 0.000000 + 18 0.000000 + +Molecules + + 1 1 + 2 1 + 3 1 + 4 1 + 5 1 + 6 1 + 7 1 + 8 1 + 9 1 + 10 1 + 11 1 + 12 1 + 13 1 + 14 1 + 15 1 + 16 1 + 17 1 + 18 1 + +Bonds + + 1 na-c2 1 2 + 2 na-hn 1 4 + 3 na-hn 1 5 + 4 c2-c2 2 3 + 5 c2-hc 2 6 + 6 c2-hc 2 7 + 7 c2-c2 3 16 + 8 c2-hc 3 17 + 9 c2-hc 3 18 + 10 c2-c2 8 9 + 11 c2-c_1 9 10 + 12 c2-hc 9 13 + 13 c2-hc 9 14 + 14 c_1-o_1 10 11 + 15 c_1-o 10 12 + 16 o-ho 12 15 + +Angles + + 1 c2-na-hn 2 1 4 + 2 c2-na-hn 2 1 5 + 3 hn-na-hn 4 1 5 + 4 na-c2-c2 1 2 3 + 5 na-c2-hc 1 2 6 + 6 na-c2-hc 1 2 7 + 7 c2-c2-hc 3 2 6 + 8 c2-c2-hc 3 2 7 + 9 hc-c2-hc 6 2 7 + 10 c2-c2-c2 2 3 16 + 11 c2-c2-hc 2 3 17 + 12 c2-c2-hc 2 3 18 + 13 c2-c2-hc 16 3 17 + 14 c2-c2-hc 16 3 18 + 15 hc-c2-hc 17 3 18 + 16 c2-c2-c_1 8 9 10 + 17 c2-c2-hc 8 9 13 + 18 c2-c2-hc 8 9 14 + 19 hc-c2-c_1 13 9 10 + 20 hc-c2-c_1 14 9 10 + 21 hc-c2-hc 13 9 14 + 22 c2-c_1-o_1 9 10 11 + 23 c2-c_1-o 9 10 12 + 24 o_1-c_1-o 11 10 12 + 25 c_1-o-ho 10 12 15 + +Dihedrals + + 1 hn-na-c2-c2 4 1 2 3 + 2 hn-na-c2-hc 4 1 2 6 + 3 hn-na-c2-hc 4 1 2 7 + 4 hn-na-c2-c2 5 1 2 3 + 5 hn-na-c2-hc 5 1 2 6 + 6 hn-na-c2-hc 5 1 2 7 + 7 na-c2-c2-c2 1 2 3 16 + 8 na-c2-c2-hc 1 2 3 17 + 9 na-c2-c2-hc 1 2 3 18 + 10 c2-c2-c2-hc 16 3 2 6 + 11 hc-c2-c2-hc 6 2 3 17 + 12 hc-c2-c2-hc 6 2 3 18 + 13 c2-c2-c2-hc 16 3 2 7 + 14 hc-c2-c2-hc 7 2 3 17 + 15 hc-c2-c2-hc 7 2 3 18 + 16 c2-c2-c_1-o_1 8 9 10 11 + 17 c2-c2-c_1-o 8 9 10 12 + 18 hc-c2-c_1-o_1 13 9 10 11 + 19 hc-c2-c_1-o 13 9 10 12 + 20 hc-c2-c_1-o_1 14 9 10 11 + 21 hc-c2-c_1-o 14 9 10 12 + 22 c2-c_1-o-ho 9 10 12 15 + 23 o_1-c_1-o-ho 11 10 12 15 + +Impropers + + 1 c2-na-hn-hn 2 1 4 5 + 2 c2-c_1-o_1-o 9 10 11 12 diff --git a/examples/PACKAGES/reaction/nylon,6-6_melt/rxn1_stp2_reacted.data_template b/examples/PACKAGES/reaction/nylon,6-6_melt/rxn1_stp2_reacted.data_template deleted file mode 100644 index ffd3ef733c..0000000000 --- a/examples/PACKAGES/reaction/nylon,6-6_melt/rxn1_stp2_reacted.data_template +++ /dev/null @@ -1,131 +0,0 @@ -this is a molecule template for: water condensation, post-reacting - -15 atoms -13 bonds -19 angles -16 dihedrals -10 impropers - -Types - -1 9 -2 1 -3 1 -4 10 -5 4 -6 3 -7 3 -8 1 -9 1 -10 5 -11 8 -12 11 -13 3 -14 3 -15 10 - -Charges - -1 -0.300000 -2 0.000000 -3 0.000000 -4 0.410000 -5 0.000000 -6 0.000000 -7 0.000000 -8 0.000000 -9 0.000000 -10 0.300000 -11 0.000000 -12 -0.820000 -13 0.000000 -14 0.000000 -15 0.410000 - -Coords - -1 -4.856280 -1.050468 1.432625 -2 -5.047195 -0.935267 -0.358173 -3 -6.526281 -0.755366 -0.743523 -4 -5.282604 0.020447 1.552710 -5 -3.860697 -1.095850 1.428305 -6 -4.662382 -1.920900 -0.781524 -7 -4.433977 -0.072765 -0.784071 -8 -5.506279 0.202610 4.825816 -9 -4.449177 -0.844592 4.423366 -10 -4.103916 -0.749629 2.925195 -11 -3.376249 -1.886171 2.245643 -12 -4.493235 0.477214 2.137199 -13 -4.849053 -1.888877 4.663994 -14 -3.491823 -0.662913 5.018510 -15 -5.020777 1.189745 2.805427 - -Bonds - -1 9 1 2 -2 10 1 5 -3 11 1 10 -4 1 2 3 -5 2 2 6 -6 2 2 7 -7 13 4 12 -8 1 8 9 -9 6 9 10 -10 2 9 13 -11 2 9 14 -12 7 10 11 -13 13 15 12 - -Angles - -1 14 2 1 5 -2 15 2 1 10 -3 17 5 1 10 -4 18 1 2 3 -5 19 1 2 6 -6 19 1 2 7 -7 1 3 2 6 -8 1 3 2 7 -9 3 6 2 7 -10 12 8 9 10 -11 1 8 9 13 -12 1 8 9 14 -13 13 13 9 10 -14 13 14 9 10 -15 3 13 9 14 -16 10 9 10 11 -17 20 1 10 9 -18 22 1 10 11 -19 25 15 12 4 - -Dihedrals - -1 16 5 1 2 3 -2 17 5 1 2 6 -3 17 5 1 2 7 -4 18 10 1 2 3 -5 19 10 1 2 6 -6 19 10 1 2 7 -7 20 2 1 10 9 -8 21 2 1 10 11 -9 23 5 1 10 9 -10 24 5 1 10 11 -11 14 8 9 10 11 -12 28 8 9 10 1 -13 15 13 9 10 11 -14 29 13 9 10 1 -15 15 14 9 10 11 -16 29 14 9 10 1 - -Impropers - -1 10 2 1 5 10 -2 11 1 10 9 11 -3 1 1 2 3 6 -4 1 1 2 3 7 -5 1 1 2 6 7 -6 1 3 2 6 7 -7 1 8 9 13 10 -8 1 8 9 14 10 -9 1 8 9 13 14 -10 1 13 9 14 10 diff --git a/examples/PACKAGES/reaction/nylon,6-6_melt/rxn1_stp2_reacted.molecule_template b/examples/PACKAGES/reaction/nylon,6-6_melt/rxn1_stp2_reacted.molecule_template new file mode 100644 index 0000000000..2e91261468 --- /dev/null +++ b/examples/PACKAGES/reaction/nylon,6-6_melt/rxn1_stp2_reacted.molecule_template @@ -0,0 +1,141 @@ +this is a molecule template for: water condensation, post-reacting + + 15 atoms + 13 bonds + 19 angles + 16 dihedrals + 2 impropers + +Coords + + 1 -4.856280281 -1.050467974 1.432625159 + 2 -5.047194816 -0.935266843 -0.358172771 + 3 -6.526281447 -0.755365854 -0.743523227 + 4 -5.282604074 0.020446894 1.552710361 + 5 -3.860696509 -1.095850190 1.428304925 + 6 -4.662381862 -1.920899862 -0.781524026 + 7 -4.433976540 -0.072765142 -0.784070641 + 8 -5.506279186 0.202610302 4.825815562 + 9 -4.449176624 -0.844592213 4.423366146 + 10 -4.103915981 -0.749628655 2.925195217 + 11 -3.376248536 -1.886171498 2.245643443 + 12 -4.493235430 0.477213651 2.137199034 + 13 -4.849052953 -1.888876753 4.663993750 + 14 -3.491822950 -0.662913310 5.018510248 + 15 -5.020776528 1.189745133 2.805427194 + +Types + + 1 n + 2 c2 + 3 c2 + 4 hw + 5 hn + 6 hc + 7 hc + 8 c2 + 9 c2 + 10 c_1 + 11 o_1 + 12 o* + 13 hc + 14 hc + 15 hw + +Charges + + 1 -0.300000 + 2 0.000000 + 3 0.000000 + 4 0.410000 + 5 0.000000 + 6 0.000000 + 7 0.000000 + 8 0.000000 + 9 0.000000 + 10 0.300000 + 11 0.000000 + 12 -0.820000 + 13 0.000000 + 14 0.000000 + 15 0.410000 + +Molecules + + 1 1 + 2 1 + 3 1 + 4 1 + 5 1 + 6 1 + 7 1 + 8 1 + 9 1 + 10 1 + 11 1 + 12 1 + 13 1 + 14 1 + 15 1 + +Bonds + + 1 n-c2 1 2 + 2 n-hn 1 5 + 3 n-c_1 1 10 + 4 c2-c2 2 3 + 5 c2-hc 2 6 + 6 c2-hc 2 7 + 7 hw-o* 4 12 + 8 c2-c2 8 9 + 9 c2-c_1 9 10 + 10 c2-hc 9 13 + 11 c2-hc 9 14 + 12 c_1-o_1 10 11 + 13 hw-o* 15 12 + +Angles + + 1 c2-n-hn 2 1 5 + 2 c2-n-c_1 2 1 10 + 3 hn-n-c_1 5 1 10 + 4 n-c2-c2 1 2 3 + 5 n-c2-hc 1 2 6 + 6 n-c2-hc 1 2 7 + 7 c2-c2-hc 3 2 6 + 8 c2-c2-hc 3 2 7 + 9 hc-c2-hc 6 2 7 + 10 c2-c2-c_1 8 9 10 + 11 c2-c2-hc 8 9 13 + 12 c2-c2-hc 8 9 14 + 13 hc-c2-c_1 13 9 10 + 14 hc-c2-c_1 14 9 10 + 15 hc-c2-hc 13 9 14 + 16 c2-c_1-o_1 9 10 11 + 17 n-c_1-c2 1 10 9 + 18 n-c_1-o_1 1 10 11 + 19 hw-o*-hw 15 12 4 + +Dihedrals + + 1 hn-n-c2-c2 5 1 2 3 + 2 hn-n-c2-hc 5 1 2 6 + 3 hn-n-c2-hc 5 1 2 7 + 4 c_1-n-c2-c2 10 1 2 3 + 5 c_1-n-c2-hc 10 1 2 6 + 6 c_1-n-c2-hc 10 1 2 7 + 7 c2-n-c_1-c2 2 1 10 9 + 8 c2-n-c_1-o_1 2 1 10 11 + 9 hn-n-c_1-c2 5 1 10 9 + 10 hn-n-c_1-o_1 5 1 10 11 + 11 c2-c2-c_1-o_1 8 9 10 11 + 12 c2-c2-c_1-n 8 9 10 1 + 13 hc-c2-c_1-o_1 13 9 10 11 + 14 hc-c2-c_1-n 13 9 10 1 + 15 hc-c2-c_1-o_1 14 9 10 11 + 16 hc-c2-c_1-n 14 9 10 1 + +Impropers + + 1 c2-n-hn-c_1 2 1 5 10 + 2 n-c_1-c2-o_1 1 10 9 11 diff --git a/examples/PACKAGES/reaction/nylon,6-6_melt/rxn1_stp2_unreacted.data_template b/examples/PACKAGES/reaction/nylon,6-6_melt/rxn1_stp2_unreacted.data_template deleted file mode 100644 index 7abe15ada8..0000000000 --- a/examples/PACKAGES/reaction/nylon,6-6_melt/rxn1_stp2_unreacted.data_template +++ /dev/null @@ -1,158 +0,0 @@ -this is a molecule template for: water condensation, pre-reacting - -15 atoms -14 bonds -25 angles -30 dihedrals -16 impropers - -Types - -1 9 -2 1 -3 1 -4 4 -5 4 -6 3 -7 3 -8 1 -9 1 -10 5 -11 8 -12 6 -13 3 -14 3 -15 7 - -Charges - -1 -0.300000 -2 0.000000 -3 0.000000 -4 0.000000 -5 0.000000 -6 0.000000 -7 0.000000 -8 0.000000 -9 0.000000 -10 0.300000 -11 0.000000 -12 0.000000 -13 0.000000 -14 0.000000 -15 0.000000 - -Coords - -1 -4.922858 -0.946982 1.146055 -2 -5.047195 -0.935267 -0.358173 -3 -6.526281 -0.755366 -0.743523 -4 -5.282604 0.020447 1.552710 -5 -3.860697 -1.095850 1.428305 -6 -4.662382 -1.920900 -0.781524 -7 -4.433977 -0.072765 -0.784071 -8 -5.506279 0.202610 4.825816 -9 -4.449177 -0.844592 4.423366 -10 -4.103916 -0.749629 2.925195 -11 -3.376249 -1.886171 2.245643 -12 -4.493235 0.477214 2.137199 -13 -4.849053 -1.888877 4.663994 -14 -3.491823 -0.662913 5.018510 -15 -5.020777 1.189745 2.805427 - -Bonds - -1 9 1 2 -2 10 1 4 -3 10 1 5 -4 11 1 10 -5 1 2 3 -6 2 2 6 -7 2 2 7 -8 1 8 9 -9 6 9 10 -10 2 9 13 -11 2 9 14 -12 7 10 11 -13 5 10 12 -14 8 12 15 - -Angles - -1 14 2 1 4 -2 14 2 1 5 -3 15 2 1 10 -4 16 4 1 5 -5 17 4 1 10 -6 17 5 1 10 -7 18 1 2 3 -8 19 1 2 6 -9 19 1 2 7 -10 1 3 2 6 -11 1 3 2 7 -12 3 6 2 7 -13 12 8 9 10 -14 1 8 9 13 -15 1 8 9 14 -16 13 13 9 10 -17 13 14 9 10 -18 3 13 9 14 -19 10 9 10 11 -20 8 9 10 12 -21 20 1 10 9 -22 21 11 10 12 -23 22 1 10 11 -24 23 1 10 12 -25 11 10 12 15 - -Dihedrals - -1 16 4 1 2 3 -2 17 4 1 2 6 -3 17 4 1 2 7 -4 16 5 1 2 3 -5 17 5 1 2 6 -6 17 5 1 2 7 -7 18 10 1 2 3 -8 19 10 1 2 6 -9 19 10 1 2 7 -10 20 2 1 10 9 -11 21 2 1 10 11 -12 22 2 1 10 12 -13 23 4 1 10 9 -14 24 4 1 10 11 -15 25 4 1 10 12 -16 23 5 1 10 9 -17 24 5 1 10 11 -18 25 5 1 10 12 -19 14 8 9 10 11 -20 12 8 9 10 12 -21 28 8 9 10 1 -22 15 13 9 10 11 -23 13 13 9 10 12 -24 29 13 9 10 1 -25 15 14 9 10 11 -26 13 14 9 10 12 -27 29 14 9 10 1 -28 10 9 10 12 15 -29 11 11 10 12 15 -30 30 1 10 12 15 - -Impropers - -1 1 2 1 4 5 -2 1 2 1 4 10 -3 1 2 1 5 10 -4 1 4 1 5 10 -5 1 1 2 3 6 -6 1 1 2 3 7 -7 1 1 2 6 7 -8 1 3 2 6 7 -9 1 8 9 13 10 -10 1 8 9 14 10 -11 1 8 9 13 14 -12 1 13 9 14 10 -13 1 9 10 11 12 -14 1 1 10 9 11 -15 1 1 10 9 12 -16 1 1 10 11 12 diff --git a/examples/PACKAGES/reaction/nylon,6-6_melt/rxn1_stp2_unreacted.molecule_template b/examples/PACKAGES/reaction/nylon,6-6_melt/rxn1_stp2_unreacted.molecule_template new file mode 100644 index 0000000000..86a772634d --- /dev/null +++ b/examples/PACKAGES/reaction/nylon,6-6_melt/rxn1_stp2_unreacted.molecule_template @@ -0,0 +1,157 @@ +this is a molecule template for: water condensation, pre-reacting + + 15 atoms + 14 bonds + 25 angles + 30 dihedrals + 0 impropers + +Coords + + 1 -4.922858499 -0.946981747 1.146055346 + 2 -5.047194816 -0.935266843 -0.358172771 + 3 -6.526281447 -0.755365854 -0.743523227 + 4 -5.282604074 0.020446894 1.552710361 + 5 -3.860696509 -1.095850190 1.428304925 + 6 -4.662381862 -1.920899862 -0.781524026 + 7 -4.433976540 -0.072765142 -0.784070641 + 8 -5.506279186 0.202610302 4.825815562 + 9 -4.449176624 -0.844592213 4.423366146 + 10 -4.103915981 -0.749628655 2.925195217 + 11 -3.376248536 -1.886171498 2.245643443 + 12 -4.493235430 0.477213651 2.137199034 + 13 -4.849052953 -1.888876753 4.663993750 + 14 -3.491822950 -0.662913310 5.018510248 + 15 -5.020776528 1.189745133 2.805427194 + +Types + + 1 n + 2 c2 + 3 c2 + 4 hn + 5 hn + 6 hc + 7 hc + 8 c2 + 9 c2 + 10 c_1 + 11 o_1 + 12 o + 13 hc + 14 hc + 15 ho + +Charges + + 1 -0.300000 + 2 0.000000 + 3 0.000000 + 4 0.000000 + 5 0.000000 + 6 0.000000 + 7 0.000000 + 8 0.000000 + 9 0.000000 + 10 0.300000 + 11 0.000000 + 12 0.000000 + 13 0.000000 + 14 0.000000 + 15 0.000000 + +Molecules + + 1 1 + 2 1 + 3 1 + 4 1 + 5 1 + 6 1 + 7 1 + 8 1 + 9 1 + 10 1 + 11 1 + 12 1 + 13 1 + 14 1 + 15 1 + +Bonds + + 1 n-c2 1 2 + 2 n-hn 1 4 + 3 n-hn 1 5 + 4 n-c_1 1 10 + 5 c2-c2 2 3 + 6 c2-hc 2 6 + 7 c2-hc 2 7 + 8 c2-c2 8 9 + 9 c2-c_1 9 10 + 10 c2-hc 9 13 + 11 c2-hc 9 14 + 12 c_1-o_1 10 11 + 13 c_1-o 10 12 + 14 o-ho 12 15 + +Angles + + 1 c2-n-hn 2 1 4 + 2 c2-n-hn 2 1 5 + 3 c2-n-c_1 2 1 10 + 4 hn-n-hn 4 1 5 + 5 hn-n-c_1 4 1 10 + 6 hn-n-c_1 5 1 10 + 7 n-c2-c2 1 2 3 + 8 n-c2-hc 1 2 6 + 9 n-c2-hc 1 2 7 + 10 c2-c2-hc 3 2 6 + 11 c2-c2-hc 3 2 7 + 12 hc-c2-hc 6 2 7 + 13 c2-c2-c_1 8 9 10 + 14 c2-c2-hc 8 9 13 + 15 c2-c2-hc 8 9 14 + 16 hc-c2-c_1 13 9 10 + 17 hc-c2-c_1 14 9 10 + 18 hc-c2-hc 13 9 14 + 19 c2-c_1-o_1 9 10 11 + 20 c2-c_1-o 9 10 12 + 21 n-c_1-c2 1 10 9 + 22 o_1-c_1-o 11 10 12 + 23 n-c_1-o_1 1 10 11 + 24 n-c_1-o 1 10 12 + 25 c_1-o-ho 10 12 15 + +Dihedrals + + 1 hn-n-c2-c2 4 1 2 3 + 2 hn-n-c2-hc 4 1 2 6 + 3 hn-n-c2-hc 4 1 2 7 + 4 hn-n-c2-c2 5 1 2 3 + 5 hn-n-c2-hc 5 1 2 6 + 6 hn-n-c2-hc 5 1 2 7 + 7 c_1-n-c2-c2 10 1 2 3 + 8 c_1-n-c2-hc 10 1 2 6 + 9 c_1-n-c2-hc 10 1 2 7 + 10 c2-n-c_1-c2 2 1 10 9 + 11 c2-n-c_1-o_1 2 1 10 11 + 12 c2-n-c_1-o 2 1 10 12 + 13 hn-n-c_1-c2 4 1 10 9 + 14 hn-n-c_1-o_1 4 1 10 11 + 15 hn-n-c_1-o 4 1 10 12 + 16 hn-n-c_1-c2 5 1 10 9 + 17 hn-n-c_1-o_1 5 1 10 11 + 18 hn-n-c_1-o 5 1 10 12 + 19 c2-c2-c_1-o_1 8 9 10 11 + 20 c2-c2-c_1-o 8 9 10 12 + 21 c2-c2-c_1-n 8 9 10 1 + 22 hc-c2-c_1-o_1 13 9 10 11 + 23 hc-c2-c_1-o 13 9 10 12 + 24 hc-c2-c_1-n 13 9 10 1 + 25 hc-c2-c_1-o_1 14 9 10 11 + 26 hc-c2-c_1-o 14 9 10 12 + 27 hc-c2-c_1-n 14 9 10 1 + 28 c2-c_1-o-ho 9 10 12 15 + 29 o_1-c_1-o-ho 11 10 12 15 + 30 n-c_1-o-ho 1 10 12 15 diff --git a/examples/PACKAGES/reaction/tiny_epoxy/in.tiny_epoxy.stabilized b/examples/PACKAGES/reaction/tiny_epoxy/in.tiny_epoxy.stabilized index 0e6e97cd46..1309eff3a3 100644 --- a/examples/PACKAGES/reaction/tiny_epoxy/in.tiny_epoxy.stabilized +++ b/examples/PACKAGES/reaction/tiny_epoxy/in.tiny_epoxy.stabilized @@ -9,9 +9,9 @@ atom_style full pair_style lj/class2 8 -angle_style class2 +angle_style class2 -bond_style class2 +bond_style class2 dihedral_style class2 @@ -21,12 +21,12 @@ read_data tiny_epoxy.data velocity all create 300.0 4928459 dist gaussian -molecule mol1 rxn1_stp1_pre.data_template -molecule mol2 rxn1_stp1_post.data_template -molecule mol3 rxn1_stp2_post.data_template -molecule mol4 rxn2_stp1_pre.data_template -molecule mol5 rxn2_stp1_post.data_template -molecule mol6 rxn2_stp2_post.data_template +molecule mol1 rxn1_stp1_pre.molecule_template +molecule mol2 rxn1_stp1_post.molecule_template +molecule mol3 rxn1_stp2_post.molecule_template +molecule mol4 rxn2_stp1_pre.molecule_template +molecule mol5 rxn2_stp1_post.molecule_template +molecule mol6 rxn2_stp2_post.molecule_template thermo 50 diff --git a/examples/PACKAGES/reaction/tiny_epoxy/log.20Nov19.tiny_epoxy.stabilized.g++.1 b/examples/PACKAGES/reaction/tiny_epoxy/log.20Nov19.tiny_epoxy.stabilized.g++.1 deleted file mode 100644 index 6ca0361513..0000000000 --- a/examples/PACKAGES/reaction/tiny_epoxy/log.20Nov19.tiny_epoxy.stabilized.g++.1 +++ /dev/null @@ -1,172 +0,0 @@ -LAMMPS (20 Nov 2019) - -WARNING-WARNING-WARNING-WARNING-WARNING -This LAMMPS executable was compiled using C++98 compatibility. -Please report the compiler info below at https://github.com/lammps/lammps/issues/1659 -GNU C++ 4.8.5 -WARNING-WARNING-WARNING-WARNING-WARNING - -Reading data file ... - orthogonal box = (10 -10 -15) to (30 20 10) - 1 by 1 by 1 MPI processor grid - reading atoms ... - 118 atoms - scanning bonds ... - 4 = max bonds/atom - scanning angles ... - 6 = max angles/atom - scanning dihedrals ... - 18 = max dihedrals/atom - scanning impropers ... - 4 = max impropers/atom - reading bonds ... - 123 bonds - reading angles ... - 221 angles - reading dihedrals ... - 302 dihedrals - reading impropers ... - 115 impropers -Finding 1-2 1-3 1-4 neighbors ... - special bond factors lj: 0 0 0 - special bond factors coul: 0 0 0 - 4 = max # of 1-2 neighbors - 10 = max # of 1-3 neighbors - 19 = max # of 1-4 neighbors - 22 = max # of special neighbors - special bonds CPU = 0.000286808 secs - read_data CPU = 0.00724107 secs -Read molecule mol1: - 31 atoms with max type 10 - 30 bonds with max type 15 - 53 angles with max type 29 - 66 dihedrals with max type 39 - 31 impropers with max type 5 -Read molecule mol2: - 31 atoms with max type 10 - 30 bonds with max type 17 - 55 angles with max type 36 - 75 dihedrals with max type 51 - 34 impropers with max type 5 -Read molecule mol3: - 31 atoms with max type 11 - 30 bonds with max type 18 - 53 angles with max type 37 - 72 dihedrals with max type 53 - 31 impropers with max type 5 -Read molecule mol4: - 42 atoms with max type 11 - 41 bonds with max type 18 - 73 angles with max type 41 - 96 dihedrals with max type 54 - 43 impropers with max type 5 -Read molecule mol5: - 42 atoms with max type 11 - 41 bonds with max type 18 - 75 angles with max type 37 - 108 dihedrals with max type 53 - 46 impropers with max type 5 -Read molecule mol6: - 42 atoms with max type 11 - 41 bonds with max type 19 - 73 angles with max type 50 - 102 dihedrals with max type 66 - 43 impropers with max type 22 -dynamic group bond_react_MASTER_group defined -dynamic group statted_grp_REACT defined -Neighbor list info ... - update every 1 steps, delay 10 steps, check yes - max neighbors/atom: 2000, page size: 100000 - master list distance cutoff = 10 - ghost atom cutoff = 10 - binsize = 5, bins = 4 6 5 - 2 neighbor lists, perpetual/occasional/extra = 1 1 0 - (1) pair lj/class2, perpetual - attributes: half, newton on - pair build: half/bin/newton - stencil: half/bin/3d/newton - bin: standard - (2) fix bond/react, occasional, copy from (1) - attributes: half, newton on - pair build: copy - stencil: none - bin: none -Setting up Verlet run ... - Unit style : real - Current step : 0 - Time step : 1 -Per MPI rank memory allocation (min/avg/max) = 17.28 | 17.28 | 17.28 Mbytes -Step Temp f_rxns[1] f_rxns[2] f_rxns[3] f_rxns[4] - 0 300 0 0 0 0 - 50 391.52956 1 0 0 0 - 100 475.26826 1 1 0 0 - 150 605.26215 1 1 1 0 - 200 545.7485 1 1 1 0 - 250 461.64929 1 1 1 1 - 300 452.10611 1 1 1 1 - 350 379.61671 1 1 1 1 - 400 331.22444 1 1 1 1 - 450 275.63969 1 1 1 1 - 500 316.63407 1 1 1 1 - 550 261.39841 1 1 1 1 - 600 313.70928 1 1 1 1 - 650 294.24011 1 1 1 1 - 700 285.81736 1 1 1 1 - 750 340.37496 1 1 1 1 - 800 333.2496 1 1 1 1 - 850 307.40826 1 1 1 1 - 900 304.68718 1 1 1 1 - 950 328.0289 1 1 1 1 - 1000 290.22808 1 1 1 1 - 1050 272.78518 1 1 1 1 - 1100 291.30546 1 1 1 1 - 1150 320.33992 1 1 1 1 - 1200 330.57057 1 1 1 1 - 1250 300.51008 1 1 1 1 - 1300 293.6209 1 1 1 1 - 1350 324.36604 1 1 1 1 - 1400 331.15408 1 1 1 1 - 1450 302.23396 1 1 1 1 - 1500 297.55562 1 1 1 1 - 1550 277.3187 1 1 1 1 - 1600 289.66052 1 1 1 1 - 1650 281.85404 1 1 1 1 - 1700 293.4999 1 1 1 1 - 1750 306.21866 1 1 1 1 - 1800 283.22696 1 1 1 1 - 1850 295.10473 1 1 1 1 - 1900 317.3843 1 1 1 1 - 1950 305.14825 1 1 1 1 - 2000 289.00911 1 1 1 1 -Loop time of 1.87066 on 1 procs for 2000 steps with 118 atoms - -Performance: 92.374 ns/day, 0.260 hours/ns, 1069.141 timesteps/s -98.4% CPU use with 1 MPI tasks x no OpenMP threads - -MPI task timing breakdown: -Section | min time | avg time | max time |%varavg| %total ---------------------------------------------------------------- -Pair | 0.12832 | 0.12832 | 0.12832 | 0.0 | 6.86 -Bond | 0.77458 | 0.77458 | 0.77458 | 0.0 | 41.41 -Neigh | 0.45068 | 0.45068 | 0.45068 | 0.0 | 24.09 -Comm | 0.029785 | 0.029785 | 0.029785 | 0.0 | 1.59 -Output | 0.31635 | 0.31635 | 0.31635 | 0.0 | 16.91 -Modify | 0.16657 | 0.16657 | 0.16657 | 0.0 | 8.90 -Other | | 0.004368 | | | 0.23 - -Nlocal: 118 ave 118 max 118 min -Histogram: 1 0 0 0 0 0 0 0 0 0 -Nghost: 332 ave 332 max 332 min -Histogram: 1 0 0 0 0 0 0 0 0 0 -Neighs: 4338 ave 4338 max 4338 min -Histogram: 1 0 0 0 0 0 0 0 0 0 - -Total # of neighbors = 4338 -Ave neighs/atom = 36.7627 -Ave special neighs/atom = 10.5763 -Neighbor list builds = 2000 -Dangerous builds = 0 - -Please see the log.cite file for references relevant to this simulation - -Total wall time: 0:00:02 diff --git a/examples/PACKAGES/reaction/tiny_epoxy/log.20Nov19.tiny_epoxy.stabilized.g++.4 b/examples/PACKAGES/reaction/tiny_epoxy/log.20Nov19.tiny_epoxy.stabilized.g++.4 deleted file mode 100644 index 4673ba3980..0000000000 --- a/examples/PACKAGES/reaction/tiny_epoxy/log.20Nov19.tiny_epoxy.stabilized.g++.4 +++ /dev/null @@ -1,172 +0,0 @@ -LAMMPS (20 Nov 2019) - -WARNING-WARNING-WARNING-WARNING-WARNING -This LAMMPS executable was compiled using C++98 compatibility. -Please report the compiler info below at https://github.com/lammps/lammps/issues/1659 -GNU C++ 4.8.5 -WARNING-WARNING-WARNING-WARNING-WARNING - -Reading data file ... - orthogonal box = (10 -10 -15) to (30 20 10) - 1 by 2 by 2 MPI processor grid - reading atoms ... - 118 atoms - scanning bonds ... - 4 = max bonds/atom - scanning angles ... - 6 = max angles/atom - scanning dihedrals ... - 18 = max dihedrals/atom - scanning impropers ... - 4 = max impropers/atom - reading bonds ... - 123 bonds - reading angles ... - 221 angles - reading dihedrals ... - 302 dihedrals - reading impropers ... - 115 impropers -Finding 1-2 1-3 1-4 neighbors ... - special bond factors lj: 0 0 0 - special bond factors coul: 0 0 0 - 4 = max # of 1-2 neighbors - 10 = max # of 1-3 neighbors - 19 = max # of 1-4 neighbors - 22 = max # of special neighbors - special bonds CPU = 0.000239905 secs - read_data CPU = 0.0080783 secs -Read molecule mol1: - 31 atoms with max type 10 - 30 bonds with max type 15 - 53 angles with max type 29 - 66 dihedrals with max type 39 - 31 impropers with max type 5 -Read molecule mol2: - 31 atoms with max type 10 - 30 bonds with max type 17 - 55 angles with max type 36 - 75 dihedrals with max type 51 - 34 impropers with max type 5 -Read molecule mol3: - 31 atoms with max type 11 - 30 bonds with max type 18 - 53 angles with max type 37 - 72 dihedrals with max type 53 - 31 impropers with max type 5 -Read molecule mol4: - 42 atoms with max type 11 - 41 bonds with max type 18 - 73 angles with max type 41 - 96 dihedrals with max type 54 - 43 impropers with max type 5 -Read molecule mol5: - 42 atoms with max type 11 - 41 bonds with max type 18 - 75 angles with max type 37 - 108 dihedrals with max type 53 - 46 impropers with max type 5 -Read molecule mol6: - 42 atoms with max type 11 - 41 bonds with max type 19 - 73 angles with max type 50 - 102 dihedrals with max type 66 - 43 impropers with max type 22 -dynamic group bond_react_MASTER_group defined -dynamic group statted_grp_REACT defined -Neighbor list info ... - update every 1 steps, delay 10 steps, check yes - max neighbors/atom: 2000, page size: 100000 - master list distance cutoff = 10 - ghost atom cutoff = 10 - binsize = 5, bins = 4 6 5 - 2 neighbor lists, perpetual/occasional/extra = 1 1 0 - (1) pair lj/class2, perpetual - attributes: half, newton on - pair build: half/bin/newton - stencil: half/bin/3d/newton - bin: standard - (2) fix bond/react, occasional, copy from (1) - attributes: half, newton on - pair build: copy - stencil: none - bin: none -Setting up Verlet run ... - Unit style : real - Current step : 0 - Time step : 1 -Per MPI rank memory allocation (min/avg/max) = 16.26 | 16.45 | 16.63 Mbytes -Step Temp f_rxns[1] f_rxns[2] f_rxns[3] f_rxns[4] - 0 300 0 0 0 0 - 50 391.52956 1 0 0 0 - 100 475.26826 1 1 0 0 - 150 605.26215 1 1 1 0 - 200 545.7485 1 1 1 0 - 250 461.64929 1 1 1 1 - 300 452.10611 1 1 1 1 - 350 379.61671 1 1 1 1 - 400 331.22444 1 1 1 1 - 450 275.63969 1 1 1 1 - 500 316.63407 1 1 1 1 - 550 261.39841 1 1 1 1 - 600 313.70928 1 1 1 1 - 650 294.24011 1 1 1 1 - 700 285.81736 1 1 1 1 - 750 340.37496 1 1 1 1 - 800 333.2496 1 1 1 1 - 850 307.40826 1 1 1 1 - 900 304.68718 1 1 1 1 - 950 328.0289 1 1 1 1 - 1000 290.22808 1 1 1 1 - 1050 272.78518 1 1 1 1 - 1100 291.30546 1 1 1 1 - 1150 320.33992 1 1 1 1 - 1200 330.57057 1 1 1 1 - 1250 300.51008 1 1 1 1 - 1300 293.6209 1 1 1 1 - 1350 324.36604 1 1 1 1 - 1400 331.15408 1 1 1 1 - 1450 302.23396 1 1 1 1 - 1500 297.55562 1 1 1 1 - 1550 277.3187 1 1 1 1 - 1600 289.66052 1 1 1 1 - 1650 281.85404 1 1 1 1 - 1700 293.4999 1 1 1 1 - 1750 306.21866 1 1 1 1 - 1800 283.22695 1 1 1 1 - 1850 295.10472 1 1 1 1 - 1900 317.38431 1 1 1 1 - 1950 305.14824 1 1 1 1 - 2000 289.00909 1 1 1 1 -Loop time of 0.689125 on 4 procs for 2000 steps with 118 atoms - -Performance: 250.753 ns/day, 0.096 hours/ns, 2902.231 timesteps/s -100.0% CPU use with 4 MPI tasks x no OpenMP threads - -MPI task timing breakdown: -Section | min time | avg time | max time |%varavg| %total ---------------------------------------------------------------- -Pair | 0.02002 | 0.030617 | 0.053133 | 7.7 | 4.44 -Bond | 0.10356 | 0.18908 | 0.22691 | 11.6 | 27.44 -Neigh | 0.16721 | 0.17002 | 0.17247 | 0.5 | 24.67 -Comm | 0.057286 | 0.12002 | 0.21612 | 17.0 | 17.42 -Output | 0.00028991 | 0.00034121 | 0.00049323 | 0.0 | 0.05 -Modify | 0.17626 | 0.17675 | 0.17721 | 0.1 | 25.65 -Other | | 0.002287 | | | 0.33 - -Nlocal: 29.5 ave 41 max 18 min -Histogram: 1 0 0 1 0 0 1 0 0 1 -Nghost: 306 ave 349 max 269 min -Histogram: 1 1 0 0 0 0 1 0 0 1 -Neighs: 1084.5 ave 2154 max 397 min -Histogram: 1 0 1 1 0 0 0 0 0 1 - -Total # of neighbors = 4338 -Ave neighs/atom = 36.7627 -Ave special neighs/atom = 10.5763 -Neighbor list builds = 2000 -Dangerous builds = 0 - -Please see the log.cite file for references relevant to this simulation - -Total wall time: 0:00:01 diff --git a/examples/PACKAGES/reaction/tiny_epoxy/log.4Nov2022.tiny_epoxy.stabilized.g++.1 b/examples/PACKAGES/reaction/tiny_epoxy/log.4Nov2022.tiny_epoxy.stabilized.g++.1 new file mode 100644 index 0000000000..24b8fb0987 --- /dev/null +++ b/examples/PACKAGES/reaction/tiny_epoxy/log.4Nov2022.tiny_epoxy.stabilized.g++.1 @@ -0,0 +1,249 @@ +LAMMPS (4 Nov 2022) +# two molecules DGEBA (diepoxy) and one DETA (linker) +# two crosslinking reactions + +units real + +boundary p p p + +atom_style full + +pair_style lj/class2 8 + +angle_style class2 + +bond_style class2 + +dihedral_style class2 + +improper_style class2 + +read_data tiny_epoxy.data +Reading data file ... + orthogonal box = (10 -10 -15) to (30 20 10) + 1 by 1 by 1 MPI processor grid + reading atom labelmap ... + reading bond labelmap ... + reading angle labelmap ... + reading dihedral labelmap ... + reading improper labelmap ... + reading atoms ... + 118 atoms + scanning bonds ... + 4 = max bonds/atom + scanning angles ... + 6 = max angles/atom + scanning dihedrals ... + 18 = max dihedrals/atom + scanning impropers ... + 4 = max impropers/atom + reading bonds ... + 123 bonds + reading angles ... + 221 angles + reading dihedrals ... + 302 dihedrals + reading impropers ... + 115 impropers +Finding 1-2 1-3 1-4 neighbors ... + special bond factors lj: 0 0 0 + special bond factors coul: 0 0 0 + 4 = max # of 1-2 neighbors + 10 = max # of 1-3 neighbors + 19 = max # of 1-4 neighbors + 22 = max # of special neighbors + special bonds CPU = 0.000 seconds + read_data CPU = 0.015 seconds + +velocity all create 300.0 4928459 dist gaussian + +molecule mol1 rxn1_stp1_pre.molecule_template +Read molecule template mol1: + 1 molecules + 0 fragments + 31 atoms with max type 10 + 30 bonds with max type 15 + 53 angles with max type 29 + 66 dihedrals with max type 39 + 3 impropers with max type 5 +molecule mol2 rxn1_stp1_post.molecule_template +Read molecule template mol2: + 1 molecules + 0 fragments + 31 atoms with max type 10 + 30 bonds with max type 17 + 55 angles with max type 36 + 75 dihedrals with max type 51 + 2 impropers with max type 5 +molecule mol3 rxn1_stp2_post.molecule_template +Read molecule template mol3: + 1 molecules + 0 fragments + 31 atoms with max type 11 + 30 bonds with max type 18 + 53 angles with max type 37 + 72 dihedrals with max type 53 + 3 impropers with max type 5 +molecule mol4 rxn2_stp1_pre.molecule_template +Read molecule template mol4: + 1 molecules + 0 fragments + 42 atoms with max type 11 + 41 bonds with max type 18 + 73 angles with max type 41 + 96 dihedrals with max type 54 + 3 impropers with max type 5 +molecule mol5 rxn2_stp1_post.molecule_template +Read molecule template mol5: + 1 molecules + 0 fragments + 42 atoms with max type 11 + 41 bonds with max type 18 + 75 angles with max type 37 + 108 dihedrals with max type 53 + 2 impropers with max type 5 +molecule mol6 rxn2_stp2_post.molecule_template +Read molecule template mol6: + 1 molecules + 0 fragments + 42 atoms with max type 11 + 41 bonds with max type 19 + 73 angles with max type 50 + 102 dihedrals with max type 66 + 3 impropers with max type 22 + +thermo 50 + +# dump 1 all xyz 1 test_vis.xyz + +fix rxns all bond/react stabilization yes statted_grp .03 react rxn1_stp1 all 1 0.0 5 mol1 mol2 rxn1_stp1.map react rxn1_stp2 all 1 0.0 5 mol2 mol3 rxn1_stp2.map react rxn2_stp1 all 1 0.0 5 mol4 mol5 rxn2_stp1.map react rxn2_stp2 all 1 0.0 5 mol5 mol6 rxn2_stp2.map +dynamic group bond_react_MASTER_group defined +dynamic group statted_grp_REACT defined + + +fix 1 statted_grp_REACT nvt temp 300 300 100 + +thermo_style custom step temp f_rxns[1] f_rxns[2] f_rxns[3] f_rxns[4] + +run 2000 + +CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE + +Your simulation uses code contributions which should be cited: + +- fix bond/react: reacter.org doi:10.1016/j.polymer.2017.09.038, doi:10.1021/acs.macromol.0c02012 + +@Article{Gissinger17, + author = {J. R. Gissinger and B. D. Jensen and K. E. Wise}, + title = {Modeling Chemical Reactions in Classical Molecular Dynamics Simulations}, + journal = {Polymer}, + year = 2017, + volume = 128, + pages = {211--217} +} + +@Article{Gissinger20, + author = {J. R. Gissinger, B. D. Jensen, K. E. Wise}, + title = {{REACTER}: A Heuristic Method for Reactive Molecular Dynamics}, + journal = {Macromolecules}, + year = 2020, + volume = 53, + number = 22, + pages = {9953--9961} +} + +CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE + +Generated 55 of 55 mixed pair_coeff terms from sixthpower/geometric mixing rule +Neighbor list info ... + update: every = 1 steps, delay = 0 steps, check = yes + max neighbors/atom: 2000, page size: 100000 + master list distance cutoff = 10 + ghost atom cutoff = 10 + binsize = 5, bins = 4 6 5 + 2 neighbor lists, perpetual/occasional/extra = 1 1 0 + (1) pair lj/class2, perpetual + attributes: half, newton on + pair build: half/bin/newton + stencil: half/bin/3d + bin: standard + (2) fix bond/react, occasional, copy from (1) + attributes: half, newton on + pair build: copy + stencil: none + bin: none +Per MPI rank memory allocation (min/avg/max) = 16.64 | 16.64 | 16.64 Mbytes + Step Temp f_rxns[1] f_rxns[2] f_rxns[3] f_rxns[4] + 0 300 0 0 0 0 + 50 378.29345 1 0 0 0 + 100 471.04152 1 1 0 0 + 150 583.79755 1 1 1 0 + 200 526.00812 1 1 1 1 + 250 429.56812 1 1 1 1 + 300 512.54655 1 1 1 1 + 350 461.18357 1 1 1 1 + 400 379.38965 1 1 1 1 + 450 424.89528 1 1 1 1 + 500 324.72257 1 1 1 1 + 550 302.91042 1 1 1 1 + 600 253.80911 1 1 1 1 + 650 252.90262 1 1 1 1 + 700 270.62628 1 1 1 1 + 750 311.64391 1 1 1 1 + 800 318.9413 1 1 1 1 + 850 354.20196 1 1 1 1 + 900 302.19641 1 1 1 1 + 950 316.97905 1 1 1 1 + 1000 303.08194 1 1 1 1 + 1050 317.51619 1 1 1 1 + 1100 287.57204 1 1 1 1 + 1150 226.72101 1 1 1 1 + 1200 283.97519 1 1 1 1 + 1250 287.0607 1 1 1 1 + 1300 327.65278 1 1 1 1 + 1350 316.06809 1 1 1 1 + 1400 337.69947 1 1 1 1 + 1450 326.12278 1 1 1 1 + 1500 300.89265 1 1 1 1 + 1550 325.2415 1 1 1 1 + 1600 294.1844 1 1 1 1 + 1650 293.98596 1 1 1 1 + 1700 317.35477 1 1 1 1 + 1750 296.97768 1 1 1 1 + 1800 274.97297 1 1 1 1 + 1850 335.36697 1 1 1 1 + 1900 315.3756 1 1 1 1 + 1950 260.65335 1 1 1 1 + 2000 354.03612 1 1 1 1 +Loop time of 0.910097 on 1 procs for 2000 steps with 118 atoms + +Performance: 189.870 ns/day, 0.126 hours/ns, 2197.568 timesteps/s, 259.313 katom-step/s +99.9% CPU use with 1 MPI tasks x no OpenMP threads + +MPI task timing breakdown: +Section | min time | avg time | max time |%varavg| %total +--------------------------------------------------------------- +Pair | 0.10286 | 0.10286 | 0.10286 | 0.0 | 11.30 +Bond | 0.63714 | 0.63714 | 0.63714 | 0.0 | 70.01 +Neigh | 0.013949 | 0.013949 | 0.013949 | 0.0 | 1.53 +Comm | 0.0056606 | 0.0056606 | 0.0056606 | 0.0 | 0.62 +Output | 0.00055825 | 0.00055825 | 0.00055825 | 0.0 | 0.06 +Modify | 0.14629 | 0.14629 | 0.14629 | 0.0 | 16.07 +Other | | 0.003637 | | | 0.40 + +Nlocal: 118 ave 118 max 118 min +Histogram: 1 0 0 0 0 0 0 0 0 0 +Nghost: 372 ave 372 max 372 min +Histogram: 1 0 0 0 0 0 0 0 0 0 +Neighs: 3487 ave 3487 max 3487 min +Histogram: 1 0 0 0 0 0 0 0 0 0 + +Total # of neighbors = 3487 +Ave neighs/atom = 29.550847 +Ave special neighs/atom = 10.576271 +Neighbor list builds = 68 +Dangerous builds = 0 + +# write_restart restart_longrun +# write_data restart_longrun.data nofix +Total wall time: 0:00:01 diff --git a/examples/PACKAGES/reaction/tiny_epoxy/log.4Nov2022.tiny_epoxy.stabilized.g++.4 b/examples/PACKAGES/reaction/tiny_epoxy/log.4Nov2022.tiny_epoxy.stabilized.g++.4 new file mode 100644 index 0000000000..5d1a80405a --- /dev/null +++ b/examples/PACKAGES/reaction/tiny_epoxy/log.4Nov2022.tiny_epoxy.stabilized.g++.4 @@ -0,0 +1,249 @@ +LAMMPS (4 Nov 2022) +# two molecules DGEBA (diepoxy) and one DETA (linker) +# two crosslinking reactions + +units real + +boundary p p p + +atom_style full + +pair_style lj/class2 8 + +angle_style class2 + +bond_style class2 + +dihedral_style class2 + +improper_style class2 + +read_data tiny_epoxy.data +Reading data file ... + orthogonal box = (10 -10 -15) to (30 20 10) + 1 by 2 by 2 MPI processor grid + reading atom labelmap ... + reading bond labelmap ... + reading angle labelmap ... + reading dihedral labelmap ... + reading improper labelmap ... + reading atoms ... + 118 atoms + scanning bonds ... + 4 = max bonds/atom + scanning angles ... + 6 = max angles/atom + scanning dihedrals ... + 18 = max dihedrals/atom + scanning impropers ... + 4 = max impropers/atom + reading bonds ... + 123 bonds + reading angles ... + 221 angles + reading dihedrals ... + 302 dihedrals + reading impropers ... + 115 impropers +Finding 1-2 1-3 1-4 neighbors ... + special bond factors lj: 0 0 0 + special bond factors coul: 0 0 0 + 4 = max # of 1-2 neighbors + 10 = max # of 1-3 neighbors + 19 = max # of 1-4 neighbors + 22 = max # of special neighbors + special bonds CPU = 0.000 seconds + read_data CPU = 0.013 seconds + +velocity all create 300.0 4928459 dist gaussian + +molecule mol1 rxn1_stp1_pre.molecule_template +Read molecule template mol1: + 1 molecules + 0 fragments + 31 atoms with max type 10 + 30 bonds with max type 15 + 53 angles with max type 29 + 66 dihedrals with max type 39 + 3 impropers with max type 5 +molecule mol2 rxn1_stp1_post.molecule_template +Read molecule template mol2: + 1 molecules + 0 fragments + 31 atoms with max type 10 + 30 bonds with max type 17 + 55 angles with max type 36 + 75 dihedrals with max type 51 + 2 impropers with max type 5 +molecule mol3 rxn1_stp2_post.molecule_template +Read molecule template mol3: + 1 molecules + 0 fragments + 31 atoms with max type 11 + 30 bonds with max type 18 + 53 angles with max type 37 + 72 dihedrals with max type 53 + 3 impropers with max type 5 +molecule mol4 rxn2_stp1_pre.molecule_template +Read molecule template mol4: + 1 molecules + 0 fragments + 42 atoms with max type 11 + 41 bonds with max type 18 + 73 angles with max type 41 + 96 dihedrals with max type 54 + 3 impropers with max type 5 +molecule mol5 rxn2_stp1_post.molecule_template +Read molecule template mol5: + 1 molecules + 0 fragments + 42 atoms with max type 11 + 41 bonds with max type 18 + 75 angles with max type 37 + 108 dihedrals with max type 53 + 2 impropers with max type 5 +molecule mol6 rxn2_stp2_post.molecule_template +Read molecule template mol6: + 1 molecules + 0 fragments + 42 atoms with max type 11 + 41 bonds with max type 19 + 73 angles with max type 50 + 102 dihedrals with max type 66 + 3 impropers with max type 22 + +thermo 50 + +# dump 1 all xyz 1 test_vis.xyz + +fix rxns all bond/react stabilization yes statted_grp .03 react rxn1_stp1 all 1 0.0 5 mol1 mol2 rxn1_stp1.map react rxn1_stp2 all 1 0.0 5 mol2 mol3 rxn1_stp2.map react rxn2_stp1 all 1 0.0 5 mol4 mol5 rxn2_stp1.map react rxn2_stp2 all 1 0.0 5 mol5 mol6 rxn2_stp2.map +dynamic group bond_react_MASTER_group defined +dynamic group statted_grp_REACT defined + + +fix 1 statted_grp_REACT nvt temp 300 300 100 + +thermo_style custom step temp f_rxns[1] f_rxns[2] f_rxns[3] f_rxns[4] + +run 2000 + +CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE + +Your simulation uses code contributions which should be cited: + +- fix bond/react: reacter.org doi:10.1016/j.polymer.2017.09.038, doi:10.1021/acs.macromol.0c02012 + +@Article{Gissinger17, + author = {J. R. Gissinger and B. D. Jensen and K. E. Wise}, + title = {Modeling Chemical Reactions in Classical Molecular Dynamics Simulations}, + journal = {Polymer}, + year = 2017, + volume = 128, + pages = {211--217} +} + +@Article{Gissinger20, + author = {J. R. Gissinger, B. D. Jensen, K. E. Wise}, + title = {{REACTER}: A Heuristic Method for Reactive Molecular Dynamics}, + journal = {Macromolecules}, + year = 2020, + volume = 53, + number = 22, + pages = {9953--9961} +} + +CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE + +Generated 55 of 55 mixed pair_coeff terms from sixthpower/geometric mixing rule +Neighbor list info ... + update: every = 1 steps, delay = 0 steps, check = yes + max neighbors/atom: 2000, page size: 100000 + master list distance cutoff = 10 + ghost atom cutoff = 10 + binsize = 5, bins = 4 6 5 + 2 neighbor lists, perpetual/occasional/extra = 1 1 0 + (1) pair lj/class2, perpetual + attributes: half, newton on + pair build: half/bin/newton + stencil: half/bin/3d + bin: standard + (2) fix bond/react, occasional, copy from (1) + attributes: half, newton on + pair build: copy + stencil: none + bin: none +Per MPI rank memory allocation (min/avg/max) = 16.63 | 16.63 | 16.64 Mbytes + Step Temp f_rxns[1] f_rxns[2] f_rxns[3] f_rxns[4] + 0 300 0 0 0 0 + 50 378.29345 1 0 0 0 + 100 471.04152 1 1 0 0 + 150 583.79755 1 1 1 0 + 200 526.00812 1 1 1 1 + 250 429.56812 1 1 1 1 + 300 512.54655 1 1 1 1 + 350 461.18357 1 1 1 1 + 400 379.38965 1 1 1 1 + 450 424.89528 1 1 1 1 + 500 324.72257 1 1 1 1 + 550 302.91042 1 1 1 1 + 600 253.80911 1 1 1 1 + 650 252.90262 1 1 1 1 + 700 270.62628 1 1 1 1 + 750 311.64391 1 1 1 1 + 800 318.9413 1 1 1 1 + 850 354.20196 1 1 1 1 + 900 302.19641 1 1 1 1 + 950 316.97905 1 1 1 1 + 1000 303.08194 1 1 1 1 + 1050 317.51619 1 1 1 1 + 1100 287.57204 1 1 1 1 + 1150 226.72101 1 1 1 1 + 1200 283.97519 1 1 1 1 + 1250 287.0607 1 1 1 1 + 1300 327.65278 1 1 1 1 + 1350 316.06809 1 1 1 1 + 1400 337.69947 1 1 1 1 + 1450 326.12278 1 1 1 1 + 1500 300.89265 1 1 1 1 + 1550 325.2415 1 1 1 1 + 1600 294.1844 1 1 1 1 + 1650 293.98596 1 1 1 1 + 1700 317.35477 1 1 1 1 + 1750 296.97768 1 1 1 1 + 1800 274.97297 1 1 1 1 + 1850 335.36698 1 1 1 1 + 1900 315.3756 1 1 1 1 + 1950 260.65334 1 1 1 1 + 2000 354.03612 1 1 1 1 +Loop time of 0.47159 on 4 procs for 2000 steps with 118 atoms + +Performance: 366.420 ns/day, 0.065 hours/ns, 4240.970 timesteps/s, 500.434 katom-step/s +99.9% CPU use with 4 MPI tasks x no OpenMP threads + +MPI task timing breakdown: +Section | min time | avg time | max time |%varavg| %total +--------------------------------------------------------------- +Pair | 0.016546 | 0.024458 | 0.038858 | 5.5 | 5.19 +Bond | 0.072622 | 0.16458 | 0.21778 | 13.9 | 34.90 +Neigh | 0.0056307 | 0.0056812 | 0.0057292 | 0.1 | 1.20 +Comm | 0.028022 | 0.095922 | 0.19526 | 20.3 | 20.34 +Output | 0.00034591 | 0.00041633 | 0.00062378 | 0.0 | 0.09 +Modify | 0.17613 | 0.17649 | 0.17711 | 0.1 | 37.43 +Other | | 0.00404 | | | 0.86 + +Nlocal: 29.5 ave 45 max 7 min +Histogram: 1 0 0 0 0 0 1 1 0 1 +Nghost: 315 ave 343 max 287 min +Histogram: 1 1 0 0 0 0 0 0 1 1 +Neighs: 871.75 ave 1772 max 236 min +Histogram: 1 0 1 1 0 0 0 0 0 1 + +Total # of neighbors = 3487 +Ave neighs/atom = 29.550847 +Ave special neighs/atom = 10.576271 +Neighbor list builds = 68 +Dangerous builds = 0 + +# write_restart restart_longrun +# write_data restart_longrun.data nofix +Total wall time: 0:00:00 diff --git a/examples/PACKAGES/reaction/tiny_epoxy/rxn1_stp1_post.data_template b/examples/PACKAGES/reaction/tiny_epoxy/rxn1_stp1_post.data_template deleted file mode 100644 index e510883432..0000000000 --- a/examples/PACKAGES/reaction/tiny_epoxy/rxn1_stp1_post.data_template +++ /dev/null @@ -1,315 +0,0 @@ -rxn1_stp1_post - -31 atoms -30 bonds -55 angles -75 dihedrals -34 impropers - -Types - -1 1 -2 6 -3 1 -4 7 -5 4 -6 7 -7 8 -8 8 -9 8 -10 8 -11 8 -12 9 -13 1 -14 1 -15 9 -16 9 -17 1 -18 1 -19 10 -20 8 -21 8 -22 8 -23 8 -24 10 -25 10 -26 10 -27 10 -28 8 -29 8 -30 8 -31 8 - -Charges - -1 0.000000 -2 0.000000 -3 0.000000 -4 0.100000 -5 0.000000 -6 0.000000 -7 0.000000 -8 0.000000 -9 0.000000 -10 0.000000 -11 0.000000 -12 0.000000 -13 0.000000 -14 0.000000 -15 -0.025000 -16 -0.025000 -17 0.000000 -18 0.000000 -19 0.000000 -20 0.000000 -21 0.000000 -22 0.000000 -23 0.000000 -24 0.000000 -25 0.000000 -26 0.000000 -27 0.000000 -28 0.000000 -29 0.000000 -30 0.000000 -31 0.000000 - -Coords - -1 22.582573 10.988183 -5.014054 -2 23.904713 10.750493 -4.202215 -3 23.989172 9.487042 -3.323374 -4 24.067001 11.723383 -4.037435 -5 24.627851 7.325302 -3.319944 -6 24.554632 8.418972 -4.080365 -7 22.667763 11.445703 -5.999605 -8 21.787441 10.247643 -4.916974 -9 24.964962 10.712683 -4.449374 -10 24.616703 9.689913 -2.456034 -11 22.989313 9.208153 -2.991455 -12 18.808882 13.758042 -3.958724 -13 19.293213 12.549683 -3.196594 -14 20.810543 12.417832 -3.417504 -15 21.090193 12.251203 -4.891234 -16 17.657042 16.437199 -3.985224 -17 19.126713 16.210239 -4.245154 -18 19.589151 14.957593 -3.479565 -19 19.000433 13.609432 -5.041715 -20 18.761223 11.614392 -3.573184 -21 19.082903 12.688992 -2.085145 -22 21.202852 11.511562 -2.848624 -23 21.328482 13.360252 -3.038924 -24 19.949852 12.199403 -5.680355 -25 21.477343 13.247442 -5.445915 -26 17.080341 15.555528 -4.334374 -27 17.319832 17.341927 -4.532204 -28 19.720472 17.115158 -3.887564 -29 19.298622 16.058659 -5.361685 -30 19.410772 15.105113 -2.363724 -31 20.700163 14.782252 -3.666344 - -Bonds - -1 1 1 8 -2 16 1 2 -3 1 1 7 -4 13 1 15 -5 16 3 2 -6 12 2 9 -7 17 2 4 -8 3 3 6 -9 1 3 10 -10 1 3 11 -11 8 6 5 -12 13 13 12 -13 13 18 12 -14 14 12 19 -15 15 13 14 -16 1 13 20 -17 1 13 21 -18 13 14 15 -19 1 14 22 -20 1 14 23 -21 14 15 24 -22 14 15 25 -23 13 17 16 -24 14 16 26 -25 14 16 27 -26 15 17 18 -27 1 17 28 -28 1 17 29 -29 1 18 30 -30 1 18 31 - -Angles - -1 30 2 1 8 -2 2 8 1 7 -3 26 8 1 15 -4 30 2 1 7 -5 31 2 1 15 -6 26 7 1 15 -7 32 1 2 3 -8 33 1 2 9 -9 34 1 2 4 -10 33 3 2 9 -11 34 3 2 4 -12 35 4 2 9 -13 36 2 3 6 -14 30 2 3 10 -15 30 2 3 11 -16 3 6 3 10 -17 3 6 3 11 -18 2 10 3 11 -19 22 3 6 5 -20 23 13 12 18 -21 24 13 12 19 -22 24 18 12 19 -23 25 14 13 12 -24 26 20 13 12 -25 26 21 13 12 -26 27 14 13 20 -27 27 14 13 21 -28 2 20 13 21 -29 25 13 14 15 -30 27 13 14 22 -31 27 13 14 23 -32 26 22 14 15 -33 26 23 14 15 -34 2 22 14 23 -35 23 1 15 14 -36 24 1 15 24 -37 24 1 15 25 -38 24 14 15 24 -39 24 14 15 25 -40 28 24 15 25 -41 24 17 16 26 -42 24 17 16 27 -43 28 26 16 27 -44 25 18 17 16 -45 26 28 17 16 -46 26 29 17 16 -47 27 18 17 28 -48 27 18 17 29 -49 2 28 17 29 -50 25 17 18 12 -51 26 30 18 12 -52 26 31 18 12 -53 27 17 18 30 -54 27 17 18 31 -55 2 30 18 31 - -Dihedrals - -1 40 8 1 2 3 -2 41 8 1 2 9 -3 42 8 1 2 4 -4 40 7 1 2 3 -5 41 7 1 2 9 -6 42 7 1 2 4 -7 43 15 1 2 3 -8 44 15 1 2 9 -9 45 15 1 2 4 -10 28 8 1 15 14 -11 30 8 1 15 24 -12 30 8 1 15 25 -13 46 2 1 15 14 -14 47 2 1 15 24 -15 47 2 1 15 25 -16 28 7 1 15 14 -17 30 7 1 15 24 -18 30 7 1 15 25 -19 48 6 3 2 1 -20 40 10 3 2 1 -21 40 11 3 2 1 -22 49 6 3 2 9 -23 41 10 3 2 9 -24 41 11 3 2 9 -25 50 6 3 2 4 -26 42 10 3 2 4 -27 42 11 3 2 4 -28 51 2 3 6 5 -29 7 10 3 6 5 -30 7 11 3 6 5 -31 27 14 13 12 18 -32 28 20 13 12 18 -33 28 21 13 12 18 -34 29 14 13 12 19 -35 30 20 13 12 19 -36 30 21 13 12 19 -37 27 17 18 12 13 -38 28 30 18 12 13 -39 28 31 18 12 13 -40 29 17 18 12 19 -41 30 30 18 12 19 -42 30 31 18 12 19 -43 31 12 13 14 15 -44 32 22 14 13 12 -45 32 23 14 13 12 -46 32 20 13 14 15 -47 33 20 13 14 22 -48 33 20 13 14 23 -49 32 21 13 14 15 -50 33 21 13 14 22 -51 33 21 13 14 23 -52 27 13 14 15 1 -53 29 13 14 15 24 -54 29 13 14 15 25 -55 28 22 14 15 1 -56 30 22 14 15 24 -57 30 22 14 15 25 -58 28 23 14 15 1 -59 30 23 14 15 24 -60 30 23 14 15 25 -61 29 18 17 16 26 -62 30 28 17 16 26 -63 30 29 17 16 26 -64 29 18 17 16 27 -65 30 28 17 16 27 -66 30 29 17 16 27 -67 31 16 17 18 12 -68 32 30 18 17 16 -69 32 31 18 17 16 -70 32 28 17 18 12 -71 33 28 17 18 30 -72 33 28 17 18 31 -73 32 29 17 18 12 -74 33 29 17 18 30 -75 33 29 17 18 31 - -Impropers - -1 4 13 12 18 19 -2 5 17 16 26 27 -3 1 2 1 8 7 -4 1 2 1 8 15 -5 1 8 1 7 15 -6 1 2 1 7 15 -7 1 1 2 3 9 -8 1 1 2 3 4 -9 1 1 2 4 9 -10 1 3 2 4 9 -11 1 2 3 6 10 -12 1 2 3 6 11 -13 1 2 3 10 11 -14 1 6 3 10 11 -15 1 14 13 20 12 -16 1 14 13 21 12 -17 1 20 13 21 12 -18 1 14 13 20 21 -19 1 13 14 22 15 -20 1 13 14 23 15 -21 1 13 14 22 23 -22 1 22 14 23 15 -23 1 1 15 14 24 -24 1 1 15 14 25 -25 1 1 15 24 25 -26 1 14 15 24 25 -27 1 18 17 28 16 -28 1 18 17 29 16 -29 1 28 17 29 16 -30 1 18 17 28 29 -31 1 17 18 30 12 -32 1 17 18 31 12 -33 1 30 18 31 12 -34 1 17 18 30 31 diff --git a/examples/PACKAGES/reaction/tiny_epoxy/rxn1_stp1_post.molecule_template b/examples/PACKAGES/reaction/tiny_epoxy/rxn1_stp1_post.molecule_template new file mode 100644 index 0000000000..4db26814c5 --- /dev/null +++ b/examples/PACKAGES/reaction/tiny_epoxy/rxn1_stp1_post.molecule_template @@ -0,0 +1,317 @@ +rxn1_stp1_post + + 31 atoms + 30 bonds + 55 angles + 75 dihedrals + 2 impropers + +Coords + + 1 22.582572937 10.988183022 -5.014054298 + 2 23.904712677 10.750493050 -4.202214718 + 3 23.989171982 9.487042427 -3.323374271 + 4 24.067001343 11.723382950 -4.037434578 + 5 24.627851486 7.325302124 -3.319944382 + 6 24.554632187 8.418972015 -4.080364704 + 7 22.667762756 11.445702553 -5.999605179 + 8 21.787441254 10.247642517 -4.916974068 + 9 24.964962006 10.712682724 -4.449374199 + 10 24.616703033 9.689912796 -2.456034422 + 11 22.989313126 9.208152771 -2.991454601 + 12 18.808881760 13.758042336 -3.958724499 + 13 19.293212891 12.549682617 -3.196594477 + 14 20.810543060 12.417832375 -3.417504311 + 15 21.090192795 12.251202583 -4.891234398 + 16 17.657041550 16.437198639 -3.985224247 + 17 19.126712799 16.210239410 -4.245154381 + 18 19.589151382 14.957592964 -3.479564667 + 19 19.000432968 13.609432220 -5.041714668 + 20 18.761222839 11.614392281 -3.573184490 + 21 19.082902908 12.688992500 -2.085144520 + 22 21.202852249 11.511562347 -2.848624468 + 23 21.328481674 13.360252380 -3.038924456 + 24 19.949851990 12.199402809 -5.680355072 + 25 21.477342606 13.247442245 -5.445915222 + 26 17.080341339 15.555527687 -4.334374428 + 27 17.319831848 17.341926575 -4.532204151 + 28 19.720472336 17.115158081 -3.887564182 + 29 19.298622131 16.058658600 -5.361684799 + 30 19.410772324 15.105113029 -2.363724470 + 31 20.700162888 14.782252312 -3.666344166 + +Types + + 1 c2 + 2 c3 + 3 c2 + 4 oc + 5 cp + 6 oc + 7 hc + 8 hc + 9 hc + 10 hc + 11 hc + 12 na + 13 c2 + 14 c2 + 15 na + 16 na + 17 c2 + 18 c2 + 19 hn + 20 hc + 21 hc + 22 hc + 23 hc + 24 hn + 25 hn + 26 hn + 27 hn + 28 hc + 29 hc + 30 hc + 31 hc + +Charges + + 1 0.000000 + 2 0.000000 + 3 0.000000 + 4 0.100000 + 5 0.000000 + 6 0.000000 + 7 0.000000 + 8 0.000000 + 9 0.000000 + 10 0.000000 + 11 0.000000 + 12 0.000000 + 13 0.000000 + 14 0.000000 + 15 -0.025000 + 16 -0.025000 + 17 0.000000 + 18 0.000000 + 19 0.000000 + 20 0.000000 + 21 0.000000 + 22 0.000000 + 23 0.000000 + 24 0.000000 + 25 0.000000 + 26 0.000000 + 27 0.000000 + 28 0.000000 + 29 0.000000 + 30 0.000000 + 31 0.000000 + +Molecules + + 1 1 + 2 1 + 3 1 + 4 1 + 5 1 + 6 1 + 7 1 + 8 1 + 9 1 + 10 1 + 11 1 + 12 1 + 13 1 + 14 1 + 15 1 + 16 1 + 17 1 + 18 1 + 19 1 + 20 1 + 21 1 + 22 1 + 23 1 + 24 1 + 25 1 + 26 1 + 27 1 + 28 1 + 29 1 + 30 1 + 31 1 + +Bonds + + 1 c2-hc 1 8 + 2 c2-c3 1 2 + 3 c2-hc 1 7 + 4 c2-na 1 15 + 5 c2-c3 3 2 + 6 c3-hc 2 9 + 7 c3-oc 2 4 + 8 c2-oc 3 6 + 9 c2-hc 3 10 + 10 c2-hc 3 11 + 11 cp-oc 6 5 + 12 c2-na 13 12 + 13 c2-na 18 12 + 14 na-hn 12 19 + 15 c2-c2 13 14 + 16 c2-hc 13 20 + 17 c2-hc 13 21 + 18 c2-na 14 15 + 19 c2-hc 14 22 + 20 c2-hc 14 23 + 21 na-hn 15 24 + 22 na-hn 15 25 + 23 c2-na 17 16 + 24 na-hn 16 26 + 25 na-hn 16 27 + 26 c2-c2 17 18 + 27 c2-hc 17 28 + 28 c2-hc 17 29 + 29 c2-hc 18 30 + 30 c2-hc 18 31 + +Angles + + 1 c3-c2-hc 2 1 8 + 2 hc-c2-hc 8 1 7 + 3 hc-c2-na 8 1 15 + 4 c3-c2-hc 2 1 7 + 5 c3-c2-na 2 1 15 + 6 hc-c2-na 7 1 15 + 7 c2-c3-c2 1 2 3 + 8 c2-c3-hc 1 2 9 + 9 c2-c3-oc 1 2 4 + 10 c2-c3-hc 3 2 9 + 11 c2-c3-oc 3 2 4 + 12 oc-c3-hc 4 2 9 + 13 c3-c2-oc 2 3 6 + 14 c3-c2-hc 2 3 10 + 15 c3-c2-hc 2 3 11 + 16 oc-c2-hc 6 3 10 + 17 oc-c2-hc 6 3 11 + 18 hc-c2-hc 10 3 11 + 19 c2-oc-cp 3 6 5 + 20 c2-na-c2 13 12 18 + 21 c2-na-hn 13 12 19 + 22 c2-na-hn 18 12 19 + 23 c2-c2-na 14 13 12 + 24 hc-c2-na 20 13 12 + 25 hc-c2-na 21 13 12 + 26 c2-c2-hc 14 13 20 + 27 c2-c2-hc 14 13 21 + 28 hc-c2-hc 20 13 21 + 29 c2-c2-na 13 14 15 + 30 c2-c2-hc 13 14 22 + 31 c2-c2-hc 13 14 23 + 32 hc-c2-na 22 14 15 + 33 hc-c2-na 23 14 15 + 34 hc-c2-hc 22 14 23 + 35 c2-na-c2 1 15 14 + 36 c2-na-hn 1 15 24 + 37 c2-na-hn 1 15 25 + 38 c2-na-hn 14 15 24 + 39 c2-na-hn 14 15 25 + 40 hn-na-hn 24 15 25 + 41 c2-na-hn 17 16 26 + 42 c2-na-hn 17 16 27 + 43 hn-na-hn 26 16 27 + 44 c2-c2-na 18 17 16 + 45 hc-c2-na 28 17 16 + 46 hc-c2-na 29 17 16 + 47 c2-c2-hc 18 17 28 + 48 c2-c2-hc 18 17 29 + 49 hc-c2-hc 28 17 29 + 50 c2-c2-na 17 18 12 + 51 hc-c2-na 30 18 12 + 52 hc-c2-na 31 18 12 + 53 c2-c2-hc 17 18 30 + 54 c2-c2-hc 17 18 31 + 55 hc-c2-hc 30 18 31 + +Dihedrals + + 1 hc-c2-c3-c2 8 1 2 3 + 2 hc-c2-c3-hc 8 1 2 9 + 3 hc-c2-c3-oc 8 1 2 4 + 4 hc-c2-c3-c2 7 1 2 3 + 5 hc-c2-c3-hc 7 1 2 9 + 6 hc-c2-c3-oc 7 1 2 4 + 7 na-c2-c3-c2 15 1 2 3 + 8 na-c2-c3-hc 15 1 2 9 + 9 na-c2-c3-oc 15 1 2 4 + 10 hc-c2-na-c2 8 1 15 14 + 11 hc-c2-na-hn 8 1 15 24 + 12 hc-c2-na-hn 8 1 15 25 + 13 c3-c2-na-c2 2 1 15 14 + 14 c3-c2-na-hn 2 1 15 24 + 15 c3-c2-na-hn 2 1 15 25 + 16 hc-c2-na-c2 7 1 15 14 + 17 hc-c2-na-hn 7 1 15 24 + 18 hc-c2-na-hn 7 1 15 25 + 19 oc-c2-c3-c2 6 3 2 1 + 20 hc-c2-c3-c2 10 3 2 1 + 21 hc-c2-c3-c2 11 3 2 1 + 22 oc-c2-c3-hc 6 3 2 9 + 23 hc-c2-c3-hc 10 3 2 9 + 24 hc-c2-c3-hc 11 3 2 9 + 25 oc-c2-c3-oc 6 3 2 4 + 26 hc-c2-c3-oc 10 3 2 4 + 27 hc-c2-c3-oc 11 3 2 4 + 28 c3-c2-oc-cp 2 3 6 5 + 29 hc-c2-oc-cp 10 3 6 5 + 30 hc-c2-oc-cp 11 3 6 5 + 31 c2-c2-na-c2 14 13 12 18 + 32 hc-c2-na-c2 20 13 12 18 + 33 hc-c2-na-c2 21 13 12 18 + 34 c2-c2-na-hn 14 13 12 19 + 35 hc-c2-na-hn 20 13 12 19 + 36 hc-c2-na-hn 21 13 12 19 + 37 c2-c2-na-c2 17 18 12 13 + 38 hc-c2-na-c2 30 18 12 13 + 39 hc-c2-na-c2 31 18 12 13 + 40 c2-c2-na-hn 17 18 12 19 + 41 hc-c2-na-hn 30 18 12 19 + 42 hc-c2-na-hn 31 18 12 19 + 43 na-c2-c2-na 12 13 14 15 + 44 hc-c2-c2-na 22 14 13 12 + 45 hc-c2-c2-na 23 14 13 12 + 46 hc-c2-c2-na 20 13 14 15 + 47 hc-c2-c2-hc 20 13 14 22 + 48 hc-c2-c2-hc 20 13 14 23 + 49 hc-c2-c2-na 21 13 14 15 + 50 hc-c2-c2-hc 21 13 14 22 + 51 hc-c2-c2-hc 21 13 14 23 + 52 c2-c2-na-c2 13 14 15 1 + 53 c2-c2-na-hn 13 14 15 24 + 54 c2-c2-na-hn 13 14 15 25 + 55 hc-c2-na-c2 22 14 15 1 + 56 hc-c2-na-hn 22 14 15 24 + 57 hc-c2-na-hn 22 14 15 25 + 58 hc-c2-na-c2 23 14 15 1 + 59 hc-c2-na-hn 23 14 15 24 + 60 hc-c2-na-hn 23 14 15 25 + 61 c2-c2-na-hn 18 17 16 26 + 62 hc-c2-na-hn 28 17 16 26 + 63 hc-c2-na-hn 29 17 16 26 + 64 c2-c2-na-hn 18 17 16 27 + 65 hc-c2-na-hn 28 17 16 27 + 66 hc-c2-na-hn 29 17 16 27 + 67 na-c2-c2-na 16 17 18 12 + 68 hc-c2-c2-na 30 18 17 16 + 69 hc-c2-c2-na 31 18 17 16 + 70 hc-c2-c2-na 28 17 18 12 + 71 hc-c2-c2-hc 28 17 18 30 + 72 hc-c2-c2-hc 28 17 18 31 + 73 hc-c2-c2-na 29 17 18 12 + 74 hc-c2-c2-hc 29 17 18 30 + 75 hc-c2-c2-hc 29 17 18 31 + +Impropers + + 1 c2-na-c2-hn 13 12 18 19 + 2 c2-na-hn-hn 17 16 26 27 diff --git a/examples/PACKAGES/reaction/tiny_epoxy/rxn1_stp1_pre.data_template b/examples/PACKAGES/reaction/tiny_epoxy/rxn1_stp1_pre.data_template deleted file mode 100644 index dd767a4cba..0000000000 --- a/examples/PACKAGES/reaction/tiny_epoxy/rxn1_stp1_pre.data_template +++ /dev/null @@ -1,301 +0,0 @@ -rxn1_stp1_pre - -31 atoms -30 bonds -53 angles -66 dihedrals -31 impropers - -Types - -1 2 -2 2 -3 1 -4 3 -5 4 -6 7 -7 8 -8 8 -9 8 -10 8 -11 8 -12 9 -13 1 -14 1 -15 9 -16 9 -17 1 -18 1 -19 10 -20 8 -21 8 -22 8 -23 8 -24 10 -25 10 -26 10 -27 10 -28 8 -29 8 -30 8 -31 8 - -Charges - -1 0.000000 -2 0.000000 -3 0.000000 -4 0.100000 -5 0.000000 -6 0.000000 -7 0.000000 -8 0.000000 -9 0.000000 -10 0.000000 -11 0.000000 -12 0.000000 -13 0.000000 -14 0.000000 -15 -0.025000 -16 -0.025000 -17 0.000000 -18 0.000000 -19 0.000000 -20 0.000000 -21 0.000000 -22 0.000000 -23 0.000000 -24 0.000000 -25 0.000000 -26 0.000000 -27 0.000000 -28 0.000000 -29 0.000000 -30 0.000000 -31 0.000000 - -Coords - -1 19.846882 9.569666 -1.229588 -2 21.168802 9.331466 -0.418038 -3 21.253012 8.067936 0.460722 -4 20.170443 10.460656 0.020692 -5 21.891691 5.906196 0.464152 -6 21.818472 6.999866 -0.296268 -7 19.932211 10.027435 -2.215008 -8 19.051722 8.829116 -1.132808 -9 22.229073 9.293536 -0.665088 -10 21.880442 8.270676 1.328162 -11 20.253073 7.789126 0.792482 -12 16.072590 12.338870 -0.174330 -13 16.557261 11.130320 0.587290 -14 18.074570 10.998810 0.366080 -15 18.353970 10.832370 -1.107720 -16 14.920720 15.017820 -0.200530 -17 16.390430 14.791100 -0.460440 -18 16.852980 13.538320 0.304870 -19 16.263750 12.190560 -1.257430 -20 16.025360 10.195070 0.210470 -21 16.347120 11.269210 1.698830 -22 18.467180 10.092570 0.934800 -23 18.592390 11.941300 0.744640 -24 17.843861 9.919930 -1.479780 -25 19.448191 10.736480 -1.267520 -26 14.344120 14.136250 -0.550130 -27 14.583470 15.922760 -0.747140 -28 16.984060 15.696010 -0.102600 -29 16.562420 14.639820 -1.577000 -30 16.674820 13.685670 1.420760 -31 17.963949 13.362980 0.117850 - -Bonds - -1 6 1 8 -2 4 1 4 -3 5 1 2 -4 6 1 7 -5 4 2 4 -6 2 2 3 -7 6 2 9 -8 3 3 6 -9 1 3 10 -10 1 3 11 -11 8 5 6 -12 13 13 12 -13 13 18 12 -14 14 12 19 -15 15 13 14 -16 1 13 20 -17 1 13 21 -18 13 14 15 -19 1 14 22 -20 1 14 23 -21 14 15 24 -22 14 15 25 -23 13 17 16 -24 14 16 26 -25 14 16 27 -26 15 17 18 -27 1 17 28 -28 1 17 29 -29 1 18 30 -30 1 18 31 - -Angles - -1 9 4 1 8 -2 10 2 1 8 -3 11 8 1 7 -4 8 2 1 4 -5 9 4 1 7 -6 10 2 1 7 -7 8 1 2 4 -8 29 1 2 3 -9 10 1 2 9 -10 5 3 2 4 -11 9 4 2 9 -12 7 3 2 9 -13 4 2 3 6 -14 1 2 3 10 -15 1 2 3 11 -16 3 6 3 10 -17 3 6 3 11 -18 2 10 3 11 -19 12 1 4 2 -20 22 3 6 5 -21 23 13 12 18 -22 24 13 12 19 -23 24 18 12 19 -24 25 14 13 12 -25 26 20 13 12 -26 26 21 13 12 -27 27 14 13 20 -28 27 14 13 21 -29 2 20 13 21 -30 25 13 14 15 -31 27 13 14 22 -32 27 13 14 23 -33 26 22 14 15 -34 26 23 14 15 -35 2 22 14 23 -36 24 14 15 24 -37 24 14 15 25 -38 28 24 15 25 -39 24 17 16 26 -40 24 17 16 27 -41 28 26 16 27 -42 25 18 17 16 -43 26 28 17 16 -44 26 29 17 16 -45 27 18 17 28 -46 27 18 17 29 -47 2 28 17 29 -48 25 17 18 12 -49 26 30 18 12 -50 26 31 18 12 -51 27 17 18 30 -52 27 17 18 31 -53 2 30 18 31 - -Dihedrals - -1 10 8 1 4 2 -2 10 7 1 4 2 -3 13 4 2 1 8 -4 12 3 2 1 8 -5 14 8 1 2 9 -6 11 3 2 1 4 -7 13 4 1 2 9 -8 13 4 2 1 7 -9 12 3 2 1 7 -10 14 7 1 2 9 -11 9 3 2 4 1 -12 10 9 2 4 1 -13 34 1 2 3 6 -14 35 1 2 3 10 -15 35 1 2 3 11 -16 36 4 2 3 6 -17 37 4 2 3 10 -18 37 4 2 3 11 -19 38 9 2 3 6 -20 39 9 2 3 10 -21 39 9 2 3 11 -22 8 2 3 6 5 -23 7 10 3 6 5 -24 7 11 3 6 5 -25 27 14 13 12 18 -26 28 20 13 12 18 -27 28 21 13 12 18 -28 29 14 13 12 19 -29 30 20 13 12 19 -30 30 21 13 12 19 -31 27 17 18 12 13 -32 28 30 18 12 13 -33 28 31 18 12 13 -34 29 17 18 12 19 -35 30 30 18 12 19 -36 30 31 18 12 19 -37 31 12 13 14 15 -38 32 22 14 13 12 -39 32 23 14 13 12 -40 32 20 13 14 15 -41 33 20 13 14 22 -42 33 20 13 14 23 -43 32 21 13 14 15 -44 33 21 13 14 22 -45 33 21 13 14 23 -46 29 13 14 15 24 -47 29 13 14 15 25 -48 30 22 14 15 24 -49 30 22 14 15 25 -50 30 23 14 15 24 -51 30 23 14 15 25 -52 29 18 17 16 26 -53 30 28 17 16 26 -54 30 29 17 16 26 -55 29 18 17 16 27 -56 30 28 17 16 27 -57 30 29 17 16 27 -58 31 16 17 18 12 -59 32 30 18 17 16 -60 32 31 18 17 16 -61 32 28 17 18 12 -62 33 28 17 18 30 -63 33 28 17 18 31 -64 32 29 17 18 12 -65 33 29 17 18 30 -66 33 29 17 18 31 - -Impropers - -1 4 13 12 18 19 -2 5 14 15 24 25 -3 5 17 16 26 27 -4 1 2 1 4 8 -5 1 4 1 8 7 -6 1 2 1 8 7 -7 1 2 1 4 7 -8 1 1 2 3 4 -9 1 1 2 4 9 -10 1 1 2 3 9 -11 1 3 2 4 9 -12 1 2 3 6 10 -13 1 2 3 6 11 -14 1 2 3 10 11 -15 1 6 3 10 11 -16 1 14 13 20 12 -17 1 14 13 21 12 -18 1 20 13 21 12 -19 1 14 13 20 21 -20 1 13 14 22 15 -21 1 13 14 23 15 -22 1 13 14 22 23 -23 1 22 14 23 15 -24 1 18 17 28 16 -25 1 18 17 29 16 -26 1 28 17 29 16 -27 1 18 17 28 29 -28 1 17 18 30 12 -29 1 17 18 31 12 -30 1 30 18 31 12 -31 1 17 18 30 31 diff --git a/examples/PACKAGES/reaction/tiny_epoxy/rxn1_stp1_pre.molecule_template b/examples/PACKAGES/reaction/tiny_epoxy/rxn1_stp1_pre.molecule_template new file mode 100644 index 0000000000..35d308c797 --- /dev/null +++ b/examples/PACKAGES/reaction/tiny_epoxy/rxn1_stp1_pre.molecule_template @@ -0,0 +1,307 @@ +rxn1_stp1_pre + + 31 atoms + 30 bonds + 53 angles + 66 dihedrals + 3 impropers + +Coords + + 1 19.846881866 9.569665909 -1.229588389 + 2 21.168802261 9.331465721 -0.418038189 + 3 21.253011703 8.067935944 0.460721821 + 4 20.170442581 10.460656166 0.020691812 + 5 21.891691208 5.906195641 0.464151829 + 6 21.818471909 6.999865532 -0.296268165 + 7 19.932210922 10.027435303 -2.215008259 + 8 19.051721573 8.829115868 -1.132808328 + 9 22.229072571 9.293536186 -0.665088177 + 10 21.880441666 8.270675659 1.328161597 + 11 20.253072739 7.789125919 0.792481780 + 12 16.072589874 12.338870049 -0.174329996 + 13 16.557260513 11.130319595 0.587289989 + 14 18.074569702 10.998809814 0.366079986 + 15 18.353969574 10.832369804 -1.107720017 + 16 14.920720100 15.017820358 -0.200529993 + 17 16.390430450 14.791099548 -0.460440010 + 18 16.852979660 13.538319588 0.304870009 + 19 16.263750076 12.190560341 -1.257429957 + 20 16.025360107 10.195070267 0.210470006 + 21 16.347120285 11.269209862 1.698830009 + 22 18.467180252 10.092570305 0.934800029 + 23 18.592390060 11.941300392 0.744639993 + 24 17.843860626 9.919930458 -1.479779959 + 25 19.448190689 10.736479759 -1.267519951 + 26 14.344120026 14.136249542 -0.550130010 + 27 14.583470345 15.922760010 -0.747139990 + 28 16.984060287 15.696009636 -0.102600001 + 29 16.562419891 14.639820099 -1.577000022 + 30 16.674819946 13.685669899 1.420760036 + 31 17.963949203 13.362979889 0.117849998 + +Types + + 1 c3m + 2 c3m + 3 c2 + 4 o3e + 5 cp + 6 oc + 7 hc + 8 hc + 9 hc + 10 hc + 11 hc + 12 na + 13 c2 + 14 c2 + 15 na + 16 na + 17 c2 + 18 c2 + 19 hn + 20 hc + 21 hc + 22 hc + 23 hc + 24 hn + 25 hn + 26 hn + 27 hn + 28 hc + 29 hc + 30 hc + 31 hc + +Charges + + 1 0.000000 + 2 0.000000 + 3 0.000000 + 4 0.100000 + 5 0.000000 + 6 0.000000 + 7 0.000000 + 8 0.000000 + 9 0.000000 + 10 0.000000 + 11 0.000000 + 12 0.000000 + 13 0.000000 + 14 0.000000 + 15 -0.025000 + 16 -0.025000 + 17 0.000000 + 18 0.000000 + 19 0.000000 + 20 0.000000 + 21 0.000000 + 22 0.000000 + 23 0.000000 + 24 0.000000 + 25 0.000000 + 26 0.000000 + 27 0.000000 + 28 0.000000 + 29 0.000000 + 30 0.000000 + 31 0.000000 + +Molecules + + 1 1 + 2 1 + 3 1 + 4 1 + 5 1 + 6 1 + 7 1 + 8 1 + 9 1 + 10 1 + 11 1 + 12 1 + 13 1 + 14 1 + 15 1 + 16 1 + 17 1 + 18 1 + 19 1 + 20 1 + 21 1 + 22 1 + 23 1 + 24 1 + 25 1 + 26 1 + 27 1 + 28 1 + 29 1 + 30 1 + 31 1 + +Bonds + + 1 c3m-hc 1 8 + 2 c3m-o3e 1 4 + 3 c3m-c3m 1 2 + 4 c3m-hc 1 7 + 5 c3m-o3e 2 4 + 6 c3m-c2 2 3 + 7 c3m-hc 2 9 + 8 c2-oc 3 6 + 9 c2-hc 3 10 + 10 c2-hc 3 11 + 11 cp-oc 5 6 + 12 c2-na 13 12 + 13 c2-na 18 12 + 14 na-hn 12 19 + 15 c2-c2 13 14 + 16 c2-hc 13 20 + 17 c2-hc 13 21 + 18 c2-na 14 15 + 19 c2-hc 14 22 + 20 c2-hc 14 23 + 21 na-hn 15 24 + 22 na-hn 15 25 + 23 c2-na 17 16 + 24 na-hn 16 26 + 25 na-hn 16 27 + 26 c2-c2 17 18 + 27 c2-hc 17 28 + 28 c2-hc 17 29 + 29 c2-hc 18 30 + 30 c2-hc 18 31 + +Angles + + 1 o3e-c3m-hc 4 1 8 + 2 c3m-c3m-hc 2 1 8 + 3 hc-c3m-hc 8 1 7 + 4 c3m-c3m-o3e 2 1 4 + 5 o3e-c3m-hc 4 1 7 + 6 c3m-c3m-hc 2 1 7 + 7 c3m-c3m-o3e 1 2 4 + 8 c3m-c3m-c2 1 2 3 + 9 c3m-c3m-hc 1 2 9 + 10 c2-c3m-o3e 3 2 4 + 11 o3e-c3m-hc 4 2 9 + 12 c2-c3m-hc 3 2 9 + 13 c3m-c2-oc 2 3 6 + 14 c3m-c2-hc 2 3 10 + 15 c3m-c2-hc 2 3 11 + 16 oc-c2-hc 6 3 10 + 17 oc-c2-hc 6 3 11 + 18 hc-c2-hc 10 3 11 + 19 c3m-o3e-c3m 1 4 2 + 20 c2-oc-cp 3 6 5 + 21 c2-na-c2 13 12 18 + 22 c2-na-hn 13 12 19 + 23 c2-na-hn 18 12 19 + 24 c2-c2-na 14 13 12 + 25 hc-c2-na 20 13 12 + 26 hc-c2-na 21 13 12 + 27 c2-c2-hc 14 13 20 + 28 c2-c2-hc 14 13 21 + 29 hc-c2-hc 20 13 21 + 30 c2-c2-na 13 14 15 + 31 c2-c2-hc 13 14 22 + 32 c2-c2-hc 13 14 23 + 33 hc-c2-na 22 14 15 + 34 hc-c2-na 23 14 15 + 35 hc-c2-hc 22 14 23 + 36 c2-na-hn 14 15 24 + 37 c2-na-hn 14 15 25 + 38 hn-na-hn 24 15 25 + 39 c2-na-hn 17 16 26 + 40 c2-na-hn 17 16 27 + 41 hn-na-hn 26 16 27 + 42 c2-c2-na 18 17 16 + 43 hc-c2-na 28 17 16 + 44 hc-c2-na 29 17 16 + 45 c2-c2-hc 18 17 28 + 46 c2-c2-hc 18 17 29 + 47 hc-c2-hc 28 17 29 + 48 c2-c2-na 17 18 12 + 49 hc-c2-na 30 18 12 + 50 hc-c2-na 31 18 12 + 51 c2-c2-hc 17 18 30 + 52 c2-c2-hc 17 18 31 + 53 hc-c2-hc 30 18 31 + +Dihedrals + + 1 hc-c3m-o3e-c3m 8 1 4 2 + 2 hc-c3m-o3e-c3m 7 1 4 2 + 3 o3e-c3m-c3m-hc 4 2 1 8 + 4 c2-c3m-c3m-hc 3 2 1 8 + 5 hc-c3m-c3m-hc 8 1 2 9 + 6 c2-c3m-c3m-o3e 3 2 1 4 + 7 o3e-c3m-c3m-hc 4 1 2 9 + 8 o3e-c3m-c3m-hc 4 2 1 7 + 9 c2-c3m-c3m-hc 3 2 1 7 + 10 hc-c3m-c3m-hc 7 1 2 9 + 11 c2-c3m-o3e-c3m 3 2 4 1 + 12 hc-c3m-o3e-c3m 9 2 4 1 + 13 c3m-c3m-c2-oc 1 2 3 6 + 14 c3m-c3m-c2-hc 1 2 3 10 + 15 c3m-c3m-c2-hc 1 2 3 11 + 16 o3e-c3m-c2-oc 4 2 3 6 + 17 o3e-c3m-c2-hc 4 2 3 10 + 18 o3e-c3m-c2-hc 4 2 3 11 + 19 hc-c3m-c2-oc 9 2 3 6 + 20 hc-c3m-c2-hc 9 2 3 10 + 21 hc-c3m-c2-hc 9 2 3 11 + 22 c3m-c2-oc-cp 2 3 6 5 + 23 hc-c2-oc-cp 10 3 6 5 + 24 hc-c2-oc-cp 11 3 6 5 + 25 c2-c2-na-c2 14 13 12 18 + 26 hc-c2-na-c2 20 13 12 18 + 27 hc-c2-na-c2 21 13 12 18 + 28 c2-c2-na-hn 14 13 12 19 + 29 hc-c2-na-hn 20 13 12 19 + 30 hc-c2-na-hn 21 13 12 19 + 31 c2-c2-na-c2 17 18 12 13 + 32 hc-c2-na-c2 30 18 12 13 + 33 hc-c2-na-c2 31 18 12 13 + 34 c2-c2-na-hn 17 18 12 19 + 35 hc-c2-na-hn 30 18 12 19 + 36 hc-c2-na-hn 31 18 12 19 + 37 na-c2-c2-na 12 13 14 15 + 38 hc-c2-c2-na 22 14 13 12 + 39 hc-c2-c2-na 23 14 13 12 + 40 hc-c2-c2-na 20 13 14 15 + 41 hc-c2-c2-hc 20 13 14 22 + 42 hc-c2-c2-hc 20 13 14 23 + 43 hc-c2-c2-na 21 13 14 15 + 44 hc-c2-c2-hc 21 13 14 22 + 45 hc-c2-c2-hc 21 13 14 23 + 46 c2-c2-na-hn 13 14 15 24 + 47 c2-c2-na-hn 13 14 15 25 + 48 hc-c2-na-hn 22 14 15 24 + 49 hc-c2-na-hn 22 14 15 25 + 50 hc-c2-na-hn 23 14 15 24 + 51 hc-c2-na-hn 23 14 15 25 + 52 c2-c2-na-hn 18 17 16 26 + 53 hc-c2-na-hn 28 17 16 26 + 54 hc-c2-na-hn 29 17 16 26 + 55 c2-c2-na-hn 18 17 16 27 + 56 hc-c2-na-hn 28 17 16 27 + 57 hc-c2-na-hn 29 17 16 27 + 58 na-c2-c2-na 16 17 18 12 + 59 hc-c2-c2-na 30 18 17 16 + 60 hc-c2-c2-na 31 18 17 16 + 61 hc-c2-c2-na 28 17 18 12 + 62 hc-c2-c2-hc 28 17 18 30 + 63 hc-c2-c2-hc 28 17 18 31 + 64 hc-c2-c2-na 29 17 18 12 + 65 hc-c2-c2-hc 29 17 18 30 + 66 hc-c2-c2-hc 29 17 18 31 + +Impropers + + 1 c2-na-c2-hn 13 12 18 19 + 2 c2-na-hn-hn 14 15 24 25 + 3 c2-na-hn-hn 17 16 26 27 diff --git a/examples/PACKAGES/reaction/tiny_epoxy/rxn1_stp2_post.data_template b/examples/PACKAGES/reaction/tiny_epoxy/rxn1_stp2_post.data_template deleted file mode 100644 index cbb66a3151..0000000000 --- a/examples/PACKAGES/reaction/tiny_epoxy/rxn1_stp2_post.data_template +++ /dev/null @@ -1,307 +0,0 @@ -rxn1_stp2_post - -31 atoms -30 bonds -53 angles -72 dihedrals -31 impropers - -Types - -1 1 -2 6 -3 1 -4 7 -5 4 -6 7 -7 8 -8 8 -9 8 -10 8 -11 8 -12 9 -13 1 -14 1 -15 9 -16 9 -17 1 -18 1 -19 10 -20 8 -21 8 -22 8 -23 8 -24 10 -25 11 -26 10 -27 10 -28 8 -29 8 -30 8 -31 8 - -Charges - -1 0.000000 -2 0.000000 -3 0.000000 -4 0.100000 -5 0.000000 -6 0.000000 -7 0.000000 -8 0.000000 -9 0.000000 -10 0.000000 -11 0.000000 -12 0.000000 -13 0.000000 -14 0.000000 -15 -0.025000 -16 -0.025000 -17 0.000000 -18 0.000000 -19 0.000000 -20 0.000000 -21 0.000000 -22 0.000000 -23 0.000000 -24 0.000000 -25 0.000000 -26 0.000000 -27 0.000000 -28 0.000000 -29 0.000000 -30 0.000000 -31 0.000000 - -Coords - -1 19.846411 9.569080 -1.229960 -2 21.168550 9.331390 -0.418120 -3 21.253010 8.067940 0.460720 -4 21.330839 10.304280 -0.253340 -5 21.891689 5.906200 0.464150 -6 21.818470 6.999870 -0.296270 -7 19.931601 10.026600 -2.215510 -8 19.051279 8.828540 -1.132880 -9 22.228800 9.293580 -0.665280 -10 21.880541 8.270810 1.328060 -11 20.253151 7.789050 0.792640 -12 16.072720 12.338940 -0.174630 -13 16.557051 11.130580 0.587500 -14 18.074381 10.998730 0.366590 -15 18.354031 10.832100 -1.107140 -16 14.920880 15.018100 -0.201130 -17 16.390551 14.791140 -0.461060 -18 16.852989 13.538490 0.304530 -19 16.264271 12.190330 -1.257620 -20 16.025061 10.195290 0.210910 -21 16.346741 11.269890 1.698950 -22 18.466690 10.092460 0.935470 -23 18.592319 11.941150 0.745170 -24 17.213690 10.780300 -1.896260 -25 20.881861 11.302060 -0.773030 -26 14.344180 14.136430 -0.550280 -27 14.583670 15.922830 -0.748110 -28 16.984310 15.696060 -0.103470 -29 16.562460 14.639560 -1.577590 -30 16.674610 13.686010 1.420370 -31 17.964001 13.363150 0.117750 - -Bonds - -1 1 1 8 -2 16 1 2 -3 1 1 7 -4 13 1 15 -5 16 3 2 -6 12 2 9 -7 17 2 4 -8 3 3 6 -9 1 3 10 -10 1 3 11 -11 18 4 25 -12 8 6 5 -13 13 13 12 -14 13 18 12 -15 14 12 19 -16 15 13 14 -17 1 13 20 -18 1 13 21 -19 13 14 15 -20 1 14 22 -21 1 14 23 -22 14 15 24 -23 13 17 16 -24 14 16 26 -25 14 16 27 -26 15 17 18 -27 1 17 28 -28 1 17 29 -29 1 18 30 -30 1 18 31 - -Angles - -1 30 2 1 8 -2 2 8 1 7 -3 26 8 1 15 -4 30 2 1 7 -5 31 2 1 15 -6 26 7 1 15 -7 32 1 2 3 -8 33 1 2 9 -9 34 1 2 4 -10 33 3 2 9 -11 34 3 2 4 -12 35 4 2 9 -13 36 2 3 6 -14 30 2 3 10 -15 30 2 3 11 -16 3 6 3 10 -17 3 6 3 11 -18 2 10 3 11 -19 37 2 4 25 -20 22 3 6 5 -21 23 13 12 18 -22 24 13 12 19 -23 24 18 12 19 -24 25 14 13 12 -25 26 20 13 12 -26 26 21 13 12 -27 27 14 13 20 -28 27 14 13 21 -29 2 20 13 21 -30 25 13 14 15 -31 27 13 14 22 -32 27 13 14 23 -33 26 22 14 15 -34 26 23 14 15 -35 2 22 14 23 -36 23 1 15 14 -37 24 1 15 24 -38 24 14 15 24 -39 24 17 16 26 -40 24 17 16 27 -41 28 26 16 27 -42 25 18 17 16 -43 26 28 17 16 -44 26 29 17 16 -45 27 18 17 28 -46 27 18 17 29 -47 2 28 17 29 -48 25 17 18 12 -49 26 30 18 12 -50 26 31 18 12 -51 27 17 18 30 -52 27 17 18 31 -53 2 30 18 31 - -Dihedrals - -1 40 8 1 2 3 -2 41 8 1 2 9 -3 42 8 1 2 4 -4 40 7 1 2 3 -5 41 7 1 2 9 -6 42 7 1 2 4 -7 43 15 1 2 3 -8 44 15 1 2 9 -9 45 15 1 2 4 -10 28 8 1 15 14 -11 30 8 1 15 24 -12 46 2 1 15 14 -13 47 2 1 15 24 -14 28 7 1 15 14 -15 30 7 1 15 24 -16 48 6 3 2 1 -17 40 10 3 2 1 -18 40 11 3 2 1 -19 49 6 3 2 9 -20 41 10 3 2 9 -21 41 11 3 2 9 -22 50 6 3 2 4 -23 42 10 3 2 4 -24 42 11 3 2 4 -25 52 1 2 4 25 -26 52 3 2 4 25 -27 53 9 2 4 25 -28 51 2 3 6 5 -29 7 10 3 6 5 -30 7 11 3 6 5 -31 27 14 13 12 18 -32 28 20 13 12 18 -33 28 21 13 12 18 -34 29 14 13 12 19 -35 30 20 13 12 19 -36 30 21 13 12 19 -37 27 17 18 12 13 -38 28 30 18 12 13 -39 28 31 18 12 13 -40 29 17 18 12 19 -41 30 30 18 12 19 -42 30 31 18 12 19 -43 31 12 13 14 15 -44 32 22 14 13 12 -45 32 23 14 13 12 -46 32 20 13 14 15 -47 33 20 13 14 22 -48 33 20 13 14 23 -49 32 21 13 14 15 -50 33 21 13 14 22 -51 33 21 13 14 23 -52 27 13 14 15 1 -53 29 13 14 15 24 -54 28 22 14 15 1 -55 30 22 14 15 24 -56 28 23 14 15 1 -57 30 23 14 15 24 -58 29 18 17 16 26 -59 30 28 17 16 26 -60 30 29 17 16 26 -61 29 18 17 16 27 -62 30 28 17 16 27 -63 30 29 17 16 27 -64 31 16 17 18 12 -65 32 30 18 17 16 -66 32 31 18 17 16 -67 32 28 17 18 12 -68 33 28 17 18 30 -69 33 28 17 18 31 -70 32 29 17 18 12 -71 33 29 17 18 30 -72 33 29 17 18 31 - -Impropers - -1 4 13 12 18 19 -2 4 1 15 14 24 -3 5 17 16 26 27 -4 1 2 1 8 7 -5 1 2 1 8 15 -6 1 8 1 7 15 -7 1 2 1 7 15 -8 1 1 2 3 9 -9 1 1 2 3 4 -10 1 1 2 4 9 -11 1 3 2 4 9 -12 1 2 3 6 10 -13 1 2 3 6 11 -14 1 2 3 10 11 -15 1 6 3 10 11 -16 1 14 13 20 12 -17 1 14 13 21 12 -18 1 20 13 21 12 -19 1 14 13 20 21 -20 1 13 14 22 15 -21 1 13 14 23 15 -22 1 13 14 22 23 -23 1 22 14 23 15 -24 1 18 17 28 16 -25 1 18 17 29 16 -26 1 28 17 29 16 -27 1 18 17 28 29 -28 1 17 18 30 12 -29 1 17 18 31 12 -30 1 30 18 31 12 -31 1 17 18 30 31 diff --git a/examples/PACKAGES/reaction/tiny_epoxy/rxn1_stp2_post.molecule_template b/examples/PACKAGES/reaction/tiny_epoxy/rxn1_stp2_post.molecule_template new file mode 100644 index 0000000000..bee46d3a66 --- /dev/null +++ b/examples/PACKAGES/reaction/tiny_epoxy/rxn1_stp2_post.molecule_template @@ -0,0 +1,313 @@ +rxn1_stp2_post + + 31 atoms + 30 bonds + 53 angles + 72 dihedrals + 3 impropers + +Coords + + 1 19.846410751 9.569080353 -1.229959965 + 2 21.168550491 9.331390381 -0.418119997 + 3 21.253009796 8.067939758 0.460720003 + 4 21.330839157 10.304280281 -0.253340006 + 5 21.891689301 5.906199932 0.464150012 + 6 21.818470001 6.999869823 -0.296270013 + 7 19.931600571 10.026599884 -2.215509892 + 8 19.051279068 8.828539848 -1.132879972 + 9 22.228799820 9.293580055 -0.665279984 + 10 21.880540848 8.270810127 1.328060031 + 11 20.253150940 7.789050102 0.792639971 + 12 16.072719574 12.338939667 -0.174630001 + 13 16.557050705 11.130579948 0.587499976 + 14 18.074380875 10.998729706 0.366589993 + 15 18.354030609 10.832099915 -1.107139945 + 16 14.920880318 15.018099785 -0.201130003 + 17 16.390550613 14.791139603 -0.461059988 + 18 16.852989197 13.538490295 0.304529995 + 19 16.264270782 12.190329552 -1.257619977 + 20 16.025060654 10.195289612 0.210910007 + 21 16.346740723 11.269889832 1.698950052 + 22 18.466690063 10.092459679 0.935469985 + 23 18.592319489 11.941149712 0.745169997 + 24 17.213689804 10.780300140 -1.896260023 + 25 20.881860733 11.302060127 -0.773029983 + 26 14.344180107 14.136429787 -0.550279975 + 27 14.583669662 15.922829628 -0.748109996 + 28 16.984310150 15.696060181 -0.103469998 + 29 16.562459946 14.639559746 -1.577589989 + 30 16.674610138 13.686010361 1.420369983 + 31 17.964000702 13.363149643 0.117749996 + +Types + + 1 c2 + 2 c3 + 3 c2 + 4 oc + 5 cp + 6 oc + 7 hc + 8 hc + 9 hc + 10 hc + 11 hc + 12 na + 13 c2 + 14 c2 + 15 na + 16 na + 17 c2 + 18 c2 + 19 hn + 20 hc + 21 hc + 22 hc + 23 hc + 24 hn + 25 ho + 26 hn + 27 hn + 28 hc + 29 hc + 30 hc + 31 hc + +Charges + + 1 0.000000 + 2 0.000000 + 3 0.000000 + 4 0.100000 + 5 0.000000 + 6 0.000000 + 7 0.000000 + 8 0.000000 + 9 0.000000 + 10 0.000000 + 11 0.000000 + 12 0.000000 + 13 0.000000 + 14 0.000000 + 15 -0.025000 + 16 -0.025000 + 17 0.000000 + 18 0.000000 + 19 0.000000 + 20 0.000000 + 21 0.000000 + 22 0.000000 + 23 0.000000 + 24 0.000000 + 25 0.000000 + 26 0.000000 + 27 0.000000 + 28 0.000000 + 29 0.000000 + 30 0.000000 + 31 0.000000 + +Molecules + + 1 1 + 2 1 + 3 1 + 4 1 + 5 1 + 6 1 + 7 1 + 8 1 + 9 1 + 10 1 + 11 1 + 12 1 + 13 1 + 14 1 + 15 1 + 16 1 + 17 1 + 18 1 + 19 1 + 20 1 + 21 1 + 22 1 + 23 1 + 24 1 + 25 1 + 26 1 + 27 1 + 28 1 + 29 1 + 30 1 + 31 1 + +Bonds + + 1 c2-hc 1 8 + 2 c2-c3 1 2 + 3 c2-hc 1 7 + 4 c2-na 1 15 + 5 c2-c3 3 2 + 6 c3-hc 2 9 + 7 c3-oc 2 4 + 8 c2-oc 3 6 + 9 c2-hc 3 10 + 10 c2-hc 3 11 + 11 oc-ho 4 25 + 12 cp-oc 6 5 + 13 c2-na 13 12 + 14 c2-na 18 12 + 15 na-hn 12 19 + 16 c2-c2 13 14 + 17 c2-hc 13 20 + 18 c2-hc 13 21 + 19 c2-na 14 15 + 20 c2-hc 14 22 + 21 c2-hc 14 23 + 22 na-hn 15 24 + 23 c2-na 17 16 + 24 na-hn 16 26 + 25 na-hn 16 27 + 26 c2-c2 17 18 + 27 c2-hc 17 28 + 28 c2-hc 17 29 + 29 c2-hc 18 30 + 30 c2-hc 18 31 + +Angles + + 1 c3-c2-hc 2 1 8 + 2 hc-c2-hc 8 1 7 + 3 hc-c2-na 8 1 15 + 4 c3-c2-hc 2 1 7 + 5 c3-c2-na 2 1 15 + 6 hc-c2-na 7 1 15 + 7 c2-c3-c2 1 2 3 + 8 c2-c3-hc 1 2 9 + 9 c2-c3-oc 1 2 4 + 10 c2-c3-hc 3 2 9 + 11 c2-c3-oc 3 2 4 + 12 oc-c3-hc 4 2 9 + 13 c3-c2-oc 2 3 6 + 14 c3-c2-hc 2 3 10 + 15 c3-c2-hc 2 3 11 + 16 oc-c2-hc 6 3 10 + 17 oc-c2-hc 6 3 11 + 18 hc-c2-hc 10 3 11 + 19 c3-oc-ho 2 4 25 + 20 c2-oc-cp 3 6 5 + 21 c2-na-c2 13 12 18 + 22 c2-na-hn 13 12 19 + 23 c2-na-hn 18 12 19 + 24 c2-c2-na 14 13 12 + 25 hc-c2-na 20 13 12 + 26 hc-c2-na 21 13 12 + 27 c2-c2-hc 14 13 20 + 28 c2-c2-hc 14 13 21 + 29 hc-c2-hc 20 13 21 + 30 c2-c2-na 13 14 15 + 31 c2-c2-hc 13 14 22 + 32 c2-c2-hc 13 14 23 + 33 hc-c2-na 22 14 15 + 34 hc-c2-na 23 14 15 + 35 hc-c2-hc 22 14 23 + 36 c2-na-c2 1 15 14 + 37 c2-na-hn 1 15 24 + 38 c2-na-hn 14 15 24 + 39 c2-na-hn 17 16 26 + 40 c2-na-hn 17 16 27 + 41 hn-na-hn 26 16 27 + 42 c2-c2-na 18 17 16 + 43 hc-c2-na 28 17 16 + 44 hc-c2-na 29 17 16 + 45 c2-c2-hc 18 17 28 + 46 c2-c2-hc 18 17 29 + 47 hc-c2-hc 28 17 29 + 48 c2-c2-na 17 18 12 + 49 hc-c2-na 30 18 12 + 50 hc-c2-na 31 18 12 + 51 c2-c2-hc 17 18 30 + 52 c2-c2-hc 17 18 31 + 53 hc-c2-hc 30 18 31 + +Dihedrals + + 1 hc-c2-c3-c2 8 1 2 3 + 2 hc-c2-c3-hc 8 1 2 9 + 3 hc-c2-c3-oc 8 1 2 4 + 4 hc-c2-c3-c2 7 1 2 3 + 5 hc-c2-c3-hc 7 1 2 9 + 6 hc-c2-c3-oc 7 1 2 4 + 7 na-c2-c3-c2 15 1 2 3 + 8 na-c2-c3-hc 15 1 2 9 + 9 na-c2-c3-oc 15 1 2 4 + 10 hc-c2-na-c2 8 1 15 14 + 11 hc-c2-na-hn 8 1 15 24 + 12 c3-c2-na-c2 2 1 15 14 + 13 c3-c2-na-hn 2 1 15 24 + 14 hc-c2-na-c2 7 1 15 14 + 15 hc-c2-na-hn 7 1 15 24 + 16 oc-c2-c3-c2 6 3 2 1 + 17 hc-c2-c3-c2 10 3 2 1 + 18 hc-c2-c3-c2 11 3 2 1 + 19 oc-c2-c3-hc 6 3 2 9 + 20 hc-c2-c3-hc 10 3 2 9 + 21 hc-c2-c3-hc 11 3 2 9 + 22 oc-c2-c3-oc 6 3 2 4 + 23 hc-c2-c3-oc 10 3 2 4 + 24 hc-c2-c3-oc 11 3 2 4 + 25 c2-c3-oc-ho 1 2 4 25 + 26 c2-c3-oc-ho 3 2 4 25 + 27 hc-c3-oc-ho 9 2 4 25 + 28 c3-c2-oc-cp 2 3 6 5 + 29 hc-c2-oc-cp 10 3 6 5 + 30 hc-c2-oc-cp 11 3 6 5 + 31 c2-c2-na-c2 14 13 12 18 + 32 hc-c2-na-c2 20 13 12 18 + 33 hc-c2-na-c2 21 13 12 18 + 34 c2-c2-na-hn 14 13 12 19 + 35 hc-c2-na-hn 20 13 12 19 + 36 hc-c2-na-hn 21 13 12 19 + 37 c2-c2-na-c2 17 18 12 13 + 38 hc-c2-na-c2 30 18 12 13 + 39 hc-c2-na-c2 31 18 12 13 + 40 c2-c2-na-hn 17 18 12 19 + 41 hc-c2-na-hn 30 18 12 19 + 42 hc-c2-na-hn 31 18 12 19 + 43 na-c2-c2-na 12 13 14 15 + 44 hc-c2-c2-na 22 14 13 12 + 45 hc-c2-c2-na 23 14 13 12 + 46 hc-c2-c2-na 20 13 14 15 + 47 hc-c2-c2-hc 20 13 14 22 + 48 hc-c2-c2-hc 20 13 14 23 + 49 hc-c2-c2-na 21 13 14 15 + 50 hc-c2-c2-hc 21 13 14 22 + 51 hc-c2-c2-hc 21 13 14 23 + 52 c2-c2-na-c2 13 14 15 1 + 53 c2-c2-na-hn 13 14 15 24 + 54 hc-c2-na-c2 22 14 15 1 + 55 hc-c2-na-hn 22 14 15 24 + 56 hc-c2-na-c2 23 14 15 1 + 57 hc-c2-na-hn 23 14 15 24 + 58 c2-c2-na-hn 18 17 16 26 + 59 hc-c2-na-hn 28 17 16 26 + 60 hc-c2-na-hn 29 17 16 26 + 61 c2-c2-na-hn 18 17 16 27 + 62 hc-c2-na-hn 28 17 16 27 + 63 hc-c2-na-hn 29 17 16 27 + 64 na-c2-c2-na 16 17 18 12 + 65 hc-c2-c2-na 30 18 17 16 + 66 hc-c2-c2-na 31 18 17 16 + 67 hc-c2-c2-na 28 17 18 12 + 68 hc-c2-c2-hc 28 17 18 30 + 69 hc-c2-c2-hc 28 17 18 31 + 70 hc-c2-c2-na 29 17 18 12 + 71 hc-c2-c2-hc 29 17 18 30 + 72 hc-c2-c2-hc 29 17 18 31 + +Impropers + + 1 c2-na-c2-hn 13 12 18 19 + 2 c2-na-c2-hn 1 15 14 24 + 3 c2-na-hn-hn 17 16 26 27 diff --git a/examples/PACKAGES/reaction/tiny_epoxy/rxn2_stp1_post.data_template b/examples/PACKAGES/reaction/tiny_epoxy/rxn2_stp1_post.data_template deleted file mode 100644 index 0600abdc0c..0000000000 --- a/examples/PACKAGES/reaction/tiny_epoxy/rxn2_stp1_post.data_template +++ /dev/null @@ -1,424 +0,0 @@ -rxn2_stp1_post - -42 atoms -41 bonds -75 angles -108 dihedrals -46 impropers - -Types - -1 1 -2 6 -3 1 -4 7 -5 4 -6 7 -7 8 -8 8 -9 8 -10 8 -11 8 -12 9 -13 1 -14 1 -15 9 -16 9 -17 1 -18 1 -19 10 -20 8 -21 8 -22 8 -23 8 -24 10 -25 11 -26 10 -27 10 -28 8 -29 8 -30 8 -31 8 -32 1 -33 6 -34 1 -35 7 -36 4 -37 7 -38 8 -39 8 -40 8 -41 8 -42 8 - -Charges - -1 0.000000 -2 0.000000 -3 0.000000 -4 0.100000 -5 0.000000 -6 0.000000 -7 0.000000 -8 0.000000 -9 0.000000 -10 0.000000 -11 0.000000 -12 0.000000 -13 0.000000 -14 0.000000 -15 -0.025000 -16 -0.025000 -17 0.000000 -18 0.000000 -19 0.000000 -20 0.000000 -21 0.000000 -22 0.000000 -23 0.000000 -24 0.000000 -25 0.000000 -26 0.000000 -27 0.000000 -28 0.000000 -29 0.000000 -30 0.000000 -31 0.000000 -32 0.000000 -33 0.000000 -34 0.000000 -35 0.100000 -36 0.000000 -37 0.000000 -38 0.000000 -39 0.000000 -40 0.000000 -41 0.000000 -42 0.000000 - -Coords - -1 19.846411 9.569080 -1.229960 -2 21.168550 9.331390 -0.418120 -3 21.253010 8.067940 0.460720 -4 21.330839 10.304280 -0.253340 -5 21.891689 5.906200 0.464150 -6 21.818470 6.999870 -0.296270 -7 19.931601 10.026600 -2.215510 -8 19.051279 8.828540 -1.132880 -9 22.228800 9.293580 -0.665280 -10 21.880541 8.270810 1.328060 -11 20.253151 7.789050 0.792640 -12 16.072720 12.338940 -0.174630 -13 16.557051 11.130580 0.587500 -14 18.074381 10.998730 0.366590 -15 18.354031 10.832100 -1.107140 -16 14.920880 15.018100 -0.201130 -17 16.390551 14.791140 -0.461060 -18 16.852989 13.538490 0.304530 -19 16.264271 12.190330 -1.257620 -20 16.025061 10.195290 0.210910 -21 16.346741 11.269890 1.698950 -22 18.466690 10.092460 0.935470 -23 18.592319 11.941150 0.745170 -24 17.213690 10.780300 -1.896260 -25 20.881861 11.302060 -0.773030 -26 14.344180 14.136430 -0.550280 -27 14.583670 15.922830 -0.748110 -28 16.984310 15.696060 -0.103470 -29 16.562460 14.639560 -1.577590 -30 16.674610 13.686010 1.420370 -31 17.964001 13.363150 0.117750 -32 18.680189 9.134390 -4.183100 -33 18.099751 8.263650 -5.343000 -34 19.081829 7.609610 -6.334180 -35 17.971729 9.827680 -5.367080 -36 20.263880 5.733600 -6.736780 -37 19.414030 6.299980 -5.878960 -38 18.194740 9.091640 -3.210950 -39 19.788940 9.208560 -4.119640 -40 17.399309 7.432220 -5.407800 -41 18.616249 7.545570 -7.316910 -42 19.987049 8.212500 -6.399400 - -Bonds - -1 1 1 8 -2 16 1 2 -3 1 1 7 -4 13 1 15 -5 16 3 2 -6 12 2 9 -7 17 2 4 -8 3 3 6 -9 1 3 10 -10 1 3 11 -11 18 4 25 -12 8 6 5 -13 13 13 12 -14 13 18 12 -15 14 12 19 -16 15 13 14 -17 1 13 20 -18 1 13 21 -19 13 14 15 -20 1 14 22 -21 1 14 23 -22 14 15 24 -23 13 32 15 -24 13 17 16 -25 14 16 26 -26 14 16 27 -27 15 17 18 -28 1 17 28 -29 1 17 29 -30 1 18 30 -31 1 18 31 -32 1 32 39 -33 16 32 33 -34 1 32 38 -35 17 33 35 -36 16 34 33 -37 12 33 40 -38 3 34 37 -39 1 34 41 -40 1 34 42 -41 8 37 36 - -Angles - -1 30 2 1 8 -2 2 8 1 7 -3 26 8 1 15 -4 30 2 1 7 -5 31 2 1 15 -6 26 7 1 15 -7 32 1 2 3 -8 33 1 2 9 -9 34 1 2 4 -10 33 3 2 9 -11 34 3 2 4 -12 35 4 2 9 -13 36 2 3 6 -14 30 2 3 10 -15 30 2 3 11 -16 3 6 3 10 -17 3 6 3 11 -18 2 10 3 11 -19 37 2 4 25 -20 22 3 6 5 -21 23 13 12 18 -22 24 13 12 19 -23 24 18 12 19 -24 25 14 13 12 -25 26 20 13 12 -26 26 21 13 12 -27 27 14 13 20 -28 27 14 13 21 -29 2 20 13 21 -30 25 13 14 15 -31 27 13 14 22 -32 27 13 14 23 -33 26 22 14 15 -34 26 23 14 15 -35 2 22 14 23 -36 23 1 15 14 -37 24 1 15 24 -38 23 1 15 32 -39 24 14 15 24 -40 23 14 15 32 -41 24 32 15 24 -42 24 17 16 26 -43 24 17 16 27 -44 28 26 16 27 -45 25 18 17 16 -46 26 28 17 16 -47 26 29 17 16 -48 27 18 17 28 -49 27 18 17 29 -50 2 28 17 29 -51 25 17 18 12 -52 26 30 18 12 -53 26 31 18 12 -54 27 17 18 30 -55 27 17 18 31 -56 2 30 18 31 -57 26 39 32 15 -58 31 33 32 15 -59 26 38 32 15 -60 30 33 32 39 -61 2 39 32 38 -62 30 33 32 38 -63 34 32 33 35 -64 32 32 33 34 -65 33 32 33 40 -66 34 34 33 35 -67 35 35 33 40 -68 33 34 33 40 -69 36 33 34 37 -70 30 33 34 41 -71 30 33 34 42 -72 3 37 34 41 -73 3 37 34 42 -74 2 41 34 42 -75 22 34 37 36 - -Dihedrals - -1 40 8 1 2 3 -2 41 8 1 2 9 -3 42 8 1 2 4 -4 40 7 1 2 3 -5 41 7 1 2 9 -6 42 7 1 2 4 -7 43 15 1 2 3 -8 44 15 1 2 9 -9 45 15 1 2 4 -10 28 8 1 15 14 -11 30 8 1 15 24 -12 28 8 1 15 32 -13 46 2 1 15 14 -14 47 2 1 15 24 -15 46 2 1 15 32 -16 28 7 1 15 14 -17 30 7 1 15 24 -18 28 7 1 15 32 -19 48 6 3 2 1 -20 40 10 3 2 1 -21 40 11 3 2 1 -22 49 6 3 2 9 -23 41 10 3 2 9 -24 41 11 3 2 9 -25 50 6 3 2 4 -26 42 10 3 2 4 -27 42 11 3 2 4 -28 52 1 2 4 25 -29 52 3 2 4 25 -30 53 9 2 4 25 -31 51 2 3 6 5 -32 7 10 3 6 5 -33 7 11 3 6 5 -34 27 14 13 12 18 -35 28 20 13 12 18 -36 28 21 13 12 18 -37 29 14 13 12 19 -38 30 20 13 12 19 -39 30 21 13 12 19 -40 27 17 18 12 13 -41 28 30 18 12 13 -42 28 31 18 12 13 -43 29 17 18 12 19 -44 30 30 18 12 19 -45 30 31 18 12 19 -46 31 12 13 14 15 -47 32 22 14 13 12 -48 32 23 14 13 12 -49 32 20 13 14 15 -50 33 20 13 14 22 -51 33 20 13 14 23 -52 32 21 13 14 15 -53 33 21 13 14 22 -54 33 21 13 14 23 -55 27 13 14 15 1 -56 29 13 14 15 24 -57 27 13 14 15 32 -58 28 22 14 15 1 -59 30 22 14 15 24 -60 28 22 14 15 32 -61 28 23 14 15 1 -62 30 23 14 15 24 -63 28 23 14 15 32 -64 28 39 32 15 1 -65 46 33 32 15 1 -66 28 38 32 15 1 -67 28 39 32 15 14 -68 46 33 32 15 14 -69 28 38 32 15 14 -70 30 39 32 15 24 -71 47 33 32 15 24 -72 30 38 32 15 24 -73 29 18 17 16 26 -74 30 28 17 16 26 -75 30 29 17 16 26 -76 29 18 17 16 27 -77 30 28 17 16 27 -78 30 29 17 16 27 -79 31 16 17 18 12 -80 32 30 18 17 16 -81 32 31 18 17 16 -82 32 28 17 18 12 -83 33 28 17 18 30 -84 33 28 17 18 31 -85 32 29 17 18 12 -86 33 29 17 18 30 -87 33 29 17 18 31 -88 45 15 32 33 35 -89 43 15 32 33 34 -90 44 15 32 33 40 -91 42 39 32 33 35 -92 40 39 32 33 34 -93 41 39 32 33 40 -94 42 38 32 33 35 -95 40 38 32 33 34 -96 41 38 32 33 40 -97 48 37 34 33 32 -98 40 41 34 33 32 -99 40 42 34 33 32 -100 50 37 34 33 35 -101 42 41 34 33 35 -102 42 42 34 33 35 -103 49 37 34 33 40 -104 41 41 34 33 40 -105 41 42 34 33 40 -106 51 33 34 37 36 -107 7 41 34 37 36 -108 7 42 34 37 36 - -Impropers - -1 4 13 12 18 19 -2 5 17 16 26 27 -3 1 2 1 8 7 -4 1 2 1 8 15 -5 1 8 1 7 15 -6 1 2 1 7 15 -7 1 1 2 3 9 -8 1 1 2 3 4 -9 1 1 2 4 9 -10 1 3 2 4 9 -11 1 2 3 6 10 -12 1 2 3 6 11 -13 1 2 3 10 11 -14 1 6 3 10 11 -15 1 14 13 20 12 -16 1 14 13 21 12 -17 1 20 13 21 12 -18 1 14 13 20 21 -19 1 13 14 22 15 -20 1 13 14 23 15 -21 1 13 14 22 23 -22 1 22 14 23 15 -23 1 1 15 14 24 -24 1 1 15 14 32 -25 1 1 15 32 24 -26 1 14 15 32 24 -27 1 18 17 28 16 -28 1 18 17 29 16 -29 1 28 17 29 16 -30 1 18 17 28 29 -31 1 17 18 30 12 -32 1 17 18 31 12 -33 1 30 18 31 12 -34 1 17 18 30 31 -35 1 33 32 39 15 -36 1 39 32 38 15 -37 1 33 32 38 15 -38 1 33 32 39 38 -39 1 32 33 34 35 -40 1 32 33 35 40 -41 1 32 33 34 40 -42 1 34 33 35 40 -43 1 33 34 37 41 -44 1 33 34 37 42 -45 1 33 34 41 42 -46 1 37 34 41 42 diff --git a/examples/PACKAGES/reaction/tiny_epoxy/rxn2_stp1_post.molecule_template b/examples/PACKAGES/reaction/tiny_epoxy/rxn2_stp1_post.molecule_template new file mode 100644 index 0000000000..4d5faa82b4 --- /dev/null +++ b/examples/PACKAGES/reaction/tiny_epoxy/rxn2_stp1_post.molecule_template @@ -0,0 +1,425 @@ +rxn2_stp1_post + + 42 atoms + 41 bonds + 75 angles + 108 dihedrals + 2 impropers + +Coords + + 1 19.846410751 9.569080353 -1.229959965 + 2 21.168550491 9.331390381 -0.418119997 + 3 21.253009796 8.067939758 0.460720003 + 4 21.330839157 10.304280281 -0.253340006 + 5 21.891689301 5.906199932 0.464150012 + 6 21.818470001 6.999869823 -0.296270013 + 7 19.931600571 10.026599884 -2.215509892 + 8 19.051279068 8.828539848 -1.132879972 + 9 22.228799820 9.293580055 -0.665279984 + 10 21.880540848 8.270810127 1.328060031 + 11 20.253150940 7.789050102 0.792639971 + 12 16.072719574 12.338939667 -0.174630001 + 13 16.557050705 11.130579948 0.587499976 + 14 18.074380875 10.998729706 0.366589993 + 15 18.354030609 10.832099915 -1.107139945 + 16 14.920880318 15.018099785 -0.201130003 + 17 16.390550613 14.791139603 -0.461059988 + 18 16.852989197 13.538490295 0.304529995 + 19 16.264270782 12.190329552 -1.257619977 + 20 16.025060654 10.195289612 0.210910007 + 21 16.346740723 11.269889832 1.698950052 + 22 18.466690063 10.092459679 0.935469985 + 23 18.592319489 11.941149712 0.745169997 + 24 17.213689804 10.780300140 -1.896260023 + 25 20.881860733 11.302060127 -0.773029983 + 26 14.344180107 14.136429787 -0.550279975 + 27 14.583669662 15.922829628 -0.748109996 + 28 16.984310150 15.696060181 -0.103469998 + 29 16.562459946 14.639559746 -1.577589989 + 30 16.674610138 13.686010361 1.420369983 + 31 17.964000702 13.363149643 0.117749996 + 32 18.680189133 9.134389877 -4.183100224 + 33 18.099750519 8.263649940 -5.342999935 + 34 19.081829071 7.609610081 -6.334179878 + 35 17.971729279 9.827679634 -5.367080212 + 36 20.263879776 5.733600140 -6.736780167 + 37 19.414030075 6.299980164 -5.878960133 + 38 18.194740295 9.091640472 -3.210949898 + 39 19.788940430 9.208559990 -4.119639874 + 40 17.399309158 7.432219982 -5.407800198 + 41 18.616249084 7.545569897 -7.316909790 + 42 19.987049103 8.212499619 -6.399400234 + +Types + + 1 c2 + 2 c3 + 3 c2 + 4 oc + 5 cp + 6 oc + 7 hc + 8 hc + 9 hc + 10 hc + 11 hc + 12 na + 13 c2 + 14 c2 + 15 na + 16 na + 17 c2 + 18 c2 + 19 hn + 20 hc + 21 hc + 22 hc + 23 hc + 24 hn + 25 ho + 26 hn + 27 hn + 28 hc + 29 hc + 30 hc + 31 hc + 32 c2 + 33 c3 + 34 c2 + 35 oc + 36 cp + 37 oc + 38 hc + 39 hc + 40 hc + 41 hc + 42 hc + +Charges + + 1 0.000000 + 2 0.000000 + 3 0.000000 + 4 0.100000 + 5 0.000000 + 6 0.000000 + 7 0.000000 + 8 0.000000 + 9 0.000000 + 10 0.000000 + 11 0.000000 + 12 0.000000 + 13 0.000000 + 14 0.000000 + 15 -0.025000 + 16 -0.025000 + 17 0.000000 + 18 0.000000 + 19 0.000000 + 20 0.000000 + 21 0.000000 + 22 0.000000 + 23 0.000000 + 24 0.000000 + 25 0.000000 + 26 0.000000 + 27 0.000000 + 28 0.000000 + 29 0.000000 + 30 0.000000 + 31 0.000000 + 32 0.000000 + 33 0.000000 + 34 0.000000 + 35 0.100000 + 36 0.000000 + 37 0.000000 + 38 0.000000 + 39 0.000000 + 40 0.000000 + 41 0.000000 + 42 0.000000 + +Molecules + + 1 1 + 2 1 + 3 1 + 4 1 + 5 1 + 6 1 + 7 1 + 8 1 + 9 1 + 10 1 + 11 1 + 12 1 + 13 1 + 14 1 + 15 1 + 16 1 + 17 1 + 18 1 + 19 1 + 20 1 + 21 1 + 22 1 + 23 1 + 24 1 + 25 1 + 26 1 + 27 1 + 28 1 + 29 1 + 30 1 + 31 1 + 32 1 + 33 1 + 34 1 + 35 1 + 36 1 + 37 1 + 38 1 + 39 1 + 40 1 + 41 1 + 42 1 + +Bonds + + 1 c2-hc 1 8 + 2 c2-c3 1 2 + 3 c2-hc 1 7 + 4 c2-na 1 15 + 5 c2-c3 3 2 + 6 c3-hc 2 9 + 7 c3-oc 2 4 + 8 c2-oc 3 6 + 9 c2-hc 3 10 + 10 c2-hc 3 11 + 11 oc-ho 4 25 + 12 cp-oc 6 5 + 13 c2-na 13 12 + 14 c2-na 18 12 + 15 na-hn 12 19 + 16 c2-c2 13 14 + 17 c2-hc 13 20 + 18 c2-hc 13 21 + 19 c2-na 14 15 + 20 c2-hc 14 22 + 21 c2-hc 14 23 + 22 na-hn 15 24 + 23 c2-na 32 15 + 24 c2-na 17 16 + 25 na-hn 16 26 + 26 na-hn 16 27 + 27 c2-c2 17 18 + 28 c2-hc 17 28 + 29 c2-hc 17 29 + 30 c2-hc 18 30 + 31 c2-hc 18 31 + 32 c2-hc 32 39 + 33 c2-c3 32 33 + 34 c2-hc 32 38 + 35 c3-oc 33 35 + 36 c2-c3 34 33 + 37 c3-hc 33 40 + 38 c2-oc 34 37 + 39 c2-hc 34 41 + 40 c2-hc 34 42 + 41 cp-oc 37 36 + +Angles + + 1 c3-c2-hc 2 1 8 + 2 hc-c2-hc 8 1 7 + 3 hc-c2-na 8 1 15 + 4 c3-c2-hc 2 1 7 + 5 c3-c2-na 2 1 15 + 6 hc-c2-na 7 1 15 + 7 c2-c3-c2 1 2 3 + 8 c2-c3-hc 1 2 9 + 9 c2-c3-oc 1 2 4 + 10 c2-c3-hc 3 2 9 + 11 c2-c3-oc 3 2 4 + 12 oc-c3-hc 4 2 9 + 13 c3-c2-oc 2 3 6 + 14 c3-c2-hc 2 3 10 + 15 c3-c2-hc 2 3 11 + 16 oc-c2-hc 6 3 10 + 17 oc-c2-hc 6 3 11 + 18 hc-c2-hc 10 3 11 + 19 c3-oc-ho 2 4 25 + 20 c2-oc-cp 3 6 5 + 21 c2-na-c2 13 12 18 + 22 c2-na-hn 13 12 19 + 23 c2-na-hn 18 12 19 + 24 c2-c2-na 14 13 12 + 25 hc-c2-na 20 13 12 + 26 hc-c2-na 21 13 12 + 27 c2-c2-hc 14 13 20 + 28 c2-c2-hc 14 13 21 + 29 hc-c2-hc 20 13 21 + 30 c2-c2-na 13 14 15 + 31 c2-c2-hc 13 14 22 + 32 c2-c2-hc 13 14 23 + 33 hc-c2-na 22 14 15 + 34 hc-c2-na 23 14 15 + 35 hc-c2-hc 22 14 23 + 36 c2-na-c2 1 15 14 + 37 c2-na-hn 1 15 24 + 38 c2-na-c2 1 15 32 + 39 c2-na-hn 14 15 24 + 40 c2-na-c2 14 15 32 + 41 c2-na-hn 32 15 24 + 42 c2-na-hn 17 16 26 + 43 c2-na-hn 17 16 27 + 44 hn-na-hn 26 16 27 + 45 c2-c2-na 18 17 16 + 46 hc-c2-na 28 17 16 + 47 hc-c2-na 29 17 16 + 48 c2-c2-hc 18 17 28 + 49 c2-c2-hc 18 17 29 + 50 hc-c2-hc 28 17 29 + 51 c2-c2-na 17 18 12 + 52 hc-c2-na 30 18 12 + 53 hc-c2-na 31 18 12 + 54 c2-c2-hc 17 18 30 + 55 c2-c2-hc 17 18 31 + 56 hc-c2-hc 30 18 31 + 57 hc-c2-na 39 32 15 + 58 c3-c2-na 33 32 15 + 59 hc-c2-na 38 32 15 + 60 c3-c2-hc 33 32 39 + 61 hc-c2-hc 39 32 38 + 62 c3-c2-hc 33 32 38 + 63 c2-c3-oc 32 33 35 + 64 c2-c3-c2 32 33 34 + 65 c2-c3-hc 32 33 40 + 66 c2-c3-oc 34 33 35 + 67 oc-c3-hc 35 33 40 + 68 c2-c3-hc 34 33 40 + 69 c3-c2-oc 33 34 37 + 70 c3-c2-hc 33 34 41 + 71 c3-c2-hc 33 34 42 + 72 oc-c2-hc 37 34 41 + 73 oc-c2-hc 37 34 42 + 74 hc-c2-hc 41 34 42 + 75 c2-oc-cp 34 37 36 + +Dihedrals + + 1 hc-c2-c3-c2 8 1 2 3 + 2 hc-c2-c3-hc 8 1 2 9 + 3 hc-c2-c3-oc 8 1 2 4 + 4 hc-c2-c3-c2 7 1 2 3 + 5 hc-c2-c3-hc 7 1 2 9 + 6 hc-c2-c3-oc 7 1 2 4 + 7 na-c2-c3-c2 15 1 2 3 + 8 na-c2-c3-hc 15 1 2 9 + 9 na-c2-c3-oc 15 1 2 4 + 10 hc-c2-na-c2 8 1 15 14 + 11 hc-c2-na-hn 8 1 15 24 + 12 hc-c2-na-c2 8 1 15 32 + 13 c3-c2-na-c2 2 1 15 14 + 14 c3-c2-na-hn 2 1 15 24 + 15 c3-c2-na-c2 2 1 15 32 + 16 hc-c2-na-c2 7 1 15 14 + 17 hc-c2-na-hn 7 1 15 24 + 18 hc-c2-na-c2 7 1 15 32 + 19 oc-c2-c3-c2 6 3 2 1 + 20 hc-c2-c3-c2 10 3 2 1 + 21 hc-c2-c3-c2 11 3 2 1 + 22 oc-c2-c3-hc 6 3 2 9 + 23 hc-c2-c3-hc 10 3 2 9 + 24 hc-c2-c3-hc 11 3 2 9 + 25 oc-c2-c3-oc 6 3 2 4 + 26 hc-c2-c3-oc 10 3 2 4 + 27 hc-c2-c3-oc 11 3 2 4 + 28 c2-c3-oc-ho 1 2 4 25 + 29 c2-c3-oc-ho 3 2 4 25 + 30 hc-c3-oc-ho 9 2 4 25 + 31 c3-c2-oc-cp 2 3 6 5 + 32 hc-c2-oc-cp 10 3 6 5 + 33 hc-c2-oc-cp 11 3 6 5 + 34 c2-c2-na-c2 14 13 12 18 + 35 hc-c2-na-c2 20 13 12 18 + 36 hc-c2-na-c2 21 13 12 18 + 37 c2-c2-na-hn 14 13 12 19 + 38 hc-c2-na-hn 20 13 12 19 + 39 hc-c2-na-hn 21 13 12 19 + 40 c2-c2-na-c2 17 18 12 13 + 41 hc-c2-na-c2 30 18 12 13 + 42 hc-c2-na-c2 31 18 12 13 + 43 c2-c2-na-hn 17 18 12 19 + 44 hc-c2-na-hn 30 18 12 19 + 45 hc-c2-na-hn 31 18 12 19 + 46 na-c2-c2-na 12 13 14 15 + 47 hc-c2-c2-na 22 14 13 12 + 48 hc-c2-c2-na 23 14 13 12 + 49 hc-c2-c2-na 20 13 14 15 + 50 hc-c2-c2-hc 20 13 14 22 + 51 hc-c2-c2-hc 20 13 14 23 + 52 hc-c2-c2-na 21 13 14 15 + 53 hc-c2-c2-hc 21 13 14 22 + 54 hc-c2-c2-hc 21 13 14 23 + 55 c2-c2-na-c2 13 14 15 1 + 56 c2-c2-na-hn 13 14 15 24 + 57 c2-c2-na-c2 13 14 15 32 + 58 hc-c2-na-c2 22 14 15 1 + 59 hc-c2-na-hn 22 14 15 24 + 60 hc-c2-na-c2 22 14 15 32 + 61 hc-c2-na-c2 23 14 15 1 + 62 hc-c2-na-hn 23 14 15 24 + 63 hc-c2-na-c2 23 14 15 32 + 64 hc-c2-na-c2 39 32 15 1 + 65 c3-c2-na-c2 33 32 15 1 + 66 hc-c2-na-c2 38 32 15 1 + 67 hc-c2-na-c2 39 32 15 14 + 68 c3-c2-na-c2 33 32 15 14 + 69 hc-c2-na-c2 38 32 15 14 + 70 hc-c2-na-hn 39 32 15 24 + 71 c3-c2-na-hn 33 32 15 24 + 72 hc-c2-na-hn 38 32 15 24 + 73 c2-c2-na-hn 18 17 16 26 + 74 hc-c2-na-hn 28 17 16 26 + 75 hc-c2-na-hn 29 17 16 26 + 76 c2-c2-na-hn 18 17 16 27 + 77 hc-c2-na-hn 28 17 16 27 + 78 hc-c2-na-hn 29 17 16 27 + 79 na-c2-c2-na 16 17 18 12 + 80 hc-c2-c2-na 30 18 17 16 + 81 hc-c2-c2-na 31 18 17 16 + 82 hc-c2-c2-na 28 17 18 12 + 83 hc-c2-c2-hc 28 17 18 30 + 84 hc-c2-c2-hc 28 17 18 31 + 85 hc-c2-c2-na 29 17 18 12 + 86 hc-c2-c2-hc 29 17 18 30 + 87 hc-c2-c2-hc 29 17 18 31 + 88 na-c2-c3-oc 15 32 33 35 + 89 na-c2-c3-c2 15 32 33 34 + 90 na-c2-c3-hc 15 32 33 40 + 91 hc-c2-c3-oc 39 32 33 35 + 92 hc-c2-c3-c2 39 32 33 34 + 93 hc-c2-c3-hc 39 32 33 40 + 94 hc-c2-c3-oc 38 32 33 35 + 95 hc-c2-c3-c2 38 32 33 34 + 96 hc-c2-c3-hc 38 32 33 40 + 97 oc-c2-c3-c2 37 34 33 32 + 98 hc-c2-c3-c2 41 34 33 32 + 99 hc-c2-c3-c2 42 34 33 32 + 100 oc-c2-c3-oc 37 34 33 35 + 101 hc-c2-c3-oc 41 34 33 35 + 102 hc-c2-c3-oc 42 34 33 35 + 103 oc-c2-c3-hc 37 34 33 40 + 104 hc-c2-c3-hc 41 34 33 40 + 105 hc-c2-c3-hc 42 34 33 40 + 106 c3-c2-oc-cp 33 34 37 36 + 107 hc-c2-oc-cp 41 34 37 36 + 108 hc-c2-oc-cp 42 34 37 36 + +Impropers + + 1 c2-na-c2-hn 13 12 18 19 + 2 c2-na-hn-hn 17 16 26 27 diff --git a/examples/PACKAGES/reaction/tiny_epoxy/rxn2_stp1_pre.data_template b/examples/PACKAGES/reaction/tiny_epoxy/rxn2_stp1_pre.data_template deleted file mode 100644 index 9ee4ffb2de..0000000000 --- a/examples/PACKAGES/reaction/tiny_epoxy/rxn2_stp1_pre.data_template +++ /dev/null @@ -1,407 +0,0 @@ -rxn2_stp1_pre - -42 atoms -41 bonds -73 angles -96 dihedrals -43 impropers - -Types - -1 1 -2 6 -3 1 -4 7 -5 4 -6 7 -7 8 -8 8 -9 8 -10 8 -11 8 -12 9 -13 1 -14 1 -15 9 -16 9 -17 1 -18 1 -19 10 -20 8 -21 8 -22 8 -23 8 -24 10 -25 11 -26 10 -27 10 -28 8 -29 8 -30 8 -31 8 -32 2 -33 2 -34 1 -35 3 -36 4 -37 7 -38 8 -39 8 -40 8 -41 8 -42 8 - -Charges - -1 0.000000 -2 0.000000 -3 0.000000 -4 0.100000 -5 0.000000 -6 0.000000 -7 0.000000 -8 0.000000 -9 0.000000 -10 0.000000 -11 0.000000 -12 0.000000 -13 0.000000 -14 0.000000 -15 -0.025000 -16 -0.025000 -17 0.000000 -18 0.000000 -19 0.000000 -20 0.000000 -21 0.000000 -22 0.000000 -23 0.000000 -24 0.000000 -25 0.000000 -26 0.000000 -27 0.000000 -28 0.000000 -29 0.000000 -30 0.000000 -31 0.000000 -32 0.000000 -33 0.000000 -34 0.000000 -35 0.100000 -36 0.000000 -37 0.000000 -38 0.000000 -39 0.000000 -40 0.000000 -41 0.000000 -42 0.000000 - -Coords - -1 19.846411 9.569080 -1.229960 -2 21.168550 9.331390 -0.418120 -3 21.253010 8.067940 0.460720 -4 21.330839 10.304280 -0.253340 -5 21.891689 5.906200 0.464150 -6 21.818470 6.999870 -0.296270 -7 19.931601 10.026600 -2.215510 -8 19.051279 8.828540 -1.132880 -9 22.228800 9.293580 -0.665280 -10 21.880541 8.270810 1.328060 -11 20.253151 7.789050 0.792640 -12 16.072720 12.338940 -0.174630 -13 16.557051 11.130580 0.587500 -14 18.074381 10.998730 0.366590 -15 18.354031 10.832100 -1.107140 -16 14.920880 15.018100 -0.201130 -17 16.390551 14.791140 -0.461060 -18 16.852989 13.538490 0.304530 -19 16.264271 12.190330 -1.257620 -20 16.025061 10.195290 0.210910 -21 16.346741 11.269890 1.698950 -22 18.466690 10.092460 0.935470 -23 18.592319 11.941150 0.745170 -24 17.213690 10.780300 -1.896260 -25 20.881861 11.302060 -0.773030 -26 14.344180 14.136430 -0.550280 -27 14.583670 15.922830 -0.748110 -28 16.984310 15.696060 -0.103470 -29 16.562460 14.639560 -1.577590 -30 16.674610 13.686010 1.420370 -31 17.964001 13.363150 0.117750 -32 18.703360 9.118830 -4.174240 -33 18.099751 8.263650 -5.343000 -34 19.081829 7.609610 -6.334180 -35 17.971729 9.827680 -5.367080 -36 20.263880 5.733600 -6.736780 -37 19.414030 6.299980 -5.878960 -38 18.194740 9.091640 -3.210950 -39 19.788940 9.208560 -4.119640 -40 17.399309 7.432220 -5.407800 -41 18.616249 7.545570 -7.316910 -42 19.987049 8.212500 -6.399400 - -Bonds - -1 1 1 8 -2 16 1 2 -3 1 1 7 -4 13 1 15 -5 16 3 2 -6 12 2 9 -7 17 2 4 -8 3 3 6 -9 1 3 10 -10 1 3 11 -11 18 4 25 -12 8 6 5 -13 13 13 12 -14 13 18 12 -15 14 12 19 -16 15 13 14 -17 1 13 20 -18 1 13 21 -19 13 14 15 -20 1 14 22 -21 1 14 23 -22 14 15 24 -23 13 17 16 -24 14 16 26 -25 14 16 27 -26 15 17 18 -27 1 17 28 -28 1 17 29 -29 1 18 30 -30 1 18 31 -31 6 39 32 -32 4 32 35 -33 5 32 33 -34 6 38 32 -35 4 33 35 -36 2 34 33 -37 6 40 33 -38 3 34 37 -39 1 34 41 -40 1 34 42 -41 8 37 36 - -Angles - -1 30 2 1 8 -2 2 8 1 7 -3 26 8 1 15 -4 30 2 1 7 -5 31 2 1 15 -6 26 7 1 15 -7 32 1 2 3 -8 33 1 2 9 -9 34 1 2 4 -10 33 3 2 9 -11 34 3 2 4 -12 35 4 2 9 -13 36 2 3 6 -14 30 2 3 10 -15 30 2 3 11 -16 3 6 3 10 -17 3 6 3 11 -18 2 10 3 11 -19 37 2 4 25 -20 22 3 6 5 -21 23 13 12 18 -22 24 13 12 19 -23 24 18 12 19 -24 25 14 13 12 -25 26 20 13 12 -26 26 21 13 12 -27 27 14 13 20 -28 27 14 13 21 -29 2 20 13 21 -30 25 13 14 15 -31 27 13 14 22 -32 27 13 14 23 -33 26 22 14 15 -34 26 23 14 15 -35 2 22 14 23 -36 23 1 15 14 -37 24 1 15 24 -38 24 14 15 24 -39 24 17 16 26 -40 24 17 16 27 -41 28 26 16 27 -42 25 18 17 16 -43 26 28 17 16 -44 26 29 17 16 -45 27 18 17 28 -46 27 18 17 29 -47 2 28 17 29 -48 25 17 18 12 -49 26 30 18 12 -50 26 31 18 12 -51 27 17 18 30 -52 27 17 18 31 -53 2 30 18 31 -54 38 39 32 35 -55 39 39 32 33 -56 11 39 32 38 -57 8 33 32 35 -58 38 38 32 35 -59 39 38 32 33 -60 8 32 33 35 -61 6 34 33 32 -62 39 40 33 32 -63 5 34 33 35 -64 38 40 33 35 -65 7 34 33 40 -66 40 37 34 33 -67 41 41 34 33 -68 41 42 34 33 -69 3 37 34 41 -70 3 37 34 42 -71 2 41 34 42 -72 12 32 35 33 -73 22 34 37 36 - -Dihedrals - -1 40 8 1 2 3 -2 41 8 1 2 9 -3 42 8 1 2 4 -4 40 7 1 2 3 -5 41 7 1 2 9 -6 42 7 1 2 4 -7 43 15 1 2 3 -8 44 15 1 2 9 -9 45 15 1 2 4 -10 28 8 1 15 14 -11 30 8 1 15 24 -12 46 2 1 15 14 -13 47 2 1 15 24 -14 28 7 1 15 14 -15 30 7 1 15 24 -16 48 6 3 2 1 -17 40 10 3 2 1 -18 40 11 3 2 1 -19 49 6 3 2 9 -20 41 10 3 2 9 -21 41 11 3 2 9 -22 50 6 3 2 4 -23 42 10 3 2 4 -24 42 11 3 2 4 -25 52 1 2 4 25 -26 52 3 2 4 25 -27 53 9 2 4 25 -28 51 2 3 6 5 -29 7 10 3 6 5 -30 7 11 3 6 5 -31 27 14 13 12 18 -32 28 20 13 12 18 -33 28 21 13 12 18 -34 29 14 13 12 19 -35 30 20 13 12 19 -36 30 21 13 12 19 -37 27 17 18 12 13 -38 28 30 18 12 13 -39 28 31 18 12 13 -40 29 17 18 12 19 -41 30 30 18 12 19 -42 30 31 18 12 19 -43 31 12 13 14 15 -44 32 22 14 13 12 -45 32 23 14 13 12 -46 32 20 13 14 15 -47 33 20 13 14 22 -48 33 20 13 14 23 -49 32 21 13 14 15 -50 33 21 13 14 22 -51 33 21 13 14 23 -52 27 13 14 15 1 -53 29 13 14 15 24 -54 28 22 14 15 1 -55 30 22 14 15 24 -56 28 23 14 15 1 -57 30 23 14 15 24 -58 29 18 17 16 26 -59 30 28 17 16 26 -60 30 29 17 16 26 -61 29 18 17 16 27 -62 30 28 17 16 27 -63 30 29 17 16 27 -64 31 16 17 18 12 -65 32 30 18 17 16 -66 32 31 18 17 16 -67 32 28 17 18 12 -68 33 28 17 18 30 -69 33 28 17 18 31 -70 32 29 17 18 12 -71 33 29 17 18 30 -72 33 29 17 18 31 -73 10 39 32 35 33 -74 10 38 32 35 33 -75 54 39 32 33 35 -76 12 34 33 32 39 -77 14 39 32 33 40 -78 11 34 33 32 35 -79 54 40 33 32 35 -80 54 38 32 33 35 -81 12 34 33 32 38 -82 14 38 32 33 40 -83 9 34 33 35 32 -84 10 40 33 35 32 -85 5 37 34 33 32 -86 2 41 34 33 32 -87 2 42 34 33 32 -88 4 37 34 33 35 -89 1 41 34 33 35 -90 1 42 34 33 35 -91 6 37 34 33 40 -92 3 41 34 33 40 -93 3 42 34 33 40 -94 8 33 34 37 36 -95 7 41 34 37 36 -96 7 42 34 37 36 - -Impropers - -1 4 13 12 18 19 -2 4 1 15 14 24 -3 5 17 16 26 27 -4 1 2 1 8 7 -5 1 2 1 8 15 -6 1 8 1 7 15 -7 1 2 1 7 15 -8 1 1 2 3 9 -9 1 1 2 3 4 -10 1 1 2 4 9 -11 1 3 2 4 9 -12 1 2 3 6 10 -13 1 2 3 6 11 -14 1 2 3 10 11 -15 1 6 3 10 11 -16 1 14 13 20 12 -17 1 14 13 21 12 -18 1 20 13 21 12 -19 1 14 13 20 21 -20 1 13 14 22 15 -21 1 13 14 23 15 -22 1 13 14 22 23 -23 1 22 14 23 15 -24 1 18 17 28 16 -25 1 18 17 29 16 -26 1 28 17 29 16 -27 1 18 17 28 29 -28 1 17 18 30 12 -29 1 17 18 31 12 -30 1 30 18 31 12 -31 1 17 18 30 31 -32 1 39 32 33 35 -33 1 39 32 38 35 -34 1 39 32 38 33 -35 1 38 32 33 35 -36 1 34 33 32 35 -37 1 40 33 32 35 -38 1 34 33 40 32 -39 1 34 33 40 35 -40 1 37 34 41 33 -41 1 37 34 42 33 -42 1 41 34 42 33 -43 1 37 34 41 42 diff --git a/examples/PACKAGES/reaction/tiny_epoxy/rxn2_stp1_pre.molecule_template b/examples/PACKAGES/reaction/tiny_epoxy/rxn2_stp1_pre.molecule_template new file mode 100644 index 0000000000..e729db51df --- /dev/null +++ b/examples/PACKAGES/reaction/tiny_epoxy/rxn2_stp1_pre.molecule_template @@ -0,0 +1,412 @@ +rxn2_stp1_pre + + 42 atoms + 41 bonds + 73 angles + 96 dihedrals + 3 impropers + +Coords + + 1 19.846410751 9.569080353 -1.229959965 + 2 21.168550491 9.331390381 -0.418119997 + 3 21.253009796 8.067939758 0.460720003 + 4 21.330839157 10.304280281 -0.253340006 + 5 21.891689301 5.906199932 0.464150012 + 6 21.818470001 6.999869823 -0.296270013 + 7 19.931600571 10.026599884 -2.215509892 + 8 19.051279068 8.828539848 -1.132879972 + 9 22.228799820 9.293580055 -0.665279984 + 10 21.880540848 8.270810127 1.328060031 + 11 20.253150940 7.789050102 0.792639971 + 12 16.072719574 12.338939667 -0.174630001 + 13 16.557050705 11.130579948 0.587499976 + 14 18.074380875 10.998729706 0.366589993 + 15 18.354030609 10.832099915 -1.107139945 + 16 14.920880318 15.018099785 -0.201130003 + 17 16.390550613 14.791139603 -0.461059988 + 18 16.852989197 13.538490295 0.304529995 + 19 16.264270782 12.190329552 -1.257619977 + 20 16.025060654 10.195289612 0.210910007 + 21 16.346740723 11.269889832 1.698950052 + 22 18.466690063 10.092459679 0.935469985 + 23 18.592319489 11.941149712 0.745169997 + 24 17.213689804 10.780300140 -1.896260023 + 25 20.881860733 11.302060127 -0.773029983 + 26 14.344180107 14.136429787 -0.550279975 + 27 14.583669662 15.922829628 -0.748109996 + 28 16.984310150 15.696060181 -0.103469998 + 29 16.562459946 14.639559746 -1.577589989 + 30 16.674610138 13.686010361 1.420369983 + 31 17.964000702 13.363149643 0.117749996 + 32 18.703359604 9.118829727 -4.174240112 + 33 18.099750519 8.263649940 -5.342999935 + 34 19.081829071 7.609610081 -6.334179878 + 35 17.971729279 9.827679634 -5.367080212 + 36 20.263879776 5.733600140 -6.736780167 + 37 19.414030075 6.299980164 -5.878960133 + 38 18.194740295 9.091640472 -3.210949898 + 39 19.788940430 9.208559990 -4.119639874 + 40 17.399309158 7.432219982 -5.407800198 + 41 18.616249084 7.545569897 -7.316909790 + 42 19.987049103 8.212499619 -6.399400234 + +Types + + 1 c2 + 2 c3 + 3 c2 + 4 oc + 5 cp + 6 oc + 7 hc + 8 hc + 9 hc + 10 hc + 11 hc + 12 na + 13 c2 + 14 c2 + 15 na + 16 na + 17 c2 + 18 c2 + 19 hn + 20 hc + 21 hc + 22 hc + 23 hc + 24 hn + 25 ho + 26 hn + 27 hn + 28 hc + 29 hc + 30 hc + 31 hc + 32 c3m + 33 c3m + 34 c2 + 35 o3e + 36 cp + 37 oc + 38 hc + 39 hc + 40 hc + 41 hc + 42 hc + +Charges + + 1 0.000000 + 2 0.000000 + 3 0.000000 + 4 0.100000 + 5 0.000000 + 6 0.000000 + 7 0.000000 + 8 0.000000 + 9 0.000000 + 10 0.000000 + 11 0.000000 + 12 0.000000 + 13 0.000000 + 14 0.000000 + 15 -0.025000 + 16 -0.025000 + 17 0.000000 + 18 0.000000 + 19 0.000000 + 20 0.000000 + 21 0.000000 + 22 0.000000 + 23 0.000000 + 24 0.000000 + 25 0.000000 + 26 0.000000 + 27 0.000000 + 28 0.000000 + 29 0.000000 + 30 0.000000 + 31 0.000000 + 32 0.000000 + 33 0.000000 + 34 0.000000 + 35 0.100000 + 36 0.000000 + 37 0.000000 + 38 0.000000 + 39 0.000000 + 40 0.000000 + 41 0.000000 + 42 0.000000 + +Molecules + + 1 1 + 2 1 + 3 1 + 4 1 + 5 1 + 6 1 + 7 1 + 8 1 + 9 1 + 10 1 + 11 1 + 12 1 + 13 1 + 14 1 + 15 1 + 16 1 + 17 1 + 18 1 + 19 1 + 20 1 + 21 1 + 22 1 + 23 1 + 24 1 + 25 1 + 26 1 + 27 1 + 28 1 + 29 1 + 30 1 + 31 1 + 32 1 + 33 1 + 34 1 + 35 1 + 36 1 + 37 1 + 38 1 + 39 1 + 40 1 + 41 1 + 42 1 + +Bonds + + 1 c2-hc 1 8 + 2 c2-c3 1 2 + 3 c2-hc 1 7 + 4 c2-na 1 15 + 5 c2-c3 3 2 + 6 c3-hc 2 9 + 7 c3-oc 2 4 + 8 c2-oc 3 6 + 9 c2-hc 3 10 + 10 c2-hc 3 11 + 11 oc-ho 4 25 + 12 cp-oc 6 5 + 13 c2-na 13 12 + 14 c2-na 18 12 + 15 na-hn 12 19 + 16 c2-c2 13 14 + 17 c2-hc 13 20 + 18 c2-hc 13 21 + 19 c2-na 14 15 + 20 c2-hc 14 22 + 21 c2-hc 14 23 + 22 na-hn 15 24 + 23 c2-na 17 16 + 24 na-hn 16 26 + 25 na-hn 16 27 + 26 c2-c2 17 18 + 27 c2-hc 17 28 + 28 c2-hc 17 29 + 29 c2-hc 18 30 + 30 c2-hc 18 31 + 31 c3m-hc 39 32 + 32 c3m-o3e 32 35 + 33 c3m-c3m 32 33 + 34 c3m-hc 38 32 + 35 c3m-o3e 33 35 + 36 c3m-c2 34 33 + 37 c3m-hc 40 33 + 38 c2-oc 34 37 + 39 c2-hc 34 41 + 40 c2-hc 34 42 + 41 cp-oc 37 36 + +Angles + + 1 c3-c2-hc 2 1 8 + 2 hc-c2-hc 8 1 7 + 3 hc-c2-na 8 1 15 + 4 c3-c2-hc 2 1 7 + 5 c3-c2-na 2 1 15 + 6 hc-c2-na 7 1 15 + 7 c2-c3-c2 1 2 3 + 8 c2-c3-hc 1 2 9 + 9 c2-c3-oc 1 2 4 + 10 c2-c3-hc 3 2 9 + 11 c2-c3-oc 3 2 4 + 12 oc-c3-hc 4 2 9 + 13 c3-c2-oc 2 3 6 + 14 c3-c2-hc 2 3 10 + 15 c3-c2-hc 2 3 11 + 16 oc-c2-hc 6 3 10 + 17 oc-c2-hc 6 3 11 + 18 hc-c2-hc 10 3 11 + 19 c3-oc-ho 2 4 25 + 20 c2-oc-cp 3 6 5 + 21 c2-na-c2 13 12 18 + 22 c2-na-hn 13 12 19 + 23 c2-na-hn 18 12 19 + 24 c2-c2-na 14 13 12 + 25 hc-c2-na 20 13 12 + 26 hc-c2-na 21 13 12 + 27 c2-c2-hc 14 13 20 + 28 c2-c2-hc 14 13 21 + 29 hc-c2-hc 20 13 21 + 30 c2-c2-na 13 14 15 + 31 c2-c2-hc 13 14 22 + 32 c2-c2-hc 13 14 23 + 33 hc-c2-na 22 14 15 + 34 hc-c2-na 23 14 15 + 35 hc-c2-hc 22 14 23 + 36 c2-na-c2 1 15 14 + 37 c2-na-hn 1 15 24 + 38 c2-na-hn 14 15 24 + 39 c2-na-hn 17 16 26 + 40 c2-na-hn 17 16 27 + 41 hn-na-hn 26 16 27 + 42 c2-c2-na 18 17 16 + 43 hc-c2-na 28 17 16 + 44 hc-c2-na 29 17 16 + 45 c2-c2-hc 18 17 28 + 46 c2-c2-hc 18 17 29 + 47 hc-c2-hc 28 17 29 + 48 c2-c2-na 17 18 12 + 49 hc-c2-na 30 18 12 + 50 hc-c2-na 31 18 12 + 51 c2-c2-hc 17 18 30 + 52 c2-c2-hc 17 18 31 + 53 hc-c2-hc 30 18 31 + 54 hc-c3m-o3e 39 32 35 + 55 hc-c3m-c3m 39 32 33 + 56 hc-c3m-hc 39 32 38 + 57 c3m-c3m-o3e 33 32 35 + 58 hc-c3m-o3e 38 32 35 + 59 hc-c3m-c3m 38 32 33 + 60 c3m-c3m-o3e 32 33 35 + 61 c2-c3m-c3m 34 33 32 + 62 hc-c3m-c3m 40 33 32 + 63 c2-c3m-o3e 34 33 35 + 64 hc-c3m-o3e 40 33 35 + 65 c2-c3m-hc 34 33 40 + 66 oc-c2-c3m 37 34 33 + 67 hc-c2-c3m 41 34 33 + 68 hc-c2-c3m 42 34 33 + 69 oc-c2-hc 37 34 41 + 70 oc-c2-hc 37 34 42 + 71 hc-c2-hc 41 34 42 + 72 c3m-o3e-c3m 32 35 33 + 73 c2-oc-cp 34 37 36 + +Dihedrals + + 1 hc-c2-c3-c2 8 1 2 3 + 2 hc-c2-c3-hc 8 1 2 9 + 3 hc-c2-c3-oc 8 1 2 4 + 4 hc-c2-c3-c2 7 1 2 3 + 5 hc-c2-c3-hc 7 1 2 9 + 6 hc-c2-c3-oc 7 1 2 4 + 7 na-c2-c3-c2 15 1 2 3 + 8 na-c2-c3-hc 15 1 2 9 + 9 na-c2-c3-oc 15 1 2 4 + 10 hc-c2-na-c2 8 1 15 14 + 11 hc-c2-na-hn 8 1 15 24 + 12 c3-c2-na-c2 2 1 15 14 + 13 c3-c2-na-hn 2 1 15 24 + 14 hc-c2-na-c2 7 1 15 14 + 15 hc-c2-na-hn 7 1 15 24 + 16 oc-c2-c3-c2 6 3 2 1 + 17 hc-c2-c3-c2 10 3 2 1 + 18 hc-c2-c3-c2 11 3 2 1 + 19 oc-c2-c3-hc 6 3 2 9 + 20 hc-c2-c3-hc 10 3 2 9 + 21 hc-c2-c3-hc 11 3 2 9 + 22 oc-c2-c3-oc 6 3 2 4 + 23 hc-c2-c3-oc 10 3 2 4 + 24 hc-c2-c3-oc 11 3 2 4 + 25 c2-c3-oc-ho 1 2 4 25 + 26 c2-c3-oc-ho 3 2 4 25 + 27 hc-c3-oc-ho 9 2 4 25 + 28 c3-c2-oc-cp 2 3 6 5 + 29 hc-c2-oc-cp 10 3 6 5 + 30 hc-c2-oc-cp 11 3 6 5 + 31 c2-c2-na-c2 14 13 12 18 + 32 hc-c2-na-c2 20 13 12 18 + 33 hc-c2-na-c2 21 13 12 18 + 34 c2-c2-na-hn 14 13 12 19 + 35 hc-c2-na-hn 20 13 12 19 + 36 hc-c2-na-hn 21 13 12 19 + 37 c2-c2-na-c2 17 18 12 13 + 38 hc-c2-na-c2 30 18 12 13 + 39 hc-c2-na-c2 31 18 12 13 + 40 c2-c2-na-hn 17 18 12 19 + 41 hc-c2-na-hn 30 18 12 19 + 42 hc-c2-na-hn 31 18 12 19 + 43 na-c2-c2-na 12 13 14 15 + 44 hc-c2-c2-na 22 14 13 12 + 45 hc-c2-c2-na 23 14 13 12 + 46 hc-c2-c2-na 20 13 14 15 + 47 hc-c2-c2-hc 20 13 14 22 + 48 hc-c2-c2-hc 20 13 14 23 + 49 hc-c2-c2-na 21 13 14 15 + 50 hc-c2-c2-hc 21 13 14 22 + 51 hc-c2-c2-hc 21 13 14 23 + 52 c2-c2-na-c2 13 14 15 1 + 53 c2-c2-na-hn 13 14 15 24 + 54 hc-c2-na-c2 22 14 15 1 + 55 hc-c2-na-hn 22 14 15 24 + 56 hc-c2-na-c2 23 14 15 1 + 57 hc-c2-na-hn 23 14 15 24 + 58 c2-c2-na-hn 18 17 16 26 + 59 hc-c2-na-hn 28 17 16 26 + 60 hc-c2-na-hn 29 17 16 26 + 61 c2-c2-na-hn 18 17 16 27 + 62 hc-c2-na-hn 28 17 16 27 + 63 hc-c2-na-hn 29 17 16 27 + 64 na-c2-c2-na 16 17 18 12 + 65 hc-c2-c2-na 30 18 17 16 + 66 hc-c2-c2-na 31 18 17 16 + 67 hc-c2-c2-na 28 17 18 12 + 68 hc-c2-c2-hc 28 17 18 30 + 69 hc-c2-c2-hc 28 17 18 31 + 70 hc-c2-c2-na 29 17 18 12 + 71 hc-c2-c2-hc 29 17 18 30 + 72 hc-c2-c2-hc 29 17 18 31 + 73 hc-c3m-o3e-c3m 39 32 35 33 + 74 hc-c3m-o3e-c3m 38 32 35 33 + 75 hc-c3m-c3m-o3e 39 32 33 35 + 76 c2-c3m-c3m-hc 34 33 32 39 + 77 hc-c3m-c3m-hc 39 32 33 40 + 78 c2-c3m-c3m-o3e 34 33 32 35 + 79 hc-c3m-c3m-o3e 40 33 32 35 + 80 hc-c3m-c3m-o3e 38 32 33 35 + 81 c2-c3m-c3m-hc 34 33 32 38 + 82 hc-c3m-c3m-hc 38 32 33 40 + 83 c2-c3m-o3e-c3m 34 33 35 32 + 84 hc-c3m-o3e-c3m 40 33 35 32 + 85 oc-c2-c3m-c3m 37 34 33 32 + 86 hc-c2-c3m-c3m 41 34 33 32 + 87 hc-c2-c3m-c3m 42 34 33 32 + 88 oc-c2-c3m-o3e 37 34 33 35 + 89 hc-c2-c3m-o3e 41 34 33 35 + 90 hc-c2-c3m-o3e 42 34 33 35 + 91 oc-c2-c3m-hc 37 34 33 40 + 92 hc-c2-c3m-hc 41 34 33 40 + 93 hc-c2-c3m-hc 42 34 33 40 + 94 c3m-c2-oc-cp 33 34 37 36 + 95 hc-c2-oc-cp 41 34 37 36 + 96 hc-c2-oc-cp 42 34 37 36 + +Impropers + + 1 c2-na-c2-hn 13 12 18 19 + 2 c2-na-c2-hn 1 15 14 24 + 3 c2-na-hn-hn 17 16 26 27 diff --git a/examples/PACKAGES/reaction/tiny_epoxy/rxn2_stp2_post.data_template b/examples/PACKAGES/reaction/tiny_epoxy/rxn2_stp2_post.data_template deleted file mode 100644 index 2b37ecff03..0000000000 --- a/examples/PACKAGES/reaction/tiny_epoxy/rxn2_stp2_post.data_template +++ /dev/null @@ -1,413 +0,0 @@ -rxn2_stp2_post - -42 atoms -41 bonds -73 angles -102 dihedrals -43 impropers - -Types - -1 1 -2 2 -3 1 -4 7 -5 4 -6 7 -7 8 -8 8 -9 8 -10 8 -11 8 -12 9 -13 1 -14 1 -15 9 -16 9 -17 1 -18 1 -19 10 -20 8 -21 8 -22 8 -23 8 -24 11 -25 11 -26 10 -27 10 -28 8 -29 8 -30 8 -31 8 -32 1 -33 6 -34 1 -35 7 -36 4 -37 7 -38 8 -39 8 -40 8 -41 8 -42 8 - -Charges - -1 0.000000 -2 0.000000 -3 0.000000 -4 0.100000 -5 0.000000 -6 0.000000 -7 0.000000 -8 0.000000 -9 0.000000 -10 0.000000 -11 0.000000 -12 0.000000 -13 0.000000 -14 0.000000 -15 -0.025000 -16 -0.025000 -17 0.000000 -18 0.000000 -19 0.000000 -20 0.000000 -21 0.000000 -22 0.000000 -23 0.000000 -24 0.000000 -25 0.000000 -26 0.000000 -27 0.000000 -28 0.000000 -29 0.000000 -30 0.000000 -31 0.000000 -32 0.000000 -33 0.000000 -34 0.000000 -35 0.100000 -36 0.000000 -37 0.000000 -38 0.000000 -39 0.000000 -40 0.000000 -41 0.000000 -42 0.000000 - -Coords - -1 19.846411 9.569080 -1.229960 -2 21.168550 9.331390 -0.418120 -3 21.253010 8.067940 0.460720 -4 21.330839 10.304280 -0.253340 -5 21.891689 5.906200 0.464150 -6 21.818470 6.999870 -0.296270 -7 19.931601 10.026600 -2.215510 -8 19.051279 8.828540 -1.132880 -9 22.228800 9.293580 -0.665280 -10 21.880541 8.270810 1.328060 -11 20.253151 7.789050 0.792640 -12 16.072720 12.338940 -0.174630 -13 16.557051 11.130580 0.587500 -14 18.074381 10.998730 0.366590 -15 18.354031 10.832100 -1.107140 -16 14.920880 15.018100 -0.201130 -17 16.390551 14.791140 -0.461060 -18 16.852989 13.538490 0.304530 -19 16.264271 12.190330 -1.257620 -20 16.025061 10.195290 0.210910 -21 16.346741 11.269890 1.698950 -22 18.466690 10.092460 0.935470 -23 18.592319 11.941150 0.745170 -24 16.017490 9.805710 -4.329880 -25 20.881861 11.302060 -0.773030 -26 14.344180 14.136430 -0.550280 -27 14.583670 15.922830 -0.748110 -28 16.984310 15.696060 -0.103470 -29 16.562460 14.639560 -1.577590 -30 16.674610 13.686010 1.420370 -31 17.964001 13.363150 0.117750 -32 18.680189 9.134390 -4.183100 -33 18.099751 8.263650 -5.343000 -34 19.081829 7.609610 -6.334180 -35 17.971729 9.827680 -5.367080 -36 20.263880 5.733600 -6.736780 -37 19.414030 6.299980 -5.878960 -38 18.194740 9.091640 -3.210950 -39 19.788940 9.208560 -4.119640 -40 17.399309 7.432220 -5.407800 -41 18.616249 7.545570 -7.316910 -42 19.987049 8.212500 -6.399400 - -Bonds - -1 1 1 8 -2 2 1 2 -3 1 1 7 -4 13 1 15 -5 2 3 2 -6 6 2 9 -7 19 2 4 -8 3 3 6 -9 1 3 10 -10 1 3 11 -11 18 4 25 -12 8 6 5 -13 13 13 12 -14 13 18 12 -15 14 12 19 -16 15 13 14 -17 1 13 20 -18 1 13 21 -19 13 14 15 -20 1 14 22 -21 1 14 23 -22 13 32 15 -23 13 17 16 -24 14 16 26 -25 14 16 27 -26 15 17 18 -27 1 17 28 -28 1 17 29 -29 1 18 30 -30 1 18 31 -31 18 35 24 -32 1 32 39 -33 16 32 33 -34 1 32 38 -35 17 35 33 -36 16 34 33 -37 12 40 33 -38 3 34 37 -39 1 34 41 -40 1 34 42 -41 8 37 36 - -Angles - -1 1 2 1 8 -2 2 8 1 7 -3 26 8 1 15 -4 1 2 1 7 -5 42 2 1 15 -6 26 7 1 15 -7 43 1 2 3 -8 7 1 2 9 -9 44 1 2 4 -10 7 3 2 9 -11 44 3 2 4 -12 45 4 2 9 -13 4 2 3 6 -14 1 2 3 10 -15 1 2 3 11 -16 3 6 3 10 -17 3 6 3 11 -18 2 10 3 11 -19 46 2 4 25 -20 22 3 6 5 -21 23 13 12 18 -22 24 13 12 19 -23 24 18 12 19 -24 25 14 13 12 -25 26 20 13 12 -26 26 21 13 12 -27 27 14 13 20 -28 27 14 13 21 -29 2 20 13 21 -30 25 13 14 15 -31 27 13 14 22 -32 27 13 14 23 -33 26 22 14 15 -34 26 23 14 15 -35 2 22 14 23 -36 23 1 15 14 -37 23 1 15 32 -38 23 14 15 32 -39 24 17 16 26 -40 24 17 16 27 -41 28 26 16 27 -42 25 18 17 16 -43 26 28 17 16 -44 26 29 17 16 -45 27 18 17 28 -46 27 18 17 29 -47 2 28 17 29 -48 25 17 18 12 -49 26 30 18 12 -50 26 31 18 12 -51 27 17 18 30 -52 27 17 18 31 -53 2 30 18 31 -54 26 39 32 15 -55 47 15 32 33 -56 26 38 32 15 -57 48 39 32 33 -58 2 39 32 38 -59 48 38 32 33 -60 34 32 33 35 -61 32 32 33 34 -62 33 32 33 40 -63 34 34 33 35 -64 35 35 33 40 -65 33 34 33 40 -66 49 37 34 33 -67 48 41 34 33 -68 48 42 34 33 -69 3 37 34 41 -70 3 37 34 42 -71 2 41 34 42 -72 50 24 35 33 -73 22 34 37 36 - -Dihedrals - -1 55 8 1 2 3 -2 3 8 1 2 9 -3 56 8 1 2 4 -4 55 7 1 2 3 -5 3 7 1 2 9 -6 56 7 1 2 4 -7 57 15 1 2 3 -8 58 15 1 2 9 -9 59 15 1 2 4 -10 28 8 1 15 14 -11 28 8 1 15 32 -12 60 2 1 15 14 -13 60 2 1 15 32 -14 28 7 1 15 14 -15 28 7 1 15 32 -16 61 6 3 2 1 -17 55 10 3 2 1 -18 55 11 3 2 1 -19 6 6 3 2 9 -20 3 10 3 2 9 -21 3 11 3 2 9 -22 62 6 3 2 4 -23 56 10 3 2 4 -24 56 11 3 2 4 -25 63 1 2 4 25 -26 63 3 2 4 25 -27 64 9 2 4 25 -28 8 2 3 6 5 -29 7 10 3 6 5 -30 7 11 3 6 5 -31 27 14 13 12 18 -32 28 20 13 12 18 -33 28 21 13 12 18 -34 29 14 13 12 19 -35 30 20 13 12 19 -36 30 21 13 12 19 -37 27 17 18 12 13 -38 28 30 18 12 13 -39 28 31 18 12 13 -40 29 17 18 12 19 -41 30 30 18 12 19 -42 30 31 18 12 19 -43 31 12 13 14 15 -44 32 22 14 13 12 -45 32 23 14 13 12 -46 32 20 13 14 15 -47 33 20 13 14 22 -48 33 20 13 14 23 -49 32 21 13 14 15 -50 33 21 13 14 22 -51 33 21 13 14 23 -52 27 13 14 15 1 -53 27 13 14 15 32 -54 28 22 14 15 1 -55 28 22 14 15 32 -56 28 23 14 15 1 -57 28 23 14 15 32 -58 28 39 32 15 1 -59 46 33 32 15 1 -60 28 38 32 15 1 -61 28 39 32 15 14 -62 46 33 32 15 14 -63 28 38 32 15 14 -64 29 18 17 16 26 -65 30 28 17 16 26 -66 30 29 17 16 26 -67 29 18 17 16 27 -68 30 28 17 16 27 -69 30 29 17 16 27 -70 31 16 17 18 12 -71 32 30 18 17 16 -72 32 31 18 17 16 -73 32 28 17 18 12 -74 33 28 17 18 30 -75 33 28 17 18 31 -76 32 29 17 18 12 -77 33 29 17 18 30 -78 33 29 17 18 31 -79 45 15 32 33 35 -80 43 15 32 33 34 -81 44 15 32 33 40 -82 42 39 32 33 35 -83 40 39 32 33 34 -84 41 39 32 33 40 -85 42 38 32 33 35 -86 40 38 32 33 34 -87 41 38 32 33 40 -88 65 24 35 33 32 -89 65 24 35 33 34 -90 66 24 35 33 40 -91 48 37 34 33 32 -92 40 41 34 33 32 -93 40 42 34 33 32 -94 50 37 34 33 35 -95 42 41 34 33 35 -96 42 42 34 33 35 -97 49 37 34 33 40 -98 41 41 34 33 40 -99 41 42 34 33 40 -100 51 33 34 37 36 -101 7 41 34 37 36 -102 7 42 34 37 36 - -Impropers - -1 4 13 12 18 19 -2 22 1 15 14 32 -3 5 17 16 26 27 -4 1 2 1 8 7 -5 1 2 1 8 15 -6 1 8 1 7 15 -7 1 2 1 7 15 -8 1 1 2 3 9 -9 1 1 2 3 4 -10 1 1 2 4 9 -11 1 3 2 4 9 -12 1 2 3 6 10 -13 1 2 3 6 11 -14 1 2 3 10 11 -15 1 6 3 10 11 -16 1 14 13 20 12 -17 1 14 13 21 12 -18 1 20 13 21 12 -19 1 14 13 20 21 -20 1 13 14 22 15 -21 1 13 14 23 15 -22 1 13 14 22 23 -23 1 22 14 23 15 -24 1 18 17 28 16 -25 1 18 17 29 16 -26 1 28 17 29 16 -27 1 18 17 28 29 -28 1 17 18 30 12 -29 1 17 18 31 12 -30 1 30 18 31 12 -31 1 17 18 30 31 -32 1 39 32 15 33 -33 1 39 32 38 15 -34 1 38 32 15 33 -35 1 39 32 38 33 -36 1 32 33 34 35 -37 1 32 33 35 40 -38 1 32 33 34 40 -39 1 34 33 35 40 -40 1 37 34 41 33 -41 1 37 34 42 33 -42 1 41 34 42 33 -43 1 37 34 41 42 diff --git a/examples/PACKAGES/reaction/tiny_epoxy/rxn2_stp2_post.molecule_template b/examples/PACKAGES/reaction/tiny_epoxy/rxn2_stp2_post.molecule_template new file mode 100644 index 0000000000..01a9b7dad4 --- /dev/null +++ b/examples/PACKAGES/reaction/tiny_epoxy/rxn2_stp2_post.molecule_template @@ -0,0 +1,418 @@ +rxn2_stp2_post + + 42 atoms + 41 bonds + 73 angles + 102 dihedrals + 3 impropers + +Coords + + 1 19.846410751 9.569080353 -1.229959965 + 2 21.168550491 9.331390381 -0.418119997 + 3 21.253009796 8.067939758 0.460720003 + 4 21.330839157 10.304280281 -0.253340006 + 5 21.891689301 5.906199932 0.464150012 + 6 21.818470001 6.999869823 -0.296270013 + 7 19.931600571 10.026599884 -2.215509892 + 8 19.051279068 8.828539848 -1.132879972 + 9 22.228799820 9.293580055 -0.665279984 + 10 21.880540848 8.270810127 1.328060031 + 11 20.253150940 7.789050102 0.792639971 + 12 16.072719574 12.338939667 -0.174630001 + 13 16.557050705 11.130579948 0.587499976 + 14 18.074380875 10.998729706 0.366589993 + 15 18.354030609 10.832099915 -1.107139945 + 16 14.920880318 15.018099785 -0.201130003 + 17 16.390550613 14.791139603 -0.461059988 + 18 16.852989197 13.538490295 0.304529995 + 19 16.264270782 12.190329552 -1.257619977 + 20 16.025060654 10.195289612 0.210910007 + 21 16.346740723 11.269889832 1.698950052 + 22 18.466690063 10.092459679 0.935469985 + 23 18.592319489 11.941149712 0.745169997 + 24 16.017490387 9.805709839 -4.329880238 + 25 20.881860733 11.302060127 -0.773029983 + 26 14.344180107 14.136429787 -0.550279975 + 27 14.583669662 15.922829628 -0.748109996 + 28 16.984310150 15.696060181 -0.103469998 + 29 16.562459946 14.639559746 -1.577589989 + 30 16.674610138 13.686010361 1.420369983 + 31 17.964000702 13.363149643 0.117749996 + 32 18.680189133 9.134389877 -4.183100224 + 33 18.099750519 8.263649940 -5.342999935 + 34 19.081829071 7.609610081 -6.334179878 + 35 17.971729279 9.827679634 -5.367080212 + 36 20.263879776 5.733600140 -6.736780167 + 37 19.414030075 6.299980164 -5.878960133 + 38 18.194740295 9.091640472 -3.210949898 + 39 19.788940430 9.208559990 -4.119639874 + 40 17.399309158 7.432219982 -5.407800198 + 41 18.616249084 7.545569897 -7.316909790 + 42 19.987049103 8.212499619 -6.399400234 + +Types + + 1 c2 + 2 c3m + 3 c2 + 4 oc + 5 cp + 6 oc + 7 hc + 8 hc + 9 hc + 10 hc + 11 hc + 12 na + 13 c2 + 14 c2 + 15 na + 16 na + 17 c2 + 18 c2 + 19 hn + 20 hc + 21 hc + 22 hc + 23 hc + 24 ho + 25 ho + 26 hn + 27 hn + 28 hc + 29 hc + 30 hc + 31 hc + 32 c2 + 33 c3 + 34 c2 + 35 oc + 36 cp + 37 oc + 38 hc + 39 hc + 40 hc + 41 hc + 42 hc + +Charges + + 1 0.000000 + 2 0.000000 + 3 0.000000 + 4 0.100000 + 5 0.000000 + 6 0.000000 + 7 0.000000 + 8 0.000000 + 9 0.000000 + 10 0.000000 + 11 0.000000 + 12 0.000000 + 13 0.000000 + 14 0.000000 + 15 -0.025000 + 16 -0.025000 + 17 0.000000 + 18 0.000000 + 19 0.000000 + 20 0.000000 + 21 0.000000 + 22 0.000000 + 23 0.000000 + 24 0.000000 + 25 0.000000 + 26 0.000000 + 27 0.000000 + 28 0.000000 + 29 0.000000 + 30 0.000000 + 31 0.000000 + 32 0.000000 + 33 0.000000 + 34 0.000000 + 35 0.100000 + 36 0.000000 + 37 0.000000 + 38 0.000000 + 39 0.000000 + 40 0.000000 + 41 0.000000 + 42 0.000000 + +Molecules + + 1 1 + 2 1 + 3 1 + 4 1 + 5 1 + 6 1 + 7 1 + 8 1 + 9 1 + 10 1 + 11 1 + 12 1 + 13 1 + 14 1 + 15 1 + 16 1 + 17 1 + 18 1 + 19 1 + 20 1 + 21 1 + 22 1 + 23 1 + 24 1 + 25 1 + 26 1 + 27 1 + 28 1 + 29 1 + 30 1 + 31 1 + 32 1 + 33 1 + 34 1 + 35 1 + 36 1 + 37 1 + 38 1 + 39 1 + 40 1 + 41 1 + 42 1 + +Bonds + + 1 c2-hc 1 8 + 2 c3m-c2 1 2 + 3 c2-hc 1 7 + 4 c2-na 1 15 + 5 c3m-c2 3 2 + 6 c3m-hc 2 9 + 7 c3m-oc 2 4 + 8 c2-oc 3 6 + 9 c2-hc 3 10 + 10 c2-hc 3 11 + 11 oc-ho 4 25 + 12 cp-oc 6 5 + 13 c2-na 13 12 + 14 c2-na 18 12 + 15 na-hn 12 19 + 16 c2-c2 13 14 + 17 c2-hc 13 20 + 18 c2-hc 13 21 + 19 c2-na 14 15 + 20 c2-hc 14 22 + 21 c2-hc 14 23 + 22 c2-na 32 15 + 23 c2-na 17 16 + 24 na-hn 16 26 + 25 na-hn 16 27 + 26 c2-c2 17 18 + 27 c2-hc 17 28 + 28 c2-hc 17 29 + 29 c2-hc 18 30 + 30 c2-hc 18 31 + 31 oc-ho 35 24 + 32 c2-hc 32 39 + 33 c2-c3 32 33 + 34 c2-hc 32 38 + 35 c3-oc 35 33 + 36 c2-c3 34 33 + 37 c3-hc 40 33 + 38 c2-oc 34 37 + 39 c2-hc 34 41 + 40 c2-hc 34 42 + 41 cp-oc 37 36 + +Angles + + 1 c3m-c2-hc 2 1 8 + 2 hc-c2-hc 8 1 7 + 3 hc-c2-na 8 1 15 + 4 c3m-c2-hc 2 1 7 + 5 c3m-c2-na 2 1 15 + 6 hc-c2-na 7 1 15 + 7 c2-c3m-c2 1 2 3 + 8 c2-c3m-hc 1 2 9 + 9 c2-c3m-oc 1 2 4 + 10 c2-c3m-hc 3 2 9 + 11 c2-c3m-oc 3 2 4 + 12 oc-c3m-hc 4 2 9 + 13 c3m-c2-oc 2 3 6 + 14 c3m-c2-hc 2 3 10 + 15 c3m-c2-hc 2 3 11 + 16 oc-c2-hc 6 3 10 + 17 oc-c2-hc 6 3 11 + 18 hc-c2-hc 10 3 11 + 19 c3m-oc-ho 2 4 25 + 20 c2-oc-cp 3 6 5 + 21 c2-na-c2 13 12 18 + 22 c2-na-hn 13 12 19 + 23 c2-na-hn 18 12 19 + 24 c2-c2-na 14 13 12 + 25 hc-c2-na 20 13 12 + 26 hc-c2-na 21 13 12 + 27 c2-c2-hc 14 13 20 + 28 c2-c2-hc 14 13 21 + 29 hc-c2-hc 20 13 21 + 30 c2-c2-na 13 14 15 + 31 c2-c2-hc 13 14 22 + 32 c2-c2-hc 13 14 23 + 33 hc-c2-na 22 14 15 + 34 hc-c2-na 23 14 15 + 35 hc-c2-hc 22 14 23 + 36 c2-na-c2 1 15 14 + 37 c2-na-c2 1 15 32 + 38 c2-na-c2 14 15 32 + 39 c2-na-hn 17 16 26 + 40 c2-na-hn 17 16 27 + 41 hn-na-hn 26 16 27 + 42 c2-c2-na 18 17 16 + 43 hc-c2-na 28 17 16 + 44 hc-c2-na 29 17 16 + 45 c2-c2-hc 18 17 28 + 46 c2-c2-hc 18 17 29 + 47 hc-c2-hc 28 17 29 + 48 c2-c2-na 17 18 12 + 49 hc-c2-na 30 18 12 + 50 hc-c2-na 31 18 12 + 51 c2-c2-hc 17 18 30 + 52 c2-c2-hc 17 18 31 + 53 hc-c2-hc 30 18 31 + 54 hc-c2-na 39 32 15 + 55 na-c2-c3 15 32 33 + 56 hc-c2-na 38 32 15 + 57 hc-c2-c3 39 32 33 + 58 hc-c2-hc 39 32 38 + 59 hc-c2-c3 38 32 33 + 60 c2-c3-oc 32 33 35 + 61 c2-c3-c2 32 33 34 + 62 c2-c3-hc 32 33 40 + 63 c2-c3-oc 34 33 35 + 64 oc-c3-hc 35 33 40 + 65 c2-c3-hc 34 33 40 + 66 oc-c2-c3 37 34 33 + 67 hc-c2-c3 41 34 33 + 68 hc-c2-c3 42 34 33 + 69 oc-c2-hc 37 34 41 + 70 oc-c2-hc 37 34 42 + 71 hc-c2-hc 41 34 42 + 72 ho-oc-c3 24 35 33 + 73 c2-oc-cp 34 37 36 + +Dihedrals + + 1 hc-c2-c3m-c2 8 1 2 3 + 2 hc-c2-c3m-hc 8 1 2 9 + 3 hc-c2-c3m-oc 8 1 2 4 + 4 hc-c2-c3m-c2 7 1 2 3 + 5 hc-c2-c3m-hc 7 1 2 9 + 6 hc-c2-c3m-oc 7 1 2 4 + 7 na-c2-c3m-c2 15 1 2 3 + 8 na-c2-c3m-hc 15 1 2 9 + 9 na-c2-c3m-oc 15 1 2 4 + 10 hc-c2-na-c2 8 1 15 14 + 11 hc-c2-na-c2 8 1 15 32 + 12 c3m-c2-na-c2 2 1 15 14 + 13 c3m-c2-na-c2 2 1 15 32 + 14 hc-c2-na-c2 7 1 15 14 + 15 hc-c2-na-c2 7 1 15 32 + 16 oc-c2-c3m-c2 6 3 2 1 + 17 hc-c2-c3m-c2 10 3 2 1 + 18 hc-c2-c3m-c2 11 3 2 1 + 19 oc-c2-c3m-hc 6 3 2 9 + 20 hc-c2-c3m-hc 10 3 2 9 + 21 hc-c2-c3m-hc 11 3 2 9 + 22 oc-c2-c3m-oc 6 3 2 4 + 23 hc-c2-c3m-oc 10 3 2 4 + 24 hc-c2-c3m-oc 11 3 2 4 + 25 c2-c3m-oc-ho 1 2 4 25 + 26 c2-c3m-oc-ho 3 2 4 25 + 27 hc-c3m-oc-ho 9 2 4 25 + 28 c3m-c2-oc-cp 2 3 6 5 + 29 hc-c2-oc-cp 10 3 6 5 + 30 hc-c2-oc-cp 11 3 6 5 + 31 c2-c2-na-c2 14 13 12 18 + 32 hc-c2-na-c2 20 13 12 18 + 33 hc-c2-na-c2 21 13 12 18 + 34 c2-c2-na-hn 14 13 12 19 + 35 hc-c2-na-hn 20 13 12 19 + 36 hc-c2-na-hn 21 13 12 19 + 37 c2-c2-na-c2 17 18 12 13 + 38 hc-c2-na-c2 30 18 12 13 + 39 hc-c2-na-c2 31 18 12 13 + 40 c2-c2-na-hn 17 18 12 19 + 41 hc-c2-na-hn 30 18 12 19 + 42 hc-c2-na-hn 31 18 12 19 + 43 na-c2-c2-na 12 13 14 15 + 44 hc-c2-c2-na 22 14 13 12 + 45 hc-c2-c2-na 23 14 13 12 + 46 hc-c2-c2-na 20 13 14 15 + 47 hc-c2-c2-hc 20 13 14 22 + 48 hc-c2-c2-hc 20 13 14 23 + 49 hc-c2-c2-na 21 13 14 15 + 50 hc-c2-c2-hc 21 13 14 22 + 51 hc-c2-c2-hc 21 13 14 23 + 52 c2-c2-na-c2 13 14 15 1 + 53 c2-c2-na-c2 13 14 15 32 + 54 hc-c2-na-c2 22 14 15 1 + 55 hc-c2-na-c2 22 14 15 32 + 56 hc-c2-na-c2 23 14 15 1 + 57 hc-c2-na-c2 23 14 15 32 + 58 hc-c2-na-c2 39 32 15 1 + 59 c3-c2-na-c2 33 32 15 1 + 60 hc-c2-na-c2 38 32 15 1 + 61 hc-c2-na-c2 39 32 15 14 + 62 c3-c2-na-c2 33 32 15 14 + 63 hc-c2-na-c2 38 32 15 14 + 64 c2-c2-na-hn 18 17 16 26 + 65 hc-c2-na-hn 28 17 16 26 + 66 hc-c2-na-hn 29 17 16 26 + 67 c2-c2-na-hn 18 17 16 27 + 68 hc-c2-na-hn 28 17 16 27 + 69 hc-c2-na-hn 29 17 16 27 + 70 na-c2-c2-na 16 17 18 12 + 71 hc-c2-c2-na 30 18 17 16 + 72 hc-c2-c2-na 31 18 17 16 + 73 hc-c2-c2-na 28 17 18 12 + 74 hc-c2-c2-hc 28 17 18 30 + 75 hc-c2-c2-hc 28 17 18 31 + 76 hc-c2-c2-na 29 17 18 12 + 77 hc-c2-c2-hc 29 17 18 30 + 78 hc-c2-c2-hc 29 17 18 31 + 79 na-c2-c3-oc 15 32 33 35 + 80 na-c2-c3-c2 15 32 33 34 + 81 na-c2-c3-hc 15 32 33 40 + 82 hc-c2-c3-oc 39 32 33 35 + 83 hc-c2-c3-c2 39 32 33 34 + 84 hc-c2-c3-hc 39 32 33 40 + 85 hc-c2-c3-oc 38 32 33 35 + 86 hc-c2-c3-c2 38 32 33 34 + 87 hc-c2-c3-hc 38 32 33 40 + 88 ho-oc-c3-c2 24 35 33 32 + 89 ho-oc-c3-c2 24 35 33 34 + 90 ho-oc-c3-hc 24 35 33 40 + 91 oc-c2-c3-c2 37 34 33 32 + 92 hc-c2-c3-c2 41 34 33 32 + 93 hc-c2-c3-c2 42 34 33 32 + 94 oc-c2-c3-oc 37 34 33 35 + 95 hc-c2-c3-oc 41 34 33 35 + 96 hc-c2-c3-oc 42 34 33 35 + 97 oc-c2-c3-hc 37 34 33 40 + 98 hc-c2-c3-hc 41 34 33 40 + 99 hc-c2-c3-hc 42 34 33 40 + 100 c3-c2-oc-cp 33 34 37 36 + 101 hc-c2-oc-cp 41 34 37 36 + 102 hc-c2-oc-cp 42 34 37 36 + +Impropers + + 1 c2-na-c2-hn 13 12 18 19 + 2 c2-na-c2-c2 1 15 14 32 + 3 c2-na-hn-hn 17 16 26 27 diff --git a/examples/PACKAGES/reaction/tiny_epoxy/tiny_epoxy.data b/examples/PACKAGES/reaction/tiny_epoxy/tiny_epoxy.data index d98006b107..90c074fde0 100644 --- a/examples/PACKAGES/reaction/tiny_epoxy/tiny_epoxy.data +++ b/examples/PACKAGES/reaction/tiny_epoxy/tiny_epoxy.data @@ -1,1582 +1,1765 @@ # two molecules DGEBA (diepoxy) and one DETA (linker) -118 atoms -123 bonds -221 angles -302 dihedrals -115 impropers -11 atom types -19 bond types -50 angle types -66 dihedral types -22 improper types +118 atoms +123 bonds +221 angles +302 dihedrals +115 impropers +11 atom types +19 bond types +50 angle types +66 dihedral types +22 improper types 10 30 xlo xhi -10 20 ylo yhi -15 10 zlo zhi -Masses +Atom Type Labels -1 12.011150 # c2 -2 12.011150 # c3m -3 15.999400 # o3e -4 12.011150 # cp -5 12.011150 # c -6 12.011150 # c3 -7 15.999400 # oc -8 1.007970 # hc -9 14.006700 # na -10 1.007970 # hn -11 1.007970 # ho +1 c2 +2 c3m +3 o3e +4 cp +5 c +6 c3 +7 oc +8 hc +9 na +10 hn +11 ho -Pair Coeffs # lj/class2/coul/long +Bond Type Labels -1 0.0540000000 4.0100000000 # c2 -2 0.0540000000 4.0100000000 # c3m -3 0.2400000000 3.5350000000 # o3e -4 0.0640000000 4.0100000000 # cp -5 0.0540000000 4.0100000000 # c -6 0.0540000000 4.0100000000 # c3 -7 0.2400000000 3.5350000000 # oc -8 0.0200000000 2.7000000000 # hc -9 0.0650000000 4.0700000000 # na -10 0.0130000000 1.0980000000 # hn -11 0.0130000000 1.0980000000 # ho +1 c2-hc +2 c3m-c2 +3 c2-oc +4 c3m-o3e +5 c3m-c3m +6 c3m-hc +7 cp-cp +8 cp-oc +9 cp-hc +10 cp-c +11 c-c3 +12 c3-hc +13 c2-na +14 na-hn +15 c2-c2 +16 c2-c3 +17 c3-oc +18 oc-ho +19 c3m-oc -Bond Coeffs # class2 +Angle Type Labels -1 1.1010 345.0000 -691.8900 844.6000 # c2-hc -2 1.5300 299.6700 -501.7700 679.8100 # c2-c3m -3 1.4200 400.3954 -835.1951 1313.0142 # c2-oc -4 1.4200 400.3954 -835.1951 1313.0142 # c3m-o3e -5 1.5300 299.6700 -501.7700 679.8100 # c3m-c3m -6 1.1010 345.0000 -691.8900 844.6000 # c3m-hc -7 1.4170 470.8361 -627.6179 1327.6345 # cp-cp -8 1.3768 428.8798 -738.2351 1114.9655 # cp-oc -9 1.0982 372.8251 -803.4526 894.3173 # cp-hc -10 1.5010 321.9021 -521.8208 572.1628 # cp-c -11 1.5300 299.6700 -501.7700 679.8100 # c-c3 -12 1.1010 345.0000 -691.8900 844.6000 # c3-hc -13 1.4570 365.8052 -699.6368 998.4842 # c2-na -14 1.0060 466.7400 -1073.6018 1251.1056 # na-hn -15 1.5300 299.6700 -501.7700 679.8100 # c2-c2 -16 1.5300 299.6700 -501.7700 679.8100 # c2-c3 -17 1.4200 400.3954 -835.1951 1313.0142 # c3-oc -18 0.9650 532.5062 -1282.9050 2004.7658 # oc-ho -19 1.4200 400.3954 -835.1951 1313.0142 # c3m-oc +1 c3m-c2-hc +2 hc-c2-hc +3 oc-c2-hc +4 c3m-c2-oc +5 c2-c3m-o3e +6 c2-c3m-c3m +7 c2-c3m-hc +8 c3m-c3m-o3e +9 o3e-c3m-hc +10 c3m-c3m-hc +11 hc-c3m-hc +12 c3m-o3e-c3m +13 cp-cp-cp +14 cp-cp-oc +15 cp-cp-hc +16 cp-cp-c +17 cp-c-c3 +18 cp-c-cp +19 c3-c-c3 +20 c-c3-hc +21 hc-c3-hc +22 c2-oc-cp +23 c2-na-c2 +24 c2-na-hn +25 c2-c2-na +26 hc-c2-na +27 c2-c2-hc +28 hn-na-hn +29 c3m-c3m-c2 +30 c3-c2-hc +31 c3-c2-na +32 c2-c3-c2 +33 c2-c3-hc +34 c2-c3-oc +35 oc-c3-hc +36 c3-c2-oc +37 c3-oc-ho +38 hc-c3m-o3e +39 hc-c3m-c3m +40 oc-c2-c3m +41 hc-c2-c3m +42 c3m-c2-na +43 c2-c3m-c2 +44 c2-c3m-oc +45 oc-c3m-hc +46 c3m-oc-ho +47 na-c2-c3 +48 hc-c2-c3 +49 oc-c2-c3 +50 ho-oc-c3 -Angle Coeffs # class2 +Dihedral Type Labels -1 110.7700 41.4530 -10.6040 5.1290 # c3m-c2-hc -2 107.6600 39.6410 -12.9210 -2.4318 # hc-c2-hc -3 108.7280 58.5446 -10.8088 -12.4006 # oc-c2-hc -4 111.2700 54.5381 -8.3642 -13.0838 # c3m-c2-oc -5 111.2700 54.5381 -8.3642 -13.0838 # c2-c3m-o3e -6 112.6700 39.5160 -7.4430 -9.5583 # c2-c3m-c3m -7 110.7700 41.4530 -10.6040 5.1290 # c2-c3m-hc -8 111.2700 54.5381 -8.3642 -13.0838 # c3m-c3m-o3e -9 108.7280 58.5446 -10.8088 -12.4006 # o3e-c3m-hc -10 110.7700 41.4530 -10.6040 5.1290 # c3m-c3m-hc -11 107.6600 39.6410 -12.9210 -2.4318 # hc-c3m-hc -12 104.5000 35.7454 -10.0067 -6.2729 # c3m-o3e-c3m -13 118.9000 61.0226 -34.9931 0.0000 # cp-cp-cp -14 123.4200 73.6781 -21.6787 0.0000 # cp-cp-oc -15 117.9400 35.1558 -12.4682 0.0000 # cp-cp-hc -16 120.0500 44.7148 -22.7352 0.0000 # cp-cp-c -17 108.4000 43.9594 -8.3924 -9.3379 # cp-c-c3 -18 111.0000 44.3234 -9.4454 0.0000 # cp-c-cp -19 112.6700 39.5160 -7.4430 -9.5583 # c3-c-c3 -20 110.7700 41.4530 -10.6040 5.1290 # c-c3-hc -21 107.6600 39.6410 -12.9210 -2.4318 # hc-c3-hc -22 102.9695 38.9739 -6.2595 -8.1710 # c2-oc-cp -23 112.4436 47.2337 -10.6612 -10.2062 # c2-na-c2 -24 110.9538 50.8652 -4.4522 -10.0298 # c2-na-hn -25 111.9100 60.7147 -13.3366 -13.0785 # c2-c2-na -26 110.6204 51.3137 -6.7198 -2.6003 # hc-c2-na -27 110.7700 41.4530 -10.6040 5.1290 # c2-c2-hc -28 107.0671 45.2520 -7.5558 -9.5120 # hn-na-hn -29 112.6700 39.5160 -7.4430 -9.5583 # c3m-c3m-c2 -30 110.7700 41.4530 -10.6040 5.1290 # c3-c2-hc -31 111.9100 60.7147 -13.3366 -13.0785 # c3-c2-na -32 112.6700 39.5160 -7.4430 -9.5583 # c2-c3-c2 -33 110.7700 41.4530 -10.6040 5.1290 # c2-c3-hc -34 111.2700 54.5381 -8.3642 -13.0838 # c2-c3-oc -35 108.7280 58.5446 -10.8088 -12.4006 # oc-c3-hc -36 111.2700 54.5381 -8.3642 -13.0838 # c3-c2-oc -37 105.8000 52.7061 -12.1090 -9.8681 # c3-oc-ho -38 108.7280 58.5446 -10.8088 -12.4006 # hc-c3m-o3e -39 110.7700 41.4530 -10.6040 5.1290 # hc-c3m-c3m -40 111.2700 54.5381 -8.3642 -13.0838 # oc-c2-c3m -41 110.7700 41.4530 -10.6040 5.1290 # hc-c2-c3m -42 111.9100 60.7147 -13.3366 -13.0785 # c3m-c2-na -43 112.6700 39.5160 -7.4430 -9.5583 # c2-c3m-c2 -44 111.2700 54.5381 -8.3642 -13.0838 # c2-c3m-oc -45 108.7280 58.5446 -10.8088 -12.4006 # oc-c3m-hc -46 105.8000 52.7061 -12.1090 -9.8681 # c3m-oc-ho -47 111.9100 60.7147 -13.3366 -13.0785 # na-c2-c3 -48 110.7700 41.4530 -10.6040 5.1290 # hc-c2-c3 -49 111.2700 54.5381 -8.3642 -13.0838 # oc-c2-c3 -50 105.8000 52.7061 -12.1090 -9.8681 # ho-oc-c3 +1 hc-c2-c3m-o3e +2 hc-c2-c3m-c3m +3 hc-c2-c3m-hc +4 oc-c2-c3m-o3e +5 oc-c2-c3m-c3m +6 oc-c2-c3m-hc +7 hc-c2-oc-cp +8 c3m-c2-oc-cp +9 c2-c3m-o3e-c3m +10 hc-c3m-o3e-c3m +11 c2-c3m-c3m-o3e +12 c2-c3m-c3m-hc +13 o3e-c3m-c3m-hc +14 hc-c3m-c3m-hc +15 cp-cp-cp-cp +16 cp-cp-cp-hc +17 cp-cp-cp-oc +18 oc-cp-cp-hc +19 cp-cp-oc-c2 +20 hc-cp-cp-hc +21 cp-cp-cp-c +22 c-cp-cp-hc +23 cp-cp-c-c3 +24 cp-cp-c-cp +25 cp-c-c3-hc +26 c3-c-c3-hc +27 c2-c2-na-c2 +28 hc-c2-na-c2 +29 c2-c2-na-hn +30 hc-c2-na-hn +31 na-c2-c2-na +32 hc-c2-c2-na +33 hc-c2-c2-hc +34 c3m-c3m-c2-oc +35 c3m-c3m-c2-hc +36 o3e-c3m-c2-oc +37 o3e-c3m-c2-hc +38 hc-c3m-c2-oc +39 hc-c3m-c2-hc +40 hc-c2-c3-c2 +41 hc-c2-c3-hc +42 hc-c2-c3-oc +43 na-c2-c3-c2 +44 na-c2-c3-hc +45 na-c2-c3-oc +46 c3-c2-na-c2 +47 c3-c2-na-hn +48 oc-c2-c3-c2 +49 oc-c2-c3-hc +50 oc-c2-c3-oc +51 c3-c2-oc-cp +52 c2-c3-oc-ho +53 hc-c3-oc-ho +54 hc-c3m-c3m-o3e +55 hc-c2-c3m-c2 +56 hc-c2-c3m-oc +57 na-c2-c3m-c2 +58 na-c2-c3m-hc +59 na-c2-c3m-oc +60 c3m-c2-na-c2 +61 oc-c2-c3m-c2 +62 oc-c2-c3m-oc +63 c2-c3m-oc-ho +64 hc-c3m-oc-ho +65 ho-oc-c3-c2 +66 ho-oc-c3-hc -Dihedral Coeffs # class2 +Improper Type Labels -1 -0.1435 0.0000 0.2530 0.0000 -0.0905 0.0000# hc-c2-c3m-o3e -2 0.0000 0.0000 0.0316 0.0000 -0.1681 0.0000# hc-c2-c3m-c3m -3 -0.1432 0.0000 0.0617 0.0000 -0.1083 0.0000# hc-c2-c3m-hc -4 -0.1820 0.0000 -0.1084 0.0000 -0.7047 0.0000# oc-c2-c3m-o3e -5 0.7137 0.0000 0.2660 0.0000 -0.2545 0.0000# oc-c2-c3m-c3m -6 -0.1435 0.0000 0.2530 0.0000 -0.0905 0.0000# oc-c2-c3m-hc -7 0.9513 0.0000 0.1155 0.0000 0.0720 0.0000# hc-c2-oc-cp -8 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000# c3m-c2-oc-cp -9 -0.5203 0.0000 -0.3028 0.0000 -0.3450 0.0000# c2-c3m-o3e-c3m -10 0.5302 0.0000 0.0000 0.0000 -0.3966 0.0000# hc-c3m-o3e-c3m -11 0.7137 0.0000 0.2660 0.0000 -0.2545 0.0000# c2-c3m-c3m-o3e -12 0.0000 0.0000 0.0316 0.0000 -0.1681 0.0000# c2-c3m-c3m-hc -13 -0.1435 0.0000 0.2530 0.0000 -0.0905 0.0000# o3e-c3m-c3m-hc -14 -0.1432 0.0000 0.0617 0.0000 -0.1083 0.0000# hc-c3m-c3m-hc -15 8.3667 0.0000 1.1932 0.0000 0.0000 0.0000# cp-cp-cp-cp -16 0.0000 0.0000 3.9661 0.0000 0.0000 0.0000# cp-cp-cp-hc -17 0.0000 0.0000 4.8498 0.0000 0.0000 0.0000# cp-cp-cp-oc -18 0.0000 0.0000 1.7234 0.0000 0.0000 0.0000# oc-cp-cp-hc -19 0.0000 0.0000 1.5000 0.0000 0.0000 0.0000# cp-cp-oc-c2 -20 0.0000 0.0000 1.8769 0.0000 0.0000 0.0000# hc-cp-cp-hc -21 0.0000 0.0000 4.4072 0.0000 0.0000 0.0000# cp-cp-cp-c -22 0.0000 0.0000 1.5590 0.0000 0.0000 0.0000# c-cp-cp-hc -23 -0.2802 0.0000 -0.0678 0.0000 -0.0122 0.0000# cp-cp-c-c3 -24 -0.2802 0.0000 -0.0678 0.0000 -0.0122 0.0000# cp-cp-c-cp -25 -0.0228 0.0000 0.0280 0.0000 -0.1863 0.0000# cp-c-c3-hc -26 0.0000 0.0000 0.0316 0.0000 -0.1681 0.0000# c3-c-c3-hc -27 -0.1406 0.0000 0.4168 0.0000 0.0150 0.0000# c2-c2-na-c2 -28 0.1904 0.0000 -0.1342 0.0000 -0.2460 0.0000# hc-c2-na-c2 -29 -1.1506 0.0000 -0.6344 0.0000 -0.1845 0.0000# c2-c2-na-hn -30 -0.5187 0.0000 -0.4837 0.0000 -0.1692 0.0000# hc-c2-na-hn -31 0.3805 0.0000 0.3547 0.0000 -0.1102 0.0000# na-c2-c2-na -32 -0.2428 0.0000 0.4065 0.0000 -0.3079 0.0000# hc-c2-c2-na -33 -0.1432 0.0000 0.0617 0.0000 -0.1083 0.0000# hc-c2-c2-hc -34 0.7137 0.0000 0.2660 0.0000 -0.2545 0.0000# c3m-c3m-c2-oc -35 0.0000 0.0000 0.0316 0.0000 -0.1681 0.0000# c3m-c3m-c2-hc -36 -0.1820 0.0000 -0.1084 0.0000 -0.7047 0.0000# o3e-c3m-c2-oc -37 -0.1435 0.0000 0.2530 0.0000 -0.0905 0.0000# o3e-c3m-c2-hc -38 -0.1435 0.0000 0.2530 0.0000 -0.0905 0.0000# hc-c3m-c2-oc -39 -0.1432 0.0000 0.0617 0.0000 -0.1083 0.0000# hc-c3m-c2-hc -40 0.0000 0.0000 0.0316 0.0000 -0.1681 0.0000# hc-c2-c3-c2 -41 -0.1432 0.0000 0.0617 0.0000 -0.1083 0.0000# hc-c2-c3-hc -42 -0.1435 0.0000 0.2530 0.0000 -0.0905 0.0000# hc-c2-c3-oc -43 0.1764 0.0000 0.1766 0.0000 -0.5206 0.0000# na-c2-c3-c2 -44 -0.2428 0.0000 0.4065 0.0000 -0.3079 0.0000# na-c2-c3-hc -45 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000# na-c2-c3-oc -46 -0.1406 0.0000 0.4168 0.0000 0.0150 0.0000# c3-c2-na-c2 -47 -1.1506 0.0000 -0.6344 0.0000 -0.1845 0.0000# c3-c2-na-hn -48 0.7137 0.0000 0.2660 0.0000 -0.2545 0.0000# oc-c2-c3-c2 -49 -0.1435 0.0000 0.2530 0.0000 -0.0905 0.0000# oc-c2-c3-hc -50 -0.1820 0.0000 -0.1084 0.0000 -0.7047 0.0000# oc-c2-c3-oc -51 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000# c3-c2-oc-cp -52 -0.6732 0.0000 -0.4778 0.0000 -0.1670 0.0000# c2-c3-oc-ho -53 0.1863 0.0000 -0.4338 0.0000 -0.2121 0.0000# hc-c3-oc-ho -54 -0.1435 0.0000 0.2530 0.0000 -0.0905 0.0000# hc-c3m-c3m-o3e -55 0.0000 0.0000 0.0316 0.0000 -0.1681 0.0000# hc-c2-c3m-c2 -56 -0.1435 0.0000 0.2530 0.0000 -0.0905 0.0000# hc-c2-c3m-oc -57 0.1764 0.0000 0.1766 0.0000 -0.5206 0.0000# na-c2-c3m-c2 -58 -0.2428 0.0000 0.4065 0.0000 -0.3079 0.0000# na-c2-c3m-hc -59 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000# na-c2-c3m-oc -60 -0.1406 0.0000 0.4168 0.0000 0.0150 0.0000# c3m-c2-na-c2 -61 0.7137 0.0000 0.2660 0.0000 -0.2545 0.0000# oc-c2-c3m-c2 -62 -0.1820 0.0000 -0.1084 0.0000 -0.7047 0.0000# oc-c2-c3m-oc -63 -0.6732 0.0000 -0.4778 0.0000 -0.1670 0.0000# c2-c3m-oc-ho -64 0.1863 0.0000 -0.4338 0.0000 -0.2121 0.0000# hc-c3m-oc-ho -65 -0.6732 0.0000 -0.4778 0.0000 -0.1670 0.0000# ho-oc-c3-c2 -66 0.1863 0.0000 -0.4338 0.0000 -0.2121 0.0000# ho-oc-c3-hc +1 cp-cp-cp-oc +2 cp-cp-cp-hc +3 cp-cp-cp-c +4 c2-na-c2-hn +5 c2-na-hn-hn +6 zero6 +7 zero7 +8 zero8 +9 zero9 +10 zero10 +11 zero11 +12 zero12 +13 zero13 +14 zero14 +15 zero15 +16 zero16 +17 zero17 +18 zero18 +19 zero19 +20 zero20 +21 zero21 +22 c2-na-c2-c2 -Improper Coeffs # class2 +Masses -1 13.0421 0.0000 # cp-cp-cp-oc -2 4.8912 0.0000 # cp-cp-cp-hc -3 7.8153 0.0000 # cp-cp-cp-c -4 0.0000 0.0000 # c2-na-c2-hn -5 0.0000 0.0000 # c2-na-hn-hn -6 0.0000 0.0000 -7 0.0000 0.0000 -8 0.0000 0.0000 -9 0.0000 0.0000 -10 0.0000 0.0000 -11 0.0000 0.0000 -12 0.0000 0.0000 -13 0.0000 0.0000 -14 0.0000 0.0000 -15 0.0000 0.0000 -16 0.0000 0.0000 -17 0.0000 0.0000 -18 0.0000 0.0000 -19 0.0000 0.0000 -20 0.0000 0.0000 -21 0.0000 0.0000 -22 0.0000 0.0000 # c2-na-c2-c2 +1 12.011150 +2 12.011150 +3 15.999400 +4 12.011150 +5 12.011150 +6 12.011150 +7 15.999400 +8 1.007970 +9 14.006700 +10 1.007970 +11 1.007970 -BondBond Coeffs +Pair Coeffs # lj/class2/coul/long -1 3.3872 1.5300 1.1010 -2 5.3316 1.1010 1.1010 -3 23.1979 1.4200 1.1010 -4 11.4318 1.5300 1.4200 -5 11.4318 1.5300 1.4200 -6 0.0000 1.5300 1.5300 -7 3.3872 1.5300 1.1010 -8 11.4318 1.5300 1.4200 -9 23.1979 1.4200 1.1010 -10 3.3872 1.5300 1.1010 -11 5.3316 1.1010 1.1010 -12 -7.1131 1.4200 1.4200 -13 68.2856 1.4170 1.4170 -14 48.4754 1.4170 1.3768 -15 1.0795 1.4170 1.0982 -16 12.0676 1.4170 1.5010 -17 0.0000 1.5010 1.5300 -18 0.0000 1.5010 1.5010 -19 0.0000 1.5300 1.5300 -20 3.3872 1.5300 1.1010 -21 5.3316 1.1010 1.1010 -22 0.0000 1.4200 1.3768 -23 -2.1113 1.4570 1.4570 -24 -6.4168 1.4570 1.0060 -25 4.6217 1.5300 1.4570 -26 12.4260 1.1010 1.4570 -27 3.3872 1.5300 1.1010 -28 -1.8749 1.0060 1.0060 -29 0.0000 1.5300 1.5300 -30 3.3872 1.5300 1.1010 -31 4.6217 1.5300 1.4570 -32 0.0000 1.5300 1.5300 -33 3.3872 1.5300 1.1010 -34 11.4318 1.5300 1.4200 -35 23.1979 1.4200 1.1010 -36 11.4318 1.5300 1.4200 -37 -9.6879 1.4200 0.9650 -38 23.1979 1.1010 1.4200 -39 3.3872 1.1010 1.5300 -40 11.4318 1.4200 1.5300 -41 3.3872 1.1010 1.5300 -42 4.6217 1.5300 1.4570 -43 0.0000 1.5300 1.5300 -44 11.4318 1.5300 1.4200 -45 23.1979 1.4200 1.1010 -46 -9.6879 1.4200 0.9650 -47 4.6217 1.4570 1.5300 -48 3.3872 1.1010 1.5300 -49 11.4318 1.4200 1.5300 -50 -9.6879 0.9650 1.4200 +1 0.0540000000 4.0100000000 +2 0.0540000000 4.0100000000 +3 0.2400000000 3.5350000000 +4 0.0640000000 4.0100000000 +5 0.0540000000 4.0100000000 +6 0.0540000000 4.0100000000 +7 0.2400000000 3.5350000000 +8 0.0200000000 2.7000000000 +9 0.0650000000 4.0700000000 +10 0.0130000000 1.0980000000 +11 0.0130000000 1.0980000000 -BondAngle Coeffs +Bond Coeffs # class2 -1 20.7540 11.4210 1.5300 1.1010 -2 18.1030 18.1030 1.1010 1.1010 -3 55.3270 4.6189 1.4200 1.1010 -4 2.6868 20.4033 1.5300 1.4200 -5 2.6868 20.4033 1.5300 1.4200 -6 8.0160 8.0160 1.5300 1.5300 -7 20.7540 11.4210 1.5300 1.1010 -8 2.6868 20.4033 1.5300 1.4200 -9 55.3270 4.6189 1.4200 1.1010 -10 20.7540 11.4210 1.5300 1.1010 -11 18.1030 18.1030 1.1010 1.1010 -12 -2.8112 -2.8112 1.4200 1.4200 -13 28.8708 28.8708 1.4170 1.4170 -14 58.4790 107.6806 1.4170 1.3768 -15 20.0033 24.2183 1.4170 1.0982 -16 31.0771 47.0579 1.4170 1.5010 -17 0.0000 0.0000 1.5010 1.5300 -18 0.0000 0.0000 1.5010 1.5010 -19 8.0160 8.0160 1.5300 1.5300 -20 20.7540 11.4210 1.5300 1.1010 -21 18.1030 18.1030 1.1010 1.1010 -22 0.0000 0.0000 1.4200 1.3768 -23 -7.2229 -7.2229 1.4570 1.4570 -24 31.8096 20.5799 1.4570 1.0060 -25 6.0876 16.5702 1.5300 1.4570 -26 13.4582 42.4332 1.1010 1.4570 -27 20.7540 11.4210 1.5300 1.1010 -28 28.0322 28.0322 1.0060 1.0060 -29 8.0160 8.0160 1.5300 1.5300 -30 20.7540 11.4210 1.5300 1.1010 -31 6.0876 16.5702 1.5300 1.4570 -32 8.0160 8.0160 1.5300 1.5300 -33 20.7540 11.4210 1.5300 1.1010 -34 2.6868 20.4033 1.5300 1.4200 -35 55.3270 4.6189 1.4200 1.1010 -36 2.6868 20.4033 1.5300 1.4200 -37 28.5800 18.9277 1.4200 0.9650 -38 4.6189 55.3270 1.1010 1.4200 -39 11.4210 20.7540 1.1010 1.5300 -40 20.4033 2.6868 1.4200 1.5300 -41 11.4210 20.7540 1.1010 1.5300 -42 6.0876 16.5702 1.5300 1.4570 -43 8.0160 8.0160 1.5300 1.5300 -44 2.6868 20.4033 1.5300 1.4200 -45 55.3270 4.6189 1.4200 1.1010 -46 28.5800 18.9277 1.4200 0.9650 -47 16.5702 6.0876 1.4570 1.5300 -48 11.4210 20.7540 1.1010 1.5300 -49 20.4033 2.6868 1.4200 1.5300 -50 18.9277 28.5800 0.9650 1.4200 +1 1.1010 345.0000 -691.8900 844.6000 +2 1.5300 299.6700 -501.7700 679.8100 +3 1.4200 400.3954 -835.1951 1313.0142 +4 1.4200 400.3954 -835.1951 1313.0142 +5 1.5300 299.6700 -501.7700 679.8100 +6 1.1010 345.0000 -691.8900 844.6000 +7 1.4170 470.8361 -627.6179 1327.6345 +8 1.3768 428.8798 -738.2351 1114.9655 +9 1.0982 372.8251 -803.4526 894.3173 +10 1.5010 321.9021 -521.8208 572.1628 +11 1.5300 299.6700 -501.7700 679.8100 +12 1.1010 345.0000 -691.8900 844.6000 +13 1.4570 365.8052 -699.6368 998.4842 +14 1.0060 466.7400 -1073.6018 1251.1056 +15 1.5300 299.6700 -501.7700 679.8100 +16 1.5300 299.6700 -501.7700 679.8100 +17 1.4200 400.3954 -835.1951 1313.0142 +18 0.9650 532.5062 -1282.9050 2004.7658 +19 1.4200 400.3954 -835.1951 1313.0142 -AngleAngle Coeffs +Angle Coeffs # class2 -1 0.0000 0.0000 0.0000 118.9000 123.4200 123.4200 -2 0.0000 0.0000 0.0000 118.9000 117.9400 117.9400 -3 0.0000 0.0000 0.0000 118.9000 120.0500 120.0500 -4 0.0000 0.0000 0.0000 112.4436 110.9538 110.9538 -5 0.0000 0.0000 0.0000 110.9538 107.0671 110.9538 -6 0.2738 -0.4825 0.2738 110.7700 107.6600 110.7700 -7 0.1689 2.5926 3.9177 111.2700 108.7280 110.7700 -8 2.4259 2.1283 2.4259 108.7280 107.6600 108.7280 -9 -0.8330 -0.8330 -3.5744 112.6700 111.2700 111.2700 -10 0.1689 2.5926 3.9177 111.2700 108.7280 110.7700 -11 -1.3199 -1.3199 0.1184 112.6700 110.7700 110.7700 -12 0.1689 2.5926 3.9177 111.2700 108.7280 110.7700 -13 0.2738 -0.4825 0.2738 110.7700 107.6600 110.7700 -14 2.4259 2.1283 2.4259 108.7280 107.6600 108.7280 -15 0.0000 0.0000 0.0000 108.4000 112.6700 108.4000 -16 0.0000 0.0000 0.0000 111.0000 108.4000 108.4000 -17 0.2738 -0.4825 0.2738 110.7700 107.6600 110.7700 -18 -0.3157 -0.3157 -0.3157 107.6600 107.6600 107.6600 -19 2.4286 0.5381 -2.5301 110.7700 110.6204 111.9100 -20 2.4321 2.4321 -3.5496 107.6600 110.6204 110.6204 -21 0.2738 -0.4825 0.2738 110.7700 107.6600 110.7700 -22 0.0000 0.0000 0.0000 112.4436 112.4436 112.4436 +1 110.7700 41.4530 -10.6040 5.1290 +2 107.6600 39.6410 -12.9210 -2.4318 +3 108.7280 58.5446 -10.8088 -12.4006 +4 111.2700 54.5381 -8.3642 -13.0838 +5 111.2700 54.5381 -8.3642 -13.0838 +6 112.6700 39.5160 -7.4430 -9.5583 +7 110.7700 41.4530 -10.6040 5.1290 +8 111.2700 54.5381 -8.3642 -13.0838 +9 108.7280 58.5446 -10.8088 -12.4006 +10 110.7700 41.4530 -10.6040 5.1290 +11 107.6600 39.6410 -12.9210 -2.4318 +12 104.5000 35.7454 -10.0067 -6.2729 +13 118.9000 61.0226 -34.9931 0.0000 +14 123.4200 73.6781 -21.6787 0.0000 +15 117.9400 35.1558 -12.4682 0.0000 +16 120.0500 44.7148 -22.7352 0.0000 +17 108.4000 43.9594 -8.3924 -9.3379 +18 111.0000 44.3234 -9.4454 0.0000 +19 112.6700 39.5160 -7.4430 -9.5583 +20 110.7700 41.4530 -10.6040 5.1290 +21 107.6600 39.6410 -12.9210 -2.4318 +22 102.9695 38.9739 -6.2595 -8.1710 +23 112.4436 47.2337 -10.6612 -10.2062 +24 110.9538 50.8652 -4.4522 -10.0298 +25 111.9100 60.7147 -13.3366 -13.0785 +26 110.6204 51.3137 -6.7198 -2.6003 +27 110.7700 41.4530 -10.6040 5.1290 +28 107.0671 45.2520 -7.5558 -9.5120 +29 112.6700 39.5160 -7.4430 -9.5583 +30 110.7700 41.4530 -10.6040 5.1290 +31 111.9100 60.7147 -13.3366 -13.0785 +32 112.6700 39.5160 -7.4430 -9.5583 +33 110.7700 41.4530 -10.6040 5.1290 +34 111.2700 54.5381 -8.3642 -13.0838 +35 108.7280 58.5446 -10.8088 -12.4006 +36 111.2700 54.5381 -8.3642 -13.0838 +37 105.8000 52.7061 -12.1090 -9.8681 +38 108.7280 58.5446 -10.8088 -12.4006 +39 110.7700 41.4530 -10.6040 5.1290 +40 111.2700 54.5381 -8.3642 -13.0838 +41 110.7700 41.4530 -10.6040 5.1290 +42 111.9100 60.7147 -13.3366 -13.0785 +43 112.6700 39.5160 -7.4430 -9.5583 +44 111.2700 54.5381 -8.3642 -13.0838 +45 108.7280 58.5446 -10.8088 -12.4006 +46 105.8000 52.7061 -12.1090 -9.8681 +47 111.9100 60.7147 -13.3366 -13.0785 +48 110.7700 41.4530 -10.6040 5.1290 +49 111.2700 54.5381 -8.3642 -13.0838 +50 105.8000 52.7061 -12.1090 -9.8681 -AngleAngleTorsion Coeffs +Dihedral Coeffs # class2 -1 -20.2006 110.7700 111.2700 -2 -16.1640 110.7700 112.6700 -3 -12.5640 110.7700 110.7700 -4 -14.0484 111.2700 111.2700 -5 -29.0420 111.2700 112.6700 -6 -20.2006 111.2700 110.7700 -7 0.0000 108.7280 102.9695 -8 0.0000 111.2700 102.9695 -9 -19.0059 111.2700 104.5000 -10 -16.4438 108.7280 104.5000 -11 -29.0420 112.6700 111.2700 -12 -16.1640 112.6700 110.7700 -13 -20.2006 111.2700 110.7700 -14 -12.5640 110.7700 110.7700 -15 0.0000 118.9000 118.9000 -16 -4.8141 118.9000 117.9400 -17 -21.0247 118.9000 123.4200 -18 4.2296 123.4200 117.9400 -19 0.0000 123.4200 102.9695 -20 0.3598 117.9400 117.9400 -21 -14.4097 118.9000 120.0500 -22 4.4444 120.0500 117.9400 -23 0.0000 120.0500 108.4000 -24 0.0000 120.0500 111.0000 -25 0.0000 108.4000 110.7700 -26 -16.1640 112.6700 110.7700 -27 -24.3818 111.9100 112.4436 -28 -12.5567 110.6204 112.4436 -29 -7.5499 111.9100 110.9538 -30 -10.4258 110.6204 110.9538 -31 -11.2307 111.9100 111.9100 -32 -15.7572 110.7700 111.9100 -33 -12.5640 110.7700 110.7700 -34 -29.0420 112.6700 111.2700 -35 -16.1640 112.6700 110.7700 -36 -14.0484 111.2700 111.2700 -37 -20.2006 111.2700 110.7700 -38 -20.2006 110.7700 111.2700 -39 -12.5640 110.7700 110.7700 -40 -16.1640 110.7700 112.6700 -41 -12.5640 110.7700 110.7700 -42 -20.2006 110.7700 111.2700 -43 -27.3953 111.9100 112.6700 -44 -15.7572 111.9100 110.7700 -45 0.0000 111.9100 111.2700 -46 -24.3818 111.9100 112.4436 -47 -7.5499 111.9100 110.9538 -48 -29.0420 111.2700 112.6700 -49 -20.2006 111.2700 110.7700 -50 -14.0484 111.2700 111.2700 -51 0.0000 111.2700 102.9695 -52 -12.1038 111.2700 105.8000 -53 -10.5093 108.7280 105.8000 -54 -20.2006 110.7700 111.2700 -55 -16.1640 110.7700 112.6700 -56 -20.2006 110.7700 111.2700 -57 -27.3953 111.9100 112.6700 -58 -15.7572 111.9100 110.7700 -59 0.0000 111.9100 111.2700 -60 -24.3818 111.9100 112.4436 -61 -29.0420 111.2700 112.6700 -62 -14.0484 111.2700 111.2700 -63 -12.1038 111.2700 105.8000 -64 -10.5093 108.7280 105.8000 -65 -12.1038 105.8000 111.2700 -66 -10.5093 105.8000 108.7280 +1 -0.1435 0.0000 0.2530 0.0000 -0.0905 0.0000 +2 0.0000 0.0000 0.0316 0.0000 -0.1681 0.0000 +3 -0.1432 0.0000 0.0617 0.0000 -0.1083 0.0000 +4 -0.1820 0.0000 -0.1084 0.0000 -0.7047 0.0000 +5 0.7137 0.0000 0.2660 0.0000 -0.2545 0.0000 +6 -0.1435 0.0000 0.2530 0.0000 -0.0905 0.0000 +7 0.9513 0.0000 0.1155 0.0000 0.0720 0.0000 +8 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 +9 -0.5203 0.0000 -0.3028 0.0000 -0.3450 0.0000 +10 0.5302 0.0000 0.0000 0.0000 -0.3966 0.0000 +11 0.7137 0.0000 0.2660 0.0000 -0.2545 0.0000 +12 0.0000 0.0000 0.0316 0.0000 -0.1681 0.0000 +13 -0.1435 0.0000 0.2530 0.0000 -0.0905 0.0000 +14 -0.1432 0.0000 0.0617 0.0000 -0.1083 0.0000 +15 8.3667 0.0000 1.1932 0.0000 0.0000 0.0000 +16 0.0000 0.0000 3.9661 0.0000 0.0000 0.0000 +17 0.0000 0.0000 4.8498 0.0000 0.0000 0.0000 +18 0.0000 0.0000 1.7234 0.0000 0.0000 0.0000 +19 0.0000 0.0000 1.5000 0.0000 0.0000 0.0000 +20 0.0000 0.0000 1.8769 0.0000 0.0000 0.0000 +21 0.0000 0.0000 4.4072 0.0000 0.0000 0.0000 +22 0.0000 0.0000 1.5590 0.0000 0.0000 0.0000 +23 -0.2802 0.0000 -0.0678 0.0000 -0.0122 0.0000 +24 -0.2802 0.0000 -0.0678 0.0000 -0.0122 0.0000 +25 -0.0228 0.0000 0.0280 0.0000 -0.1863 0.0000 +26 0.0000 0.0000 0.0316 0.0000 -0.1681 0.0000 +27 -0.1406 0.0000 0.4168 0.0000 0.0150 0.0000 +28 0.1904 0.0000 -0.1342 0.0000 -0.2460 0.0000 +29 -1.1506 0.0000 -0.6344 0.0000 -0.1845 0.0000 +30 -0.5187 0.0000 -0.4837 0.0000 -0.1692 0.0000 +31 0.3805 0.0000 0.3547 0.0000 -0.1102 0.0000 +32 -0.2428 0.0000 0.4065 0.0000 -0.3079 0.0000 +33 -0.1432 0.0000 0.0617 0.0000 -0.1083 0.0000 +34 0.7137 0.0000 0.2660 0.0000 -0.2545 0.0000 +35 0.0000 0.0000 0.0316 0.0000 -0.1681 0.0000 +36 -0.1820 0.0000 -0.1084 0.0000 -0.7047 0.0000 +37 -0.1435 0.0000 0.2530 0.0000 -0.0905 0.0000 +38 -0.1435 0.0000 0.2530 0.0000 -0.0905 0.0000 +39 -0.1432 0.0000 0.0617 0.0000 -0.1083 0.0000 +40 0.0000 0.0000 0.0316 0.0000 -0.1681 0.0000 +41 -0.1432 0.0000 0.0617 0.0000 -0.1083 0.0000 +42 -0.1435 0.0000 0.2530 0.0000 -0.0905 0.0000 +43 0.1764 0.0000 0.1766 0.0000 -0.5206 0.0000 +44 -0.2428 0.0000 0.4065 0.0000 -0.3079 0.0000 +45 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 +46 -0.1406 0.0000 0.4168 0.0000 0.0150 0.0000 +47 -1.1506 0.0000 -0.6344 0.0000 -0.1845 0.0000 +48 0.7137 0.0000 0.2660 0.0000 -0.2545 0.0000 +49 -0.1435 0.0000 0.2530 0.0000 -0.0905 0.0000 +50 -0.1820 0.0000 -0.1084 0.0000 -0.7047 0.0000 +51 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 +52 -0.6732 0.0000 -0.4778 0.0000 -0.1670 0.0000 +53 0.1863 0.0000 -0.4338 0.0000 -0.2121 0.0000 +54 -0.1435 0.0000 0.2530 0.0000 -0.0905 0.0000 +55 0.0000 0.0000 0.0316 0.0000 -0.1681 0.0000 +56 -0.1435 0.0000 0.2530 0.0000 -0.0905 0.0000 +57 0.1764 0.0000 0.1766 0.0000 -0.5206 0.0000 +58 -0.2428 0.0000 0.4065 0.0000 -0.3079 0.0000 +59 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 +60 -0.1406 0.0000 0.4168 0.0000 0.0150 0.0000 +61 0.7137 0.0000 0.2660 0.0000 -0.2545 0.0000 +62 -0.1820 0.0000 -0.1084 0.0000 -0.7047 0.0000 +63 -0.6732 0.0000 -0.4778 0.0000 -0.1670 0.0000 +64 0.1863 0.0000 -0.4338 0.0000 -0.2121 0.0000 +65 -0.6732 0.0000 -0.4778 0.0000 -0.1670 0.0000 +66 0.1863 0.0000 -0.4338 0.0000 -0.2121 0.0000 -EndBondTorsion Coeffs +Improper Coeffs # class2 -1 0.9681 0.9551 0.0436 0.5903 0.6669 0.8584 1.1010 1.4200 -2 0.0814 0.0591 0.2219 0.2486 0.2422 -0.0925 1.1010 1.5300 -3 0.2130 0.3120 0.0777 0.2130 0.3120 0.0777 1.1010 1.1010 -4 1.0165 0.7553 -0.4609 1.0165 0.7553 -0.4609 1.4200 1.4200 -5 1.1538 0.8409 -0.9138 -0.3190 0.4411 -0.7174 1.4200 1.5300 -6 0.5903 0.6669 0.8584 0.9681 0.9551 0.0436 1.4200 1.1010 -7 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.1010 1.3768 -8 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.5300 1.3768 -9 -0.2456 1.0517 -0.7795 0.4741 1.2635 0.5576 1.5300 1.4200 -10 -0.6054 1.3339 0.9648 -0.1620 0.1564 -1.1408 1.1010 1.4200 -11 -0.3190 0.4411 -0.7174 1.1538 0.8409 -0.9138 1.5300 1.4200 -12 0.2486 0.2422 -0.0925 0.0814 0.0591 0.2219 1.5300 1.1010 -13 0.5903 0.6669 0.8584 0.9681 0.9551 0.0436 1.4200 1.1010 -14 0.2130 0.3120 0.0777 0.2130 0.3120 0.0777 1.1010 1.1010 -15 -0.1185 6.3204 0.0000 -0.1185 6.3204 0.0000 1.4170 1.4170 -16 0.0000 -6.8958 0.0000 0.0000 -0.4669 0.0000 1.4170 1.0982 -17 0.0000 0.2655 0.0000 0.0000 4.8905 0.0000 1.4170 1.3768 -18 0.0000 4.2641 0.0000 0.0000 -1.5867 0.0000 1.3768 1.0982 -19 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.4170 1.4200 -20 0.0000 -0.6890 0.0000 0.0000 -0.6890 0.0000 1.0982 1.0982 -21 0.0000 -0.6918 0.0000 0.0000 0.2421 0.0000 1.4170 1.5010 -22 0.0000 -1.7970 0.0000 0.0000 -0.4879 0.0000 1.5010 1.0982 -23 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.4170 1.5300 -24 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.4170 1.5010 -25 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.5010 1.1010 -26 0.2486 0.2422 -0.0925 0.0814 0.0591 0.2219 1.5300 1.1010 -27 0.0997 -0.0046 -0.2657 -0.0128 -0.0495 -0.1079 1.5300 1.4570 -28 -0.5892 0.7140 0.3505 0.0628 0.0873 -0.0882 1.1010 1.4570 -29 -0.9466 0.9356 -0.5542 0.0570 0.0625 0.4112 1.5300 1.0060 -30 -1.1685 0.9266 -0.0993 0.0850 0.3061 0.2104 1.1010 1.0060 -31 0.0286 0.0566 -0.0493 0.0286 0.0566 -0.0493 1.4570 1.4570 -32 0.1960 0.7056 0.1120 0.1022 0.2090 0.6433 1.1010 1.4570 -33 0.2130 0.3120 0.0777 0.2130 0.3120 0.0777 1.1010 1.1010 -34 -0.3190 0.4411 -0.7174 1.1538 0.8409 -0.9138 1.5300 1.4200 -35 0.2486 0.2422 -0.0925 0.0814 0.0591 0.2219 1.5300 1.1010 -36 1.0165 0.7553 -0.4609 1.0165 0.7553 -0.4609 1.4200 1.4200 -37 0.5903 0.6669 0.8584 0.9681 0.9551 0.0436 1.4200 1.1010 -38 0.9681 0.9551 0.0436 0.5903 0.6669 0.8584 1.1010 1.4200 -39 0.2130 0.3120 0.0777 0.2130 0.3120 0.0777 1.1010 1.1010 -40 0.0814 0.0591 0.2219 0.2486 0.2422 -0.0925 1.1010 1.5300 -41 0.2130 0.3120 0.0777 0.2130 0.3120 0.0777 1.1010 1.1010 -42 0.9681 0.9551 0.0436 0.5903 0.6669 0.8584 1.1010 1.4200 -43 0.0579 -0.0043 -0.1906 0.1032 0.5896 -0.4836 1.4570 1.5300 -44 0.1022 0.2090 0.6433 0.1960 0.7056 0.1120 1.4570 1.1010 -45 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.4570 1.4200 -46 0.0997 -0.0046 -0.2657 -0.0128 -0.0495 -0.1079 1.5300 1.4570 -47 -0.9466 0.9356 -0.5542 0.0570 0.0625 0.4112 1.5300 1.0060 -48 1.1538 0.8409 -0.9138 -0.3190 0.4411 -0.7174 1.4200 1.5300 -49 0.5903 0.6669 0.8584 0.9681 0.9551 0.0436 1.4200 1.1010 -50 1.0165 0.7553 -0.4609 1.0165 0.7553 -0.4609 1.4200 1.4200 -51 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.5300 1.3768 -52 -0.5800 0.9004 0.0000 0.0000 0.5343 0.9025 1.5300 0.9650 -53 -1.7554 1.3145 0.2263 0.2493 0.6803 0.0000 1.1010 0.9650 -54 0.9681 0.9551 0.0436 0.5903 0.6669 0.8584 1.1010 1.4200 -55 0.0814 0.0591 0.2219 0.2486 0.2422 -0.0925 1.1010 1.5300 -56 0.9681 0.9551 0.0436 0.5903 0.6669 0.8584 1.1010 1.4200 -57 0.0579 -0.0043 -0.1906 0.1032 0.5896 -0.4836 1.4570 1.5300 -58 0.1022 0.2090 0.6433 0.1960 0.7056 0.1120 1.4570 1.1010 -59 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.4570 1.4200 -60 0.0997 -0.0046 -0.2657 -0.0128 -0.0495 -0.1079 1.5300 1.4570 -61 1.1538 0.8409 -0.9138 -0.3190 0.4411 -0.7174 1.4200 1.5300 -62 1.0165 0.7553 -0.4609 1.0165 0.7553 -0.4609 1.4200 1.4200 -63 -0.5800 0.9004 0.0000 0.0000 0.5343 0.9025 1.5300 0.9650 -64 -1.7554 1.3145 0.2263 0.2493 0.6803 0.0000 1.1010 0.9650 -65 0.0000 0.5343 0.9025 -0.5800 0.9004 0.0000 0.9650 1.5300 -66 0.2493 0.6803 0.0000 -1.7554 1.3145 0.2263 0.9650 1.1010 +1 13.0421 0.0000 # cp-cp-cp-oc +2 4.8912 0.0000 # cp-cp-cp-hc +3 7.8153 0.0000 # cp-cp-cp-c +4 0.0000 0.0000 # c2-na-c2-hn +5 0.0000 0.0000 # c2-na-hn-hn +6 0.0000 0.0000 +7 0.0000 0.0000 +8 0.0000 0.0000 +9 0.0000 0.0000 +10 0.0000 0.0000 +11 0.0000 0.0000 +12 0.0000 0.0000 +13 0.0000 0.0000 +14 0.0000 0.0000 +15 0.0000 0.0000 +16 0.0000 0.0000 +17 0.0000 0.0000 +18 0.0000 0.0000 +19 0.0000 0.0000 +20 0.0000 0.0000 +21 0.0000 0.0000 +22 0.0000 0.0000 # c2-na-c2-c2 -MiddleBondTorsion Coeffs +BondBond Coeffs -1 -16.7975 -1.2296 -0.2750 1.5300 -2 -14.8790 -3.6581 -0.3138 1.5300 -3 -14.2610 -0.5322 -0.4864 1.5300 -4 -17.2585 -3.6157 -0.8364 1.5300 -5 -21.8842 -7.6764 -0.6868 1.5300 -6 -16.7975 -1.2296 -0.2750 1.5300 -7 0.0000 0.0000 0.0000 1.4200 -8 0.0000 0.0000 0.0000 1.4200 -9 -5.9288 -2.7007 -0.3175 1.4200 -10 -6.8007 -4.6546 -1.4101 1.4200 -11 -21.8842 -7.6764 -0.6868 1.5300 -12 -14.8790 -3.6581 -0.3138 1.5300 -13 -16.7975 -1.2296 -0.2750 1.5300 -14 -14.2610 -0.5322 -0.4864 1.5300 -15 27.5989 -2.3120 0.0000 1.4170 -16 0.0000 -1.1521 0.0000 1.4170 -17 0.0000 4.8255 0.0000 1.4170 -18 0.0000 5.5432 0.0000 1.4170 -19 0.0000 0.0000 0.0000 1.3768 -20 0.0000 4.8228 0.0000 1.4170 -21 0.0000 9.1792 0.0000 1.4170 -22 0.0000 3.9421 0.0000 1.4170 -23 0.0000 0.0000 0.0000 1.5010 -24 0.0000 0.0000 0.0000 1.5010 -25 0.0000 0.0000 0.0000 1.5300 -26 -14.8790 -3.6581 -0.3138 1.5300 -27 -8.0036 -7.7321 -3.0640 1.4570 -28 -6.4529 -6.8122 -1.1632 1.4570 -29 -2.2208 0.5479 -0.3527 1.4570 -30 -3.4611 1.6996 -0.6007 1.4570 -31 -3.3497 1.0143 -3.0062 1.5300 -32 -10.4959 -0.7647 -0.0545 1.5300 -33 -14.2610 -0.5322 -0.4864 1.5300 -34 -21.8842 -7.6764 -0.6868 1.5300 -35 -14.8790 -3.6581 -0.3138 1.5300 -36 -17.2585 -3.6157 -0.8364 1.5300 -37 -16.7975 -1.2296 -0.2750 1.5300 -38 -16.7975 -1.2296 -0.2750 1.5300 -39 -14.2610 -0.5322 -0.4864 1.5300 -40 -14.8790 -3.6581 -0.3138 1.5300 -41 -14.2610 -0.5322 -0.4864 1.5300 -42 -16.7975 -1.2296 -0.2750 1.5300 -43 -15.4174 -7.3055 -1.0749 1.5300 -44 -10.4959 -0.7647 -0.0545 1.5300 -45 0.0000 0.0000 0.0000 1.5300 -46 -8.0036 -7.7321 -3.0640 1.4570 -47 -2.2208 0.5479 -0.3527 1.4570 -48 -21.8842 -7.6764 -0.6868 1.5300 -49 -16.7975 -1.2296 -0.2750 1.5300 -50 -17.2585 -3.6157 -0.8364 1.5300 -51 0.0000 0.0000 0.0000 1.4200 -52 1.2472 0.0000 0.7485 1.4200 -53 0.0000 0.9241 -0.5889 1.4200 -54 -16.7975 -1.2296 -0.2750 1.5300 -55 -14.8790 -3.6581 -0.3138 1.5300 -56 -16.7975 -1.2296 -0.2750 1.5300 -57 -15.4174 -7.3055 -1.0749 1.5300 -58 -10.4959 -0.7647 -0.0545 1.5300 -59 0.0000 0.0000 0.0000 1.5300 -60 -8.0036 -7.7321 -3.0640 1.4570 -61 -21.8842 -7.6764 -0.6868 1.5300 -62 -17.2585 -3.6157 -0.8364 1.5300 -63 1.2472 0.0000 0.7485 1.4200 -64 0.0000 0.9241 -0.5889 1.4200 -65 1.2472 0.0000 0.7485 1.4200 -66 0.0000 0.9241 -0.5889 1.4200 +1 3.3872 1.5300 1.1010 +2 5.3316 1.1010 1.1010 +3 23.1979 1.4200 1.1010 +4 11.4318 1.5300 1.4200 +5 11.4318 1.5300 1.4200 +6 0.0000 1.5300 1.5300 +7 3.3872 1.5300 1.1010 +8 11.4318 1.5300 1.4200 +9 23.1979 1.4200 1.1010 +10 3.3872 1.5300 1.1010 +11 5.3316 1.1010 1.1010 +12 -7.1131 1.4200 1.4200 +13 68.2856 1.4170 1.4170 +14 48.4754 1.4170 1.3768 +15 1.0795 1.4170 1.0982 +16 12.0676 1.4170 1.5010 +17 0.0000 1.5010 1.5300 +18 0.0000 1.5010 1.5010 +19 0.0000 1.5300 1.5300 +20 3.3872 1.5300 1.1010 +21 5.3316 1.1010 1.1010 +22 0.0000 1.4200 1.3768 +23 -2.1113 1.4570 1.4570 +24 -6.4168 1.4570 1.0060 +25 4.6217 1.5300 1.4570 +26 12.4260 1.1010 1.4570 +27 3.3872 1.5300 1.1010 +28 -1.8749 1.0060 1.0060 +29 0.0000 1.5300 1.5300 +30 3.3872 1.5300 1.1010 +31 4.6217 1.5300 1.4570 +32 0.0000 1.5300 1.5300 +33 3.3872 1.5300 1.1010 +34 11.4318 1.5300 1.4200 +35 23.1979 1.4200 1.1010 +36 11.4318 1.5300 1.4200 +37 -9.6879 1.4200 0.9650 +38 23.1979 1.1010 1.4200 +39 3.3872 1.1010 1.5300 +40 11.4318 1.4200 1.5300 +41 3.3872 1.1010 1.5300 +42 4.6217 1.5300 1.4570 +43 0.0000 1.5300 1.5300 +44 11.4318 1.5300 1.4200 +45 23.1979 1.4200 1.1010 +46 -9.6879 1.4200 0.9650 +47 4.6217 1.4570 1.5300 +48 3.3872 1.1010 1.5300 +49 11.4318 1.4200 1.5300 +50 -9.6879 0.9650 1.4200 -BondBond13 Coeffs +BondAngle Coeffs -1 0.0000 1.1010 1.4200 -2 0.0000 1.1010 1.5300 -3 0.0000 1.1010 1.1010 -4 0.0000 1.4200 1.4200 -5 0.0000 1.4200 1.5300 -6 0.0000 1.4200 1.1010 -7 0.0000 1.1010 1.3768 -8 0.0000 1.5300 1.3768 -9 0.0000 1.5300 1.4200 -10 0.0000 1.1010 1.4200 -11 0.0000 1.5300 1.4200 -12 0.0000 1.5300 1.1010 -13 0.0000 1.4200 1.1010 -14 0.0000 1.1010 1.1010 -15 53.0000 1.4170 1.4170 -16 -6.2741 1.4170 1.0982 -17 -2.2436 1.4170 1.3768 -18 2.0517 1.3768 1.0982 -19 0.0000 1.4170 1.4200 -20 -1.7077 1.0982 1.0982 -21 2.5085 1.4170 1.5010 -22 0.8743 1.5010 1.0982 -23 0.0000 1.4170 1.5300 -24 0.0000 1.4170 1.5010 -25 0.0000 1.5010 1.1010 -26 0.0000 1.5300 1.1010 -27 0.0000 1.5300 1.4570 -28 0.0000 1.1010 1.4570 -29 0.0000 1.5300 1.0060 -30 0.0000 1.1010 1.0060 -31 0.0000 1.4570 1.4570 -32 0.0000 1.1010 1.4570 -33 0.0000 1.1010 1.1010 -34 0.0000 1.5300 1.4200 -35 0.0000 1.5300 1.1010 -36 0.0000 1.4200 1.4200 -37 0.0000 1.4200 1.1010 -38 0.0000 1.1010 1.4200 -39 0.0000 1.1010 1.1010 -40 0.0000 1.1010 1.5300 -41 0.0000 1.1010 1.1010 -42 0.0000 1.1010 1.4200 -43 0.0000 1.4570 1.5300 -44 0.0000 1.4570 1.1010 -45 0.0000 1.4570 1.4200 -46 0.0000 1.5300 1.4570 -47 0.0000 1.5300 1.0060 -48 0.0000 1.4200 1.5300 -49 0.0000 1.4200 1.1010 -50 0.0000 1.4200 1.4200 -51 0.0000 1.5300 1.3768 -52 0.0000 1.5300 0.9650 -53 0.0000 1.1010 0.9650 -54 0.0000 1.1010 1.4200 -55 0.0000 1.1010 1.5300 -56 0.0000 1.1010 1.4200 -57 0.0000 1.4570 1.5300 -58 0.0000 1.4570 1.1010 -59 0.0000 1.4570 1.4200 -60 0.0000 1.5300 1.4570 -61 0.0000 1.4200 1.5300 -62 0.0000 1.4200 1.4200 -63 0.0000 1.5300 0.9650 -64 0.0000 1.1010 0.9650 -65 0.0000 0.9650 1.5300 -66 0.0000 0.9650 1.1010 +1 20.7540 11.4210 1.5300 1.1010 +2 18.1030 18.1030 1.1010 1.1010 +3 55.3270 4.6189 1.4200 1.1010 +4 2.6868 20.4033 1.5300 1.4200 +5 2.6868 20.4033 1.5300 1.4200 +6 8.0160 8.0160 1.5300 1.5300 +7 20.7540 11.4210 1.5300 1.1010 +8 2.6868 20.4033 1.5300 1.4200 +9 55.3270 4.6189 1.4200 1.1010 +10 20.7540 11.4210 1.5300 1.1010 +11 18.1030 18.1030 1.1010 1.1010 +12 -2.8112 -2.8112 1.4200 1.4200 +13 28.8708 28.8708 1.4170 1.4170 +14 58.4790 107.6806 1.4170 1.3768 +15 20.0033 24.2183 1.4170 1.0982 +16 31.0771 47.0579 1.4170 1.5010 +17 0.0000 0.0000 1.5010 1.5300 +18 0.0000 0.0000 1.5010 1.5010 +19 8.0160 8.0160 1.5300 1.5300 +20 20.7540 11.4210 1.5300 1.1010 +21 18.1030 18.1030 1.1010 1.1010 +22 0.0000 0.0000 1.4200 1.3768 +23 -7.2229 -7.2229 1.4570 1.4570 +24 31.8096 20.5799 1.4570 1.0060 +25 6.0876 16.5702 1.5300 1.4570 +26 13.4582 42.4332 1.1010 1.4570 +27 20.7540 11.4210 1.5300 1.1010 +28 28.0322 28.0322 1.0060 1.0060 +29 8.0160 8.0160 1.5300 1.5300 +30 20.7540 11.4210 1.5300 1.1010 +31 6.0876 16.5702 1.5300 1.4570 +32 8.0160 8.0160 1.5300 1.5300 +33 20.7540 11.4210 1.5300 1.1010 +34 2.6868 20.4033 1.5300 1.4200 +35 55.3270 4.6189 1.4200 1.1010 +36 2.6868 20.4033 1.5300 1.4200 +37 28.5800 18.9277 1.4200 0.9650 +38 4.6189 55.3270 1.1010 1.4200 +39 11.4210 20.7540 1.1010 1.5300 +40 20.4033 2.6868 1.4200 1.5300 +41 11.4210 20.7540 1.1010 1.5300 +42 6.0876 16.5702 1.5300 1.4570 +43 8.0160 8.0160 1.5300 1.5300 +44 2.6868 20.4033 1.5300 1.4200 +45 55.3270 4.6189 1.4200 1.1010 +46 28.5800 18.9277 1.4200 0.9650 +47 16.5702 6.0876 1.4570 1.5300 +48 11.4210 20.7540 1.1010 1.5300 +49 20.4033 2.6868 1.4200 1.5300 +50 18.9277 28.5800 0.9650 1.4200 -AngleTorsion Coeffs +AngleAngle Coeffs -1 2.3668 2.4920 -1.0122 -0.1892 0.4918 0.7273 110.7700 111.2700 -2 0.3113 0.4516 -0.1988 -0.2454 0.0000 -0.1136 110.7700 112.6700 -3 -0.8085 0.5569 -0.2466 -0.8085 0.5569 -0.2466 110.7700 110.7700 -4 0.5511 0.9737 -0.6673 0.5511 0.9737 -0.6673 111.2700 111.2700 -5 0.9672 -0.7566 -1.2331 0.5623 -0.3041 -0.4015 111.2700 112.6700 -6 -0.1892 0.4918 0.7273 2.3668 2.4920 -1.0122 111.2700 110.7700 -7 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 108.7280 102.9695 -8 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 111.2700 102.9695 -9 -2.7466 1.4877 -0.8955 0.5676 0.9450 0.0703 111.2700 104.5000 -10 -1.8234 1.6393 0.5144 -0.7777 0.4340 -0.6653 108.7280 104.5000 -11 0.5623 -0.3041 -0.4015 0.9672 -0.7566 -1.2331 112.6700 111.2700 -12 -0.2454 0.0000 -0.1136 0.3113 0.4516 -0.1988 112.6700 110.7700 -13 -0.1892 0.4918 0.7273 2.3668 2.4920 -1.0122 111.2700 110.7700 -14 -0.8085 0.5569 -0.2466 -0.8085 0.5569 -0.2466 110.7700 110.7700 -15 1.9767 1.0239 0.0000 1.9767 1.0239 0.0000 118.9000 118.9000 -16 0.0000 2.5014 0.0000 0.0000 2.7147 0.0000 118.9000 117.9400 -17 0.0000 10.0155 0.0000 0.0000 1.7404 0.0000 118.9000 123.4200 -18 0.0000 2.5706 0.0000 0.0000 1.8729 0.0000 123.4200 117.9400 -19 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 123.4200 102.9695 -20 0.0000 2.4501 0.0000 0.0000 2.4501 0.0000 117.9400 117.9400 -21 0.0000 3.8987 0.0000 0.0000 -4.4683 0.0000 118.9000 120.0500 -22 0.0000 -0.1242 0.0000 0.0000 3.4601 0.0000 120.0500 117.9400 -23 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 120.0500 108.4000 -24 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 120.0500 111.0000 -25 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 108.4000 110.7700 -26 -0.2454 0.0000 -0.1136 0.3113 0.4516 -0.1988 112.6700 110.7700 -27 -2.7883 1.5193 1.4796 1.2031 1.3645 -0.7071 111.9100 112.4436 -28 -2.6321 0.9353 -0.8398 -1.3582 0.1465 -0.5729 110.6204 112.4436 -29 -3.3430 4.4558 -0.0346 0.2873 -0.8072 -0.0960 111.9100 110.9538 -30 -3.9582 2.0063 0.3213 -0.4294 -0.4442 -0.6141 110.6204 110.9538 -31 1.3673 0.4528 -2.7700 1.3673 0.4528 -2.7700 111.9100 111.9100 -32 0.5111 1.6328 -1.0155 -1.1075 0.2820 0.8318 110.7700 111.9100 -33 -0.8085 0.5569 -0.2466 -0.8085 0.5569 -0.2466 110.7700 110.7700 -34 0.5623 -0.3041 -0.4015 0.9672 -0.7566 -1.2331 112.6700 111.2700 -35 -0.2454 0.0000 -0.1136 0.3113 0.4516 -0.1988 112.6700 110.7700 -36 0.5511 0.9737 -0.6673 0.5511 0.9737 -0.6673 111.2700 111.2700 -37 -0.1892 0.4918 0.7273 2.3668 2.4920 -1.0122 111.2700 110.7700 -38 2.3668 2.4920 -1.0122 -0.1892 0.4918 0.7273 110.7700 111.2700 -39 -0.8085 0.5569 -0.2466 -0.8085 0.5569 -0.2466 110.7700 110.7700 -40 0.3113 0.4516 -0.1988 -0.2454 0.0000 -0.1136 110.7700 112.6700 -41 -0.8085 0.5569 -0.2466 -0.8085 0.5569 -0.2466 110.7700 110.7700 -42 2.3668 2.4920 -1.0122 -0.1892 0.4918 0.7273 110.7700 111.2700 -43 2.0125 0.9440 -2.7612 -1.9225 -1.3450 0.2210 111.9100 112.6700 -44 -1.1075 0.2820 0.8318 0.5111 1.6328 -1.0155 111.9100 110.7700 -45 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 111.9100 111.2700 -46 -2.7883 1.5193 1.4796 1.2031 1.3645 -0.7071 111.9100 112.4436 -47 -3.3430 4.4558 -0.0346 0.2873 -0.8072 -0.0960 111.9100 110.9538 -48 0.9672 -0.7566 -1.2331 0.5623 -0.3041 -0.4015 111.2700 112.6700 -49 -0.1892 0.4918 0.7273 2.3668 2.4920 -1.0122 111.2700 110.7700 -50 0.5511 0.9737 -0.6673 0.5511 0.9737 -0.6673 111.2700 111.2700 -51 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 111.2700 102.9695 -52 -3.5903 2.5225 0.4888 0.8726 -0.3577 0.3888 111.2700 105.8000 -53 -3.4060 1.6396 0.0737 0.0000 -0.2810 -0.5944 108.7280 105.8000 -54 2.3668 2.4920 -1.0122 -0.1892 0.4918 0.7273 110.7700 111.2700 -55 0.3113 0.4516 -0.1988 -0.2454 0.0000 -0.1136 110.7700 112.6700 -56 2.3668 2.4920 -1.0122 -0.1892 0.4918 0.7273 110.7700 111.2700 -57 2.0125 0.9440 -2.7612 -1.9225 -1.3450 0.2210 111.9100 112.6700 -58 -1.1075 0.2820 0.8318 0.5111 1.6328 -1.0155 111.9100 110.7700 -59 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 111.9100 111.2700 -60 -2.7883 1.5193 1.4796 1.2031 1.3645 -0.7071 111.9100 112.4436 -61 0.9672 -0.7566 -1.2331 0.5623 -0.3041 -0.4015 111.2700 112.6700 -62 0.5511 0.9737 -0.6673 0.5511 0.9737 -0.6673 111.2700 111.2700 -63 -3.5903 2.5225 0.4888 0.8726 -0.3577 0.3888 111.2700 105.8000 -64 -3.4060 1.6396 0.0737 0.0000 -0.2810 -0.5944 108.7280 105.8000 -65 0.8726 -0.3577 0.3888 -3.5903 2.5225 0.4888 105.8000 111.2700 -66 0.0000 -0.2810 -0.5944 -3.4060 1.6396 0.0737 105.8000 108.7280 +1 0.0000 0.0000 0.0000 118.9000 123.4200 123.4200 +2 0.0000 0.0000 0.0000 118.9000 117.9400 117.9400 +3 0.0000 0.0000 0.0000 118.9000 120.0500 120.0500 +4 0.0000 0.0000 0.0000 112.4436 110.9538 110.9538 +5 0.0000 0.0000 0.0000 110.9538 107.0671 110.9538 +6 0.2738 -0.4825 0.2738 110.7700 107.6600 110.7700 +7 0.1689 2.5926 3.9177 111.2700 108.7280 110.7700 +8 2.4259 2.1283 2.4259 108.7280 107.6600 108.7280 +9 -0.8330 -0.8330 -3.5744 112.6700 111.2700 111.2700 +10 0.1689 2.5926 3.9177 111.2700 108.7280 110.7700 +11 -1.3199 -1.3199 0.1184 112.6700 110.7700 110.7700 +12 0.1689 2.5926 3.9177 111.2700 108.7280 110.7700 +13 0.2738 -0.4825 0.2738 110.7700 107.6600 110.7700 +14 2.4259 2.1283 2.4259 108.7280 107.6600 108.7280 +15 0.0000 0.0000 0.0000 108.4000 112.6700 108.4000 +16 0.0000 0.0000 0.0000 111.0000 108.4000 108.4000 +17 0.2738 -0.4825 0.2738 110.7700 107.6600 110.7700 +18 -0.3157 -0.3157 -0.3157 107.6600 107.6600 107.6600 +19 2.4286 0.5381 -2.5301 110.7700 110.6204 111.9100 +20 2.4321 2.4321 -3.5496 107.6600 110.6204 110.6204 +21 0.2738 -0.4825 0.2738 110.7700 107.6600 110.7700 +22 0.0000 0.0000 0.0000 112.4436 112.4436 112.4436 -Atoms # full +AngleAngleTorsion Coeffs -1 1 1 0.000000 25.246496201 -1.871744037 -8.651348114 0 0 0 # c2 -2 1 2 0.000000 25.610639572 -3.288228035 -8.165973663 0 0 0 # c3m -3 1 2 0.000000 24.731319427 -4.483242989 -8.675741196 0 0 0 # c3m -4 1 2 0.000000 18.703355789 9.118826866 -4.174236774 0 0 0 # c3m -5 1 2 0.000000 18.099748611 8.263649940 -5.343001842 0 0 0 # c3m -6 1 1 0.000000 19.081827164 7.609607220 -6.334177017 0 0 0 # c2 -7 1 3 0.100000 26.190139771 -4.295329094 -9.220970154 0 0 0 # o3e -8 1 3 0.100000 17.971729279 9.827675819 -5.367077827 0 0 0 # o3e -9 1 4 0.000000 20.263877869 5.733595848 -6.736782074 0 0 0 # cp -10 1 4 0.000000 19.777191162 4.983679771 -7.809411049 0 0 0 # cp -11 1 4 0.000000 20.667026520 4.390971184 -8.707633972 0 0 0 # cp -12 1 4 0.000000 22.043539047 4.548151016 -8.533248901 0 0 0 # cp -13 1 4 0.000000 22.530214310 5.298062801 -7.460619926 0 0 0 # cp -14 1 4 0.000000 21.640394211 5.890783787 -6.562390804 0 0 0 # cp -15 1 5 0.000000 23.005182266 3.906831026 -9.503917694 0 0 0 # c -16 1 6 0.000000 24.286390305 4.758069992 -9.590908051 0 0 0 # c3 -17 1 6 0.000000 22.342786789 3.812531948 -10.891778946 0 0 0 # c3 -18 1 4 0.000000 23.361906052 2.519830942 -9.029184341 0 0 0 # cp -19 1 4 0.000000 24.458705902 2.330889940 -8.185920715 0 0 0 # cp -20 1 4 0.000000 24.788816452 1.047963977 -7.745534897 0 0 0 # cp -21 1 4 0.000000 24.022008896 -0.046867002 -8.149927139 0 0 0 # cp -22 1 4 0.000000 22.925630569 0.140873000 -8.992565155 0 0 0 # cp -23 1 4 0.000000 22.595729828 1.424777985 -9.432847977 0 0 0 # cp -24 1 7 0.000000 19.414030075 6.299984932 -5.878956795 0 0 0 # oc -25 1 7 0.000000 24.338140488 -1.273216963 -7.729548931 0 0 0 # oc -26 1 8 0.000000 26.150024414 -1.266484976 -8.715751648 0 0 0 # hc -27 1 8 0.000000 24.778566360 -1.933199048 -9.633987427 0 0 0 # hc -28 1 8 0.000000 25.929294586 -2.927781105 -7.187973022 0 0 0 # hc -29 1 8 0.000000 24.549385071 -5.308847904 -7.987242222 0 0 0 # hc -30 1 8 0.000000 23.904827118 -4.254271030 -9.348136902 0 0 0 # hc -31 1 8 0.000000 18.194736481 9.091637611 -3.210949898 0 0 0 # hc -32 1 8 0.000000 19.788938522 9.208558083 -4.119643211 0 0 0 # hc -33 1 8 0.000000 17.399309158 7.432216167 -5.407801151 0 0 0 # hc -34 1 8 0.000000 18.616250992 7.545570850 -7.316913128 0 0 0 # hc -35 1 8 0.000000 19.987047195 8.212498665 -6.399401188 0 0 0 # hc -36 1 8 0.000000 18.713207245 4.862418175 -7.944396973 0 0 0 # hc -37 1 8 0.000000 20.290582657 3.811013937 -9.537291527 0 0 0 # hc -38 1 8 0.000000 23.594188690 5.419342995 -7.325634956 0 0 0 # hc -39 1 8 0.000000 22.016828537 6.470753193 -5.732734203 0 0 0 # hc -40 1 8 0.000000 24.982324600 4.297049999 -10.290958405 0 0 0 # hc -41 1 8 0.000000 24.034254074 5.760886192 -9.936174393 0 0 0 # hc -42 1 8 0.000000 24.749143600 4.819462776 -8.606439590 0 0 0 # hc -43 1 8 0.000000 23.034755707 3.349560976 -11.594371796 0 0 0 # hc -44 1 8 0.000000 21.438467026 3.207982063 -10.822364807 0 0 0 # hc -45 1 8 0.000000 22.084871292 4.811752796 -11.239845276 0 0 0 # hc -46 1 8 0.000000 25.050769806 3.177418947 -7.873311996 0 0 0 # hc -47 1 8 0.000000 25.636974335 0.901705027 -7.093626022 0 0 0 # hc -48 1 8 0.000000 22.333581924 -0.705653012 -9.305183411 0 0 0 # hc -49 1 8 0.000000 21.747369766 1.570054054 -10.084861755 0 0 0 # hc -50 1 1 0.000000 25.222612381 -4.200571060 0.463562995 0 0 0 # c2 -51 1 2 0.000000 25.832977295 -5.360119820 -0.347983003 0 0 0 # c3m -52 1 2 0.000000 27.389345169 -5.551681042 -0.290704012 0 0 0 # c3m -53 1 2 0.000000 20.635538101 8.396902084 -1.535487056 0 0 0 # c3m -54 1 2 0.000000 21.957460403 8.158697128 -0.723941982 0 0 0 # c3m -55 1 1 0.000000 22.041673660 6.895174980 0.154822007 0 0 0 # c2 -56 1 3 0.100000 26.447082520 -6.565405846 0.448491007 0 0 0 # o3e -57 1 3 0.100000 20.959102631 9.287891388 -0.285212994 0 0 0 # o3e -58 1 4 0.000000 22.680345535 4.733430862 0.158248007 0 0 0 # cp -59 1 4 0.000000 23.824728012 4.488029957 0.920358002 0 0 0 # cp -60 1 4 0.000000 23.901163101 3.343113899 1.716701984 0 0 0 # cp -61 1 4 0.000000 22.833225250 2.443607092 1.750934958 0 0 0 # cp -62 1 4 0.000000 21.688846588 2.689002037 0.988831997 0 0 0 # cp -63 1 4 0.000000 21.612403870 3.833913088 0.192488998 0 0 0 # cp -64 1 5 0.000000 22.916360855 1.205785036 2.611289978 0 0 0 # c -65 1 6 0.000000 21.501018524 0.810333014 3.075165987 0 0 0 # c3 -66 1 6 0.000000 23.808341980 1.493147969 3.834667921 0 0 0 # c3 -67 1 4 0.000000 23.514062881 0.070205003 1.817157984 0 0 0 # cp -68 1 4 0.000000 22.684833527 -0.782863975 1.085504055 0 0 0 # cp -69 1 4 0.000000 23.237234116 -1.833225965 0.349765003 0 0 0 # cp -70 1 4 0.000000 24.619955063 -2.031138897 0.346872985 0 0 0 # cp -71 1 4 0.000000 25.449554443 -1.179108977 1.077638030 0 0 0 # cp -72 1 4 0.000000 24.896312714 -0.128257006 1.813575983 0 0 0 # cp -73 1 7 0.000000 22.607131958 5.827101231 -0.602173984 0 0 0 # oc -74 1 7 0.000000 25.147769928 -3.035661936 -0.355791986 0 0 0 # oc -75 1 8 0.000000 24.221906662 -4.476489067 0.794990003 0 0 0 # hc -76 1 8 0.000000 25.849754333 -3.994390965 1.331357956 0 0 0 # hc -77 1 8 0.000000 25.097463608 -5.257826805 -1.146129966 0 0 0 # hc -78 1 8 0.000000 27.892013550 -5.893630028 -1.196079969 0 0 0 # hc -79 1 8 0.000000 27.964216232 -4.855231762 0.319745004 0 0 0 # hc -80 1 8 0.000000 20.720872879 8.854673386 -2.520912886 0 0 0 # hc -81 1 8 0.000000 19.840383530 7.656352043 -1.438712001 0 0 0 # hc -82 1 8 0.000000 23.017726898 8.120765686 -0.970986009 0 0 0 # hc -83 1 8 0.000000 22.669095993 7.097908974 1.022259951 0 0 0 # hc -84 1 8 0.000000 21.041725159 6.616360188 0.486577004 0 0 0 # hc -85 1 8 0.000000 24.650087357 5.183434963 0.894133985 0 0 0 # hc -86 1 8 0.000000 24.786277771 3.153367996 2.306194067 0 0 0 # hc -87 1 8 0.000000 20.863473892 1.993592978 1.015051961 0 0 0 # hc -88 1 8 0.000000 20.727291107 4.023673058 -0.397009999 0 0 0 # hc -89 1 8 0.000000 21.558345795 -0.083162002 3.696341038 0 0 0 # hc -90 1 8 0.000000 21.065618515 1.626867056 3.651936054 0 0 0 # hc -91 1 8 0.000000 20.876825333 0.608124971 2.205033064 0 0 0 # hc -92 1 8 0.000000 23.870355606 0.601037025 4.457283974 0 0 0 # hc -93 1 8 0.000000 24.807676315 1.770614982 3.498578072 0 0 0 # hc -94 1 8 0.000000 23.380037308 2.311306953 4.412462234 0 0 0 # hc -95 1 8 0.000000 21.616291046 -0.629218996 1.087699056 0 0 0 # hc -96 1 8 0.000000 22.596149445 -2.493021011 -0.215893999 0 0 0 # hc -97 1 8 0.000000 26.518102646 -1.332759023 1.075448036 0 0 0 # hc -98 1 8 0.000000 25.538236618 0.531040013 2.379035950 0 0 0 # hc -99 1 9 0.000000 16.072591782 12.338866234 -0.174325004 0 0 0 # na -100 1 1 0.000000 16.557256699 11.130316734 0.587288976 0 0 0 # c2 -101 1 1 0.000000 18.074571609 10.998808861 0.366084993 0 0 0 # c2 -102 1 9 -0.025000 18.353967667 10.832372665 -1.107717037 0 0 0 # na -103 1 9 -0.025000 14.920715332 15.017822266 -0.200534001 0 0 0 # na -104 1 1 0.000000 16.390434265 14.791102409 -0.460442007 0 0 0 # c2 -105 1 1 0.000000 16.852983475 13.538317680 0.304865986 0 0 0 # c2 -106 1 10 0.000000 16.263746262 12.190562248 -1.257431984 0 0 0 # hn -107 1 8 0.000000 16.025363922 10.195071220 0.210473999 0 0 0 # hc -108 1 8 0.000000 16.347120285 11.269214630 1.698830962 0 0 0 # hc -109 1 8 0.000000 18.467184067 10.092565536 0.934801996 0 0 0 # hc -110 1 8 0.000000 18.592388153 11.941304207 0.744638979 0 0 0 # hc -111 1 10 0.000000 17.843862534 9.919928551 -1.479779005 0 0 0 # hn -112 1 10 0.000000 19.448190689 10.736482620 -1.267521024 0 0 0 # hn -113 1 10 0.000000 14.344121933 14.136246681 -0.550131977 0 0 0 # hn -114 1 10 0.000000 14.583471298 15.922760963 -0.747138977 0 0 0 # hn -115 1 8 0.000000 16.984062195 15.696007729 -0.102596000 0 0 0 # hc -116 1 8 0.000000 16.562423706 14.639820099 -1.577000022 0 0 0 # hc -117 1 8 0.000000 16.674821854 13.685671806 1.420761943 0 0 0 # hc -118 1 8 0.000000 17.963953018 13.362975121 0.117853999 0 0 0 # hc +1 -20.2006 110.7700 111.2700 +2 -16.1640 110.7700 112.6700 +3 -12.5640 110.7700 110.7700 +4 -14.0484 111.2700 111.2700 +5 -29.0420 111.2700 112.6700 +6 -20.2006 111.2700 110.7700 +7 0.0000 108.7280 102.9695 +8 0.0000 111.2700 102.9695 +9 -19.0059 111.2700 104.5000 +10 -16.4438 108.7280 104.5000 +11 -29.0420 112.6700 111.2700 +12 -16.1640 112.6700 110.7700 +13 -20.2006 111.2700 110.7700 +14 -12.5640 110.7700 110.7700 +15 0.0000 118.9000 118.9000 +16 -4.8141 118.9000 117.9400 +17 -21.0247 118.9000 123.4200 +18 4.2296 123.4200 117.9400 +19 0.0000 123.4200 102.9695 +20 0.3598 117.9400 117.9400 +21 -14.4097 118.9000 120.0500 +22 4.4444 120.0500 117.9400 +23 0.0000 120.0500 108.4000 +24 0.0000 120.0500 111.0000 +25 0.0000 108.4000 110.7700 +26 -16.1640 112.6700 110.7700 +27 -24.3818 111.9100 112.4436 +28 -12.5567 110.6204 112.4436 +29 -7.5499 111.9100 110.9538 +30 -10.4258 110.6204 110.9538 +31 -11.2307 111.9100 111.9100 +32 -15.7572 110.7700 111.9100 +33 -12.5640 110.7700 110.7700 +34 -29.0420 112.6700 111.2700 +35 -16.1640 112.6700 110.7700 +36 -14.0484 111.2700 111.2700 +37 -20.2006 111.2700 110.7700 +38 -20.2006 110.7700 111.2700 +39 -12.5640 110.7700 110.7700 +40 -16.1640 110.7700 112.6700 +41 -12.5640 110.7700 110.7700 +42 -20.2006 110.7700 111.2700 +43 -27.3953 111.9100 112.6700 +44 -15.7572 111.9100 110.7700 +45 0.0000 111.9100 111.2700 +46 -24.3818 111.9100 112.4436 +47 -7.5499 111.9100 110.9538 +48 -29.0420 111.2700 112.6700 +49 -20.2006 111.2700 110.7700 +50 -14.0484 111.2700 111.2700 +51 0.0000 111.2700 102.9695 +52 -12.1038 111.2700 105.8000 +53 -10.5093 108.7280 105.8000 +54 -20.2006 110.7700 111.2700 +55 -16.1640 110.7700 112.6700 +56 -20.2006 110.7700 111.2700 +57 -27.3953 111.9100 112.6700 +58 -15.7572 111.9100 110.7700 +59 0.0000 111.9100 111.2700 +60 -24.3818 111.9100 112.4436 +61 -29.0420 111.2700 112.6700 +62 -14.0484 111.2700 111.2700 +63 -12.1038 111.2700 105.8000 +64 -10.5093 108.7280 105.8000 +65 -12.1038 105.8000 111.2700 +66 -10.5093 105.8000 108.7280 -Bonds +EndBondTorsion Coeffs -1 1 1 26 -2 2 1 2 -3 1 1 27 -4 3 1 25 -5 4 2 7 -6 5 2 3 -7 6 2 28 -8 4 3 7 -9 6 3 29 -10 6 3 30 -11 6 4 32 -12 4 4 8 -13 5 4 5 -14 6 4 31 -15 4 5 8 -16 2 6 5 -17 6 5 33 -18 3 6 24 -19 1 6 34 -20 1 6 35 -21 7 9 14 -22 7 9 10 -23 8 9 24 -24 7 10 11 -25 9 10 36 -26 7 11 12 -27 9 11 37 -28 7 12 13 -29 10 12 15 -30 7 13 14 -31 9 13 38 -32 9 14 39 -33 11 15 16 -34 11 15 17 -35 10 18 15 -36 12 16 40 -37 12 16 41 -38 12 16 42 -39 12 17 43 -40 12 17 44 -41 12 17 45 -42 7 18 23 -43 7 18 19 -44 7 19 20 -45 9 19 46 -46 7 20 21 -47 9 20 47 -48 7 21 22 -49 8 21 25 -50 7 22 23 -51 9 22 48 -52 9 23 49 -53 1 50 75 -54 2 50 51 -55 1 50 76 -56 3 50 74 -57 4 51 56 -58 5 51 52 -59 6 51 77 -60 4 52 56 -61 6 52 78 -62 6 52 79 -63 6 53 81 -64 4 53 57 -65 5 53 54 -66 6 53 80 -67 4 54 57 -68 2 55 54 -69 6 54 82 -70 3 55 73 -71 1 55 83 -72 1 55 84 -73 7 58 63 -74 7 58 59 -75 8 58 73 -76 7 59 60 -77 9 59 85 -78 7 60 61 -79 9 60 86 -80 7 61 62 -81 10 61 64 -82 7 62 63 -83 9 62 87 -84 9 63 88 -85 11 64 65 -86 11 64 66 -87 10 67 64 -88 12 65 89 -89 12 65 90 -90 12 65 91 -91 12 66 92 -92 12 66 93 -93 12 66 94 -94 7 67 72 -95 7 67 68 -96 7 68 69 -97 9 68 95 -98 7 69 70 -99 9 69 96 -100 7 70 71 -101 8 70 74 -102 7 71 72 -103 9 71 97 -104 9 72 98 -105 13 100 99 -106 13 105 99 -107 14 99 106 -108 15 100 101 -109 1 100 107 -110 1 100 108 -111 13 101 102 -112 1 101 109 -113 1 101 110 -114 14 102 111 -115 14 102 112 -116 13 104 103 -117 14 103 113 -118 14 103 114 -119 15 104 105 -120 1 104 115 -121 1 104 116 -122 1 105 117 -123 1 105 118 +1 0.9681 0.9551 0.0436 0.5903 0.6669 0.8584 1.1010 1.4200 +2 0.0814 0.0591 0.2219 0.2486 0.2422 -0.0925 1.1010 1.5300 +3 0.2130 0.3120 0.0777 0.2130 0.3120 0.0777 1.1010 1.1010 +4 1.0165 0.7553 -0.4609 1.0165 0.7553 -0.4609 1.4200 1.4200 +5 1.1538 0.8409 -0.9138 -0.3190 0.4411 -0.7174 1.4200 1.5300 +6 0.5903 0.6669 0.8584 0.9681 0.9551 0.0436 1.4200 1.1010 +7 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.1010 1.3768 +8 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.5300 1.3768 +9 -0.2456 1.0517 -0.7795 0.4741 1.2635 0.5576 1.5300 1.4200 +10 -0.6054 1.3339 0.9648 -0.1620 0.1564 -1.1408 1.1010 1.4200 +11 -0.3190 0.4411 -0.7174 1.1538 0.8409 -0.9138 1.5300 1.4200 +12 0.2486 0.2422 -0.0925 0.0814 0.0591 0.2219 1.5300 1.1010 +13 0.5903 0.6669 0.8584 0.9681 0.9551 0.0436 1.4200 1.1010 +14 0.2130 0.3120 0.0777 0.2130 0.3120 0.0777 1.1010 1.1010 +15 -0.1185 6.3204 0.0000 -0.1185 6.3204 0.0000 1.4170 1.4170 +16 0.0000 -6.8958 0.0000 0.0000 -0.4669 0.0000 1.4170 1.0982 +17 0.0000 0.2655 0.0000 0.0000 4.8905 0.0000 1.4170 1.3768 +18 0.0000 4.2641 0.0000 0.0000 -1.5867 0.0000 1.3768 1.0982 +19 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.4170 1.4200 +20 0.0000 -0.6890 0.0000 0.0000 -0.6890 0.0000 1.0982 1.0982 +21 0.0000 -0.6918 0.0000 0.0000 0.2421 0.0000 1.4170 1.5010 +22 0.0000 -1.7970 0.0000 0.0000 -0.4879 0.0000 1.5010 1.0982 +23 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.4170 1.5300 +24 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.4170 1.5010 +25 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.5010 1.1010 +26 0.2486 0.2422 -0.0925 0.0814 0.0591 0.2219 1.5300 1.1010 +27 0.0997 -0.0046 -0.2657 -0.0128 -0.0495 -0.1079 1.5300 1.4570 +28 -0.5892 0.7140 0.3505 0.0628 0.0873 -0.0882 1.1010 1.4570 +29 -0.9466 0.9356 -0.5542 0.0570 0.0625 0.4112 1.5300 1.0060 +30 -1.1685 0.9266 -0.0993 0.0850 0.3061 0.2104 1.1010 1.0060 +31 0.0286 0.0566 -0.0493 0.0286 0.0566 -0.0493 1.4570 1.4570 +32 0.1960 0.7056 0.1120 0.1022 0.2090 0.6433 1.1010 1.4570 +33 0.2130 0.3120 0.0777 0.2130 0.3120 0.0777 1.1010 1.1010 +34 -0.3190 0.4411 -0.7174 1.1538 0.8409 -0.9138 1.5300 1.4200 +35 0.2486 0.2422 -0.0925 0.0814 0.0591 0.2219 1.5300 1.1010 +36 1.0165 0.7553 -0.4609 1.0165 0.7553 -0.4609 1.4200 1.4200 +37 0.5903 0.6669 0.8584 0.9681 0.9551 0.0436 1.4200 1.1010 +38 0.9681 0.9551 0.0436 0.5903 0.6669 0.8584 1.1010 1.4200 +39 0.2130 0.3120 0.0777 0.2130 0.3120 0.0777 1.1010 1.1010 +40 0.0814 0.0591 0.2219 0.2486 0.2422 -0.0925 1.1010 1.5300 +41 0.2130 0.3120 0.0777 0.2130 0.3120 0.0777 1.1010 1.1010 +42 0.9681 0.9551 0.0436 0.5903 0.6669 0.8584 1.1010 1.4200 +43 0.0579 -0.0043 -0.1906 0.1032 0.5896 -0.4836 1.4570 1.5300 +44 0.1022 0.2090 0.6433 0.1960 0.7056 0.1120 1.4570 1.1010 +45 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.4570 1.4200 +46 0.0997 -0.0046 -0.2657 -0.0128 -0.0495 -0.1079 1.5300 1.4570 +47 -0.9466 0.9356 -0.5542 0.0570 0.0625 0.4112 1.5300 1.0060 +48 1.1538 0.8409 -0.9138 -0.3190 0.4411 -0.7174 1.4200 1.5300 +49 0.5903 0.6669 0.8584 0.9681 0.9551 0.0436 1.4200 1.1010 +50 1.0165 0.7553 -0.4609 1.0165 0.7553 -0.4609 1.4200 1.4200 +51 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.5300 1.3768 +52 -0.5800 0.9004 0.0000 0.0000 0.5343 0.9025 1.5300 0.9650 +53 -1.7554 1.3145 0.2263 0.2493 0.6803 0.0000 1.1010 0.9650 +54 0.9681 0.9551 0.0436 0.5903 0.6669 0.8584 1.1010 1.4200 +55 0.0814 0.0591 0.2219 0.2486 0.2422 -0.0925 1.1010 1.5300 +56 0.9681 0.9551 0.0436 0.5903 0.6669 0.8584 1.1010 1.4200 +57 0.0579 -0.0043 -0.1906 0.1032 0.5896 -0.4836 1.4570 1.5300 +58 0.1022 0.2090 0.6433 0.1960 0.7056 0.1120 1.4570 1.1010 +59 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.4570 1.4200 +60 0.0997 -0.0046 -0.2657 -0.0128 -0.0495 -0.1079 1.5300 1.4570 +61 1.1538 0.8409 -0.9138 -0.3190 0.4411 -0.7174 1.4200 1.5300 +62 1.0165 0.7553 -0.4609 1.0165 0.7553 -0.4609 1.4200 1.4200 +63 -0.5800 0.9004 0.0000 0.0000 0.5343 0.9025 1.5300 0.9650 +64 -1.7554 1.3145 0.2263 0.2493 0.6803 0.0000 1.1010 0.9650 +65 0.0000 0.5343 0.9025 -0.5800 0.9004 0.0000 0.9650 1.5300 +66 0.2493 0.6803 0.0000 -1.7554 1.3145 0.2263 0.9650 1.1010 -Angles +MiddleBondTorsion Coeffs -1 1 2 1 26 -2 2 26 1 27 -3 3 25 1 26 -4 1 2 1 27 -5 4 2 1 25 -6 3 25 1 27 -7 5 1 2 7 -8 6 1 2 3 -9 7 1 2 28 -10 8 3 2 7 -11 9 7 2 28 -12 10 3 2 28 -13 8 2 3 7 -14 10 2 3 29 -15 10 2 3 30 -16 9 7 3 29 -17 9 7 3 30 -18 11 29 3 30 -19 9 8 4 32 -20 10 5 4 32 -21 11 32 4 31 -22 8 5 4 8 -23 9 8 4 31 -24 10 5 4 31 -25 8 4 5 8 -26 6 6 5 4 -27 10 4 5 33 -28 5 6 5 8 -29 9 8 5 33 -30 7 6 5 33 -31 4 5 6 24 -32 1 5 6 34 -33 1 5 6 35 -34 3 24 6 34 -35 3 24 6 35 -36 2 34 6 35 -37 12 2 7 3 -38 12 4 8 5 -39 13 14 9 10 -40 14 14 9 24 -41 14 10 9 24 -42 13 9 10 11 -43 15 9 10 36 -44 15 11 10 36 -45 13 10 11 12 -46 15 10 11 37 -47 15 12 11 37 -48 13 11 12 13 -49 16 11 12 15 -50 16 13 12 15 -51 13 12 13 14 -52 15 12 13 38 -53 15 14 13 38 -54 13 9 14 13 -55 15 9 14 39 -56 15 13 14 39 -57 17 12 15 16 -58 17 12 15 17 -59 18 12 15 18 -60 19 16 15 17 -61 17 18 15 16 -62 17 18 15 17 -63 20 15 16 40 -64 20 15 16 41 -65 20 15 16 42 -66 21 40 16 41 -67 21 40 16 42 -68 21 41 16 42 -69 20 15 17 43 -70 20 15 17 44 -71 20 15 17 45 -72 21 43 17 44 -73 21 43 17 45 -74 21 44 17 45 -75 16 23 18 15 -76 16 19 18 15 -77 13 23 18 19 -78 13 18 19 20 -79 15 18 19 46 -80 15 20 19 46 -81 13 19 20 21 -82 15 19 20 47 -83 15 21 20 47 -84 13 20 21 22 -85 14 20 21 25 -86 14 22 21 25 -87 13 21 22 23 -88 15 21 22 48 -89 15 23 22 48 -90 13 18 23 22 -91 15 18 23 49 -92 15 22 23 49 -93 22 6 24 9 -94 22 1 25 21 -95 1 51 50 75 -96 2 75 50 76 -97 3 74 50 75 -98 1 51 50 76 -99 4 51 50 74 -100 3 74 50 76 -101 5 50 51 56 -102 6 50 51 52 -103 7 50 51 77 -104 8 52 51 56 -105 9 56 51 77 -106 10 52 51 77 -107 8 51 52 56 -108 10 51 52 78 -109 10 51 52 79 -110 9 56 52 78 -111 9 56 52 79 -112 11 78 52 79 -113 9 57 53 81 -114 10 54 53 81 -115 11 81 53 80 -116 8 54 53 57 -117 9 57 53 80 -118 10 54 53 80 -119 8 53 54 57 -120 6 55 54 53 -121 10 53 54 82 -122 5 55 54 57 -123 9 57 54 82 -124 7 55 54 82 -125 4 54 55 73 -126 1 54 55 83 -127 1 54 55 84 -128 3 73 55 83 -129 3 73 55 84 -130 2 83 55 84 -131 12 51 56 52 -132 12 53 57 54 -133 13 63 58 59 -134 14 63 58 73 -135 14 59 58 73 -136 13 58 59 60 -137 15 58 59 85 -138 15 60 59 85 -139 13 59 60 61 -140 15 59 60 86 -141 15 61 60 86 -142 13 60 61 62 -143 16 60 61 64 -144 16 62 61 64 -145 13 61 62 63 -146 15 61 62 87 -147 15 63 62 87 -148 13 58 63 62 -149 15 58 63 88 -150 15 62 63 88 -151 17 61 64 65 -152 17 61 64 66 -153 18 61 64 67 -154 19 65 64 66 -155 17 67 64 65 -156 17 67 64 66 -157 20 64 65 89 -158 20 64 65 90 -159 20 64 65 91 -160 21 89 65 90 -161 21 89 65 91 -162 21 90 65 91 -163 20 64 66 92 -164 20 64 66 93 -165 20 64 66 94 -166 21 92 66 93 -167 21 92 66 94 -168 21 93 66 94 -169 16 72 67 64 -170 16 68 67 64 -171 13 72 67 68 -172 13 67 68 69 -173 15 67 68 95 -174 15 69 68 95 -175 13 68 69 70 -176 15 68 69 96 -177 15 70 69 96 -178 13 69 70 71 -179 14 69 70 74 -180 14 71 70 74 -181 13 70 71 72 -182 15 70 71 97 -183 15 72 71 97 -184 13 67 72 71 -185 15 67 72 98 -186 15 71 72 98 -187 22 55 73 58 -188 22 50 74 70 -189 23 100 99 105 -190 24 100 99 106 -191 24 105 99 106 -192 25 101 100 99 -193 26 107 100 99 -194 26 108 100 99 -195 27 101 100 107 -196 27 101 100 108 -197 2 107 100 108 -198 25 100 101 102 -199 27 100 101 109 -200 27 100 101 110 -201 26 109 101 102 -202 26 110 101 102 -203 2 109 101 110 -204 24 101 102 111 -205 24 101 102 112 -206 28 111 102 112 -207 24 104 103 113 -208 24 104 103 114 -209 28 113 103 114 -210 25 105 104 103 -211 26 115 104 103 -212 26 116 104 103 -213 27 105 104 115 -214 27 105 104 116 -215 2 115 104 116 -216 25 104 105 99 -217 26 117 105 99 -218 26 118 105 99 -219 27 104 105 117 -220 27 104 105 118 -221 2 117 105 118 +1 -16.7975 -1.2296 -0.2750 1.5300 +2 -14.8790 -3.6581 -0.3138 1.5300 +3 -14.2610 -0.5322 -0.4864 1.5300 +4 -17.2585 -3.6157 -0.8364 1.5300 +5 -21.8842 -7.6764 -0.6868 1.5300 +6 -16.7975 -1.2296 -0.2750 1.5300 +7 0.0000 0.0000 0.0000 1.4200 +8 0.0000 0.0000 0.0000 1.4200 +9 -5.9288 -2.7007 -0.3175 1.4200 +10 -6.8007 -4.6546 -1.4101 1.4200 +11 -21.8842 -7.6764 -0.6868 1.5300 +12 -14.8790 -3.6581 -0.3138 1.5300 +13 -16.7975 -1.2296 -0.2750 1.5300 +14 -14.2610 -0.5322 -0.4864 1.5300 +15 27.5989 -2.3120 0.0000 1.4170 +16 0.0000 -1.1521 0.0000 1.4170 +17 0.0000 4.8255 0.0000 1.4170 +18 0.0000 5.5432 0.0000 1.4170 +19 0.0000 0.0000 0.0000 1.3768 +20 0.0000 4.8228 0.0000 1.4170 +21 0.0000 9.1792 0.0000 1.4170 +22 0.0000 3.9421 0.0000 1.4170 +23 0.0000 0.0000 0.0000 1.5010 +24 0.0000 0.0000 0.0000 1.5010 +25 0.0000 0.0000 0.0000 1.5300 +26 -14.8790 -3.6581 -0.3138 1.5300 +27 -8.0036 -7.7321 -3.0640 1.4570 +28 -6.4529 -6.8122 -1.1632 1.4570 +29 -2.2208 0.5479 -0.3527 1.4570 +30 -3.4611 1.6996 -0.6007 1.4570 +31 -3.3497 1.0143 -3.0062 1.5300 +32 -10.4959 -0.7647 -0.0545 1.5300 +33 -14.2610 -0.5322 -0.4864 1.5300 +34 -21.8842 -7.6764 -0.6868 1.5300 +35 -14.8790 -3.6581 -0.3138 1.5300 +36 -17.2585 -3.6157 -0.8364 1.5300 +37 -16.7975 -1.2296 -0.2750 1.5300 +38 -16.7975 -1.2296 -0.2750 1.5300 +39 -14.2610 -0.5322 -0.4864 1.5300 +40 -14.8790 -3.6581 -0.3138 1.5300 +41 -14.2610 -0.5322 -0.4864 1.5300 +42 -16.7975 -1.2296 -0.2750 1.5300 +43 -15.4174 -7.3055 -1.0749 1.5300 +44 -10.4959 -0.7647 -0.0545 1.5300 +45 0.0000 0.0000 0.0000 1.5300 +46 -8.0036 -7.7321 -3.0640 1.4570 +47 -2.2208 0.5479 -0.3527 1.4570 +48 -21.8842 -7.6764 -0.6868 1.5300 +49 -16.7975 -1.2296 -0.2750 1.5300 +50 -17.2585 -3.6157 -0.8364 1.5300 +51 0.0000 0.0000 0.0000 1.4200 +52 1.2472 0.0000 0.7485 1.4200 +53 0.0000 0.9241 -0.5889 1.4200 +54 -16.7975 -1.2296 -0.2750 1.5300 +55 -14.8790 -3.6581 -0.3138 1.5300 +56 -16.7975 -1.2296 -0.2750 1.5300 +57 -15.4174 -7.3055 -1.0749 1.5300 +58 -10.4959 -0.7647 -0.0545 1.5300 +59 0.0000 0.0000 0.0000 1.5300 +60 -8.0036 -7.7321 -3.0640 1.4570 +61 -21.8842 -7.6764 -0.6868 1.5300 +62 -17.2585 -3.6157 -0.8364 1.5300 +63 1.2472 0.0000 0.7485 1.4200 +64 0.0000 0.9241 -0.5889 1.4200 +65 1.2472 0.0000 0.7485 1.4200 +66 0.0000 0.9241 -0.5889 1.4200 -Dihedrals +BondBond13 Coeffs -1 1 26 1 2 7 -2 2 26 1 2 3 -3 3 26 1 2 28 -4 1 27 1 2 7 -5 2 27 1 2 3 -6 3 27 1 2 28 -7 4 25 1 2 7 -8 5 25 1 2 3 -9 6 25 1 2 28 -10 7 26 1 25 21 -11 8 2 1 25 21 -12 7 27 1 25 21 -13 9 1 2 7 3 -14 10 28 2 7 3 -15 11 1 2 3 7 -16 12 1 2 3 29 -17 12 1 2 3 30 -18 13 7 2 3 29 -19 13 7 2 3 30 -20 13 7 3 2 28 -21 14 28 2 3 29 -22 14 28 2 3 30 -23 10 29 3 7 2 -24 10 30 3 7 2 -25 10 32 4 8 5 -26 10 31 4 8 5 -27 13 8 5 4 32 -28 12 6 5 4 32 -29 14 32 4 5 33 -30 11 6 5 4 8 -31 13 8 4 5 33 -32 13 8 5 4 31 -33 12 6 5 4 31 -34 14 31 4 5 33 -35 9 6 5 8 4 -36 10 33 5 8 4 -37 5 24 6 5 4 -38 2 34 6 5 4 -39 2 35 6 5 4 -40 4 24 6 5 8 -41 1 34 6 5 8 -42 1 35 6 5 8 -43 6 24 6 5 33 -44 3 34 6 5 33 -45 3 35 6 5 33 -46 8 5 6 24 9 -47 7 34 6 24 9 -48 7 35 6 24 9 -49 15 10 9 14 13 -50 16 10 9 14 39 -51 17 13 14 9 24 -52 18 24 9 14 39 -53 15 14 9 10 11 -54 16 14 9 10 36 -55 17 11 10 9 24 -56 18 24 9 10 36 -57 19 14 9 24 6 -58 19 10 9 24 6 -59 15 9 10 11 12 -60 16 9 10 11 37 -61 16 12 11 10 36 -62 20 36 10 11 37 -63 15 10 11 12 13 -64 21 10 11 12 15 -65 16 13 12 11 37 -66 22 15 12 11 37 -67 15 11 12 13 14 -68 16 11 12 13 38 -69 21 14 13 12 15 -70 22 15 12 13 38 -71 23 11 12 15 16 -72 23 11 12 15 17 -73 24 11 12 15 18 -74 23 13 12 15 16 -75 23 13 12 15 17 -76 24 13 12 15 18 -77 15 12 13 14 9 -78 16 12 13 14 39 -79 16 9 14 13 38 -80 20 38 13 14 39 -81 25 12 15 16 40 -82 25 12 15 16 41 -83 25 12 15 16 42 -84 26 17 15 16 40 -85 26 17 15 16 41 -86 26 17 15 16 42 -87 25 18 15 16 40 -88 25 18 15 16 41 -89 25 18 15 16 42 -90 25 12 15 17 43 -91 25 12 15 17 44 -92 25 12 15 17 45 -93 26 16 15 17 43 -94 26 16 15 17 44 -95 26 16 15 17 45 -96 25 18 15 17 43 -97 25 18 15 17 44 -98 25 18 15 17 45 -99 24 23 18 15 12 -100 24 19 18 15 12 -101 23 23 18 15 16 -102 23 19 18 15 16 -103 23 23 18 15 17 -104 23 19 18 15 17 -105 21 22 23 18 15 -106 22 15 18 23 49 -107 15 19 18 23 22 -108 16 19 18 23 49 -109 21 20 19 18 15 -110 22 15 18 19 46 -111 15 23 18 19 20 -112 16 23 18 19 46 -113 15 18 19 20 21 -114 16 18 19 20 47 -115 16 21 20 19 46 -116 20 46 19 20 47 -117 15 19 20 21 22 -118 17 19 20 21 25 -119 16 22 21 20 47 -120 18 25 21 20 47 -121 15 20 21 22 23 -122 16 20 21 22 48 -123 17 23 22 21 25 -124 18 25 21 22 48 -125 19 20 21 25 1 -126 19 22 21 25 1 -127 15 21 22 23 18 -128 16 21 22 23 49 -129 16 18 23 22 48 -130 20 48 22 23 49 -131 1 75 50 51 56 -132 2 75 50 51 52 -133 3 75 50 51 77 -134 1 76 50 51 56 -135 2 76 50 51 52 -136 3 76 50 51 77 -137 4 74 50 51 56 -138 5 74 50 51 52 -139 6 74 50 51 77 -140 7 75 50 74 70 -141 8 51 50 74 70 -142 7 76 50 74 70 -143 9 50 51 56 52 -144 10 77 51 56 52 -145 11 50 51 52 56 -146 12 50 51 52 78 -147 12 50 51 52 79 -148 13 56 51 52 78 -149 13 56 51 52 79 -150 13 56 52 51 77 -151 14 77 51 52 78 -152 14 77 51 52 79 -153 10 78 52 56 51 -154 10 79 52 56 51 -155 10 81 53 57 54 -156 10 80 53 57 54 -157 13 57 54 53 81 -158 12 55 54 53 81 -159 14 81 53 54 82 -160 11 55 54 53 57 -161 13 57 53 54 82 -162 13 57 54 53 80 -163 12 55 54 53 80 -164 14 80 53 54 82 -165 9 55 54 57 53 -166 10 82 54 57 53 -167 5 73 55 54 53 -168 2 83 55 54 53 -169 2 84 55 54 53 -170 4 73 55 54 57 -171 1 83 55 54 57 -172 1 84 55 54 57 -173 6 73 55 54 82 -174 3 83 55 54 82 -175 3 84 55 54 82 -176 8 54 55 73 58 -177 7 83 55 73 58 -178 7 84 55 73 58 -179 15 59 58 63 62 -180 16 59 58 63 88 -181 17 62 63 58 73 -182 18 73 58 63 88 -183 15 63 58 59 60 -184 16 63 58 59 85 -185 17 60 59 58 73 -186 18 73 58 59 85 -187 19 63 58 73 55 -188 19 59 58 73 55 -189 15 58 59 60 61 -190 16 58 59 60 86 -191 16 61 60 59 85 -192 20 85 59 60 86 -193 15 59 60 61 62 -194 21 59 60 61 64 -195 16 62 61 60 86 -196 22 64 61 60 86 -197 15 60 61 62 63 -198 16 60 61 62 87 -199 21 63 62 61 64 -200 22 64 61 62 87 -201 23 60 61 64 65 -202 23 60 61 64 66 -203 24 60 61 64 67 -204 23 62 61 64 65 -205 23 62 61 64 66 -206 24 62 61 64 67 -207 15 61 62 63 58 -208 16 61 62 63 88 -209 16 58 63 62 87 -210 20 87 62 63 88 -211 25 61 64 65 89 -212 25 61 64 65 90 -213 25 61 64 65 91 -214 26 66 64 65 89 -215 26 66 64 65 90 -216 26 66 64 65 91 -217 25 67 64 65 89 -218 25 67 64 65 90 -219 25 67 64 65 91 -220 25 61 64 66 92 -221 25 61 64 66 93 -222 25 61 64 66 94 -223 26 65 64 66 92 -224 26 65 64 66 93 -225 26 65 64 66 94 -226 25 67 64 66 92 -227 25 67 64 66 93 -228 25 67 64 66 94 -229 24 72 67 64 61 -230 24 68 67 64 61 -231 23 72 67 64 65 -232 23 68 67 64 65 -233 23 72 67 64 66 -234 23 68 67 64 66 -235 21 71 72 67 64 -236 22 64 67 72 98 -237 15 68 67 72 71 -238 16 68 67 72 98 -239 21 69 68 67 64 -240 22 64 67 68 95 -241 15 72 67 68 69 -242 16 72 67 68 95 -243 15 67 68 69 70 -244 16 67 68 69 96 -245 16 70 69 68 95 -246 20 95 68 69 96 -247 15 68 69 70 71 -248 17 68 69 70 74 -249 16 71 70 69 96 -250 18 74 70 69 96 -251 15 69 70 71 72 -252 16 69 70 71 97 -253 17 72 71 70 74 -254 18 74 70 71 97 -255 19 69 70 74 50 -256 19 71 70 74 50 -257 15 70 71 72 67 -258 16 70 71 72 98 -259 16 67 72 71 97 -260 20 97 71 72 98 -261 27 101 100 99 105 -262 28 107 100 99 105 -263 28 108 100 99 105 -264 29 101 100 99 106 -265 30 107 100 99 106 -266 30 108 100 99 106 -267 27 104 105 99 100 -268 28 117 105 99 100 -269 28 118 105 99 100 -270 29 104 105 99 106 -271 30 117 105 99 106 -272 30 118 105 99 106 -273 31 99 100 101 102 -274 32 109 101 100 99 -275 32 110 101 100 99 -276 32 107 100 101 102 -277 33 107 100 101 109 -278 33 107 100 101 110 -279 32 108 100 101 102 -280 33 108 100 101 109 -281 33 108 100 101 110 -282 29 100 101 102 111 -283 29 100 101 102 112 -284 30 109 101 102 111 -285 30 109 101 102 112 -286 30 110 101 102 111 -287 30 110 101 102 112 -288 29 105 104 103 113 -289 30 115 104 103 113 -290 30 116 104 103 113 -291 29 105 104 103 114 -292 30 115 104 103 114 -293 30 116 104 103 114 -294 31 103 104 105 99 -295 32 117 105 104 103 -296 32 118 105 104 103 -297 32 115 104 105 99 -298 33 115 104 105 117 -299 33 115 104 105 118 -300 32 116 104 105 99 -301 33 116 104 105 117 -302 33 116 104 105 118 +1 0.0000 1.1010 1.4200 +2 0.0000 1.1010 1.5300 +3 0.0000 1.1010 1.1010 +4 0.0000 1.4200 1.4200 +5 0.0000 1.4200 1.5300 +6 0.0000 1.4200 1.1010 +7 0.0000 1.1010 1.3768 +8 0.0000 1.5300 1.3768 +9 0.0000 1.5300 1.4200 +10 0.0000 1.1010 1.4200 +11 0.0000 1.5300 1.4200 +12 0.0000 1.5300 1.1010 +13 0.0000 1.4200 1.1010 +14 0.0000 1.1010 1.1010 +15 53.0000 1.4170 1.4170 +16 -6.2741 1.4170 1.0982 +17 -2.2436 1.4170 1.3768 +18 2.0517 1.3768 1.0982 +19 0.0000 1.4170 1.4200 +20 -1.7077 1.0982 1.0982 +21 2.5085 1.4170 1.5010 +22 0.8743 1.5010 1.0982 +23 0.0000 1.4170 1.5300 +24 0.0000 1.4170 1.5010 +25 0.0000 1.5010 1.1010 +26 0.0000 1.5300 1.1010 +27 0.0000 1.5300 1.4570 +28 0.0000 1.1010 1.4570 +29 0.0000 1.5300 1.0060 +30 0.0000 1.1010 1.0060 +31 0.0000 1.4570 1.4570 +32 0.0000 1.1010 1.4570 +33 0.0000 1.1010 1.1010 +34 0.0000 1.5300 1.4200 +35 0.0000 1.5300 1.1010 +36 0.0000 1.4200 1.4200 +37 0.0000 1.4200 1.1010 +38 0.0000 1.1010 1.4200 +39 0.0000 1.1010 1.1010 +40 0.0000 1.1010 1.5300 +41 0.0000 1.1010 1.1010 +42 0.0000 1.1010 1.4200 +43 0.0000 1.4570 1.5300 +44 0.0000 1.4570 1.1010 +45 0.0000 1.4570 1.4200 +46 0.0000 1.5300 1.4570 +47 0.0000 1.5300 1.0060 +48 0.0000 1.4200 1.5300 +49 0.0000 1.4200 1.1010 +50 0.0000 1.4200 1.4200 +51 0.0000 1.5300 1.3768 +52 0.0000 1.5300 0.9650 +53 0.0000 1.1010 0.9650 +54 0.0000 1.1010 1.4200 +55 0.0000 1.1010 1.5300 +56 0.0000 1.1010 1.4200 +57 0.0000 1.4570 1.5300 +58 0.0000 1.4570 1.1010 +59 0.0000 1.4570 1.4200 +60 0.0000 1.5300 1.4570 +61 0.0000 1.4200 1.5300 +62 0.0000 1.4200 1.4200 +63 0.0000 1.5300 0.9650 +64 0.0000 1.1010 0.9650 +65 0.0000 0.9650 1.5300 +66 0.0000 0.9650 1.1010 -Impropers +AngleTorsion Coeffs -1 1 14 9 10 24 -2 2 9 10 11 36 -3 2 10 11 12 37 -4 3 11 12 13 15 -5 2 12 13 14 38 -6 2 9 14 13 39 -7 3 23 18 19 15 -8 2 18 19 20 46 -9 2 19 20 21 47 -10 1 20 21 22 25 -11 2 21 22 23 48 -12 2 18 23 22 49 -13 1 63 58 59 73 -14 2 58 59 60 85 -15 2 59 60 61 86 -16 3 60 61 62 64 -17 2 61 62 63 87 -18 2 58 63 62 88 -19 3 72 67 68 64 -20 2 67 68 69 95 -21 2 68 69 70 96 -22 1 69 70 71 74 -23 2 70 71 72 97 -24 2 67 72 71 98 -25 4 100 99 105 106 -26 5 101 102 111 112 -27 5 104 103 113 114 -28 6 2 1 26 27 -29 7 2 1 25 26 -30 8 25 1 27 26 -31 7 2 1 25 27 -32 9 1 2 3 7 -33 10 1 2 7 28 -34 11 1 2 3 28 -35 12 3 2 7 28 -36 12 2 3 7 29 -37 12 2 3 7 30 -38 13 2 3 29 30 -39 14 7 3 29 30 -40 12 5 4 8 32 -41 14 8 4 32 31 -42 13 5 4 32 31 -43 12 5 4 8 31 -44 9 6 5 4 8 -45 12 4 5 8 33 -46 11 6 5 4 33 -47 10 6 5 8 33 -48 7 5 6 24 34 -49 7 5 6 24 35 -50 6 5 6 34 35 -51 8 24 6 34 35 -52 15 12 15 16 17 -53 16 12 15 18 16 -54 16 12 15 18 17 -55 15 18 15 17 16 -56 17 15 16 40 41 -57 17 15 16 40 42 -58 17 15 16 41 42 -59 18 40 16 41 42 -60 17 15 17 43 44 -61 17 15 17 43 45 -62 17 15 17 44 45 -63 18 43 17 44 45 -64 6 51 50 75 76 -65 7 51 50 74 75 -66 8 74 50 76 75 -67 7 51 50 74 76 -68 9 50 51 52 56 -69 10 50 51 56 77 -70 11 50 51 52 77 -71 12 52 51 56 77 -72 12 51 52 56 78 -73 12 51 52 56 79 -74 13 51 52 78 79 -75 14 56 52 78 79 -76 12 54 53 57 81 -77 14 57 53 81 80 -78 13 54 53 81 80 -79 12 54 53 57 80 -80 9 55 54 53 57 -81 12 53 54 57 82 -82 11 55 54 53 82 -83 10 55 54 57 82 -84 7 54 55 73 83 -85 7 54 55 73 84 -86 6 54 55 83 84 -87 8 73 55 83 84 -88 15 61 64 65 66 -89 16 61 64 67 65 -90 16 61 64 67 66 -91 15 67 64 66 65 -92 17 64 65 89 90 -93 17 64 65 89 91 -94 17 64 65 90 91 -95 18 89 65 90 91 -96 17 64 66 92 93 -97 17 64 66 92 94 -98 17 64 66 93 94 -99 18 92 66 93 94 -100 19 101 100 107 99 -101 19 101 100 108 99 -102 20 107 100 108 99 -103 21 101 100 107 108 -104 19 100 101 109 102 -105 19 100 101 110 102 -106 21 100 101 109 110 -107 20 109 101 110 102 -108 19 105 104 115 103 -109 19 105 104 116 103 -110 20 115 104 116 103 -111 21 105 104 115 116 -112 19 104 105 117 99 -113 19 104 105 118 99 -114 20 117 105 118 99 -115 21 104 105 117 118 +1 2.3668 2.4920 -1.0122 -0.1892 0.4918 0.7273 110.7700 111.2700 +2 0.3113 0.4516 -0.1988 -0.2454 0.0000 -0.1136 110.7700 112.6700 +3 -0.8085 0.5569 -0.2466 -0.8085 0.5569 -0.2466 110.7700 110.7700 +4 0.5511 0.9737 -0.6673 0.5511 0.9737 -0.6673 111.2700 111.2700 +5 0.9672 -0.7566 -1.2331 0.5623 -0.3041 -0.4015 111.2700 112.6700 +6 -0.1892 0.4918 0.7273 2.3668 2.4920 -1.0122 111.2700 110.7700 +7 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 108.7280 102.9695 +8 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 111.2700 102.9695 +9 -2.7466 1.4877 -0.8955 0.5676 0.9450 0.0703 111.2700 104.5000 +10 -1.8234 1.6393 0.5144 -0.7777 0.4340 -0.6653 108.7280 104.5000 +11 0.5623 -0.3041 -0.4015 0.9672 -0.7566 -1.2331 112.6700 111.2700 +12 -0.2454 0.0000 -0.1136 0.3113 0.4516 -0.1988 112.6700 110.7700 +13 -0.1892 0.4918 0.7273 2.3668 2.4920 -1.0122 111.2700 110.7700 +14 -0.8085 0.5569 -0.2466 -0.8085 0.5569 -0.2466 110.7700 110.7700 +15 1.9767 1.0239 0.0000 1.9767 1.0239 0.0000 118.9000 118.9000 +16 0.0000 2.5014 0.0000 0.0000 2.7147 0.0000 118.9000 117.9400 +17 0.0000 10.0155 0.0000 0.0000 1.7404 0.0000 118.9000 123.4200 +18 0.0000 2.5706 0.0000 0.0000 1.8729 0.0000 123.4200 117.9400 +19 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 123.4200 102.9695 +20 0.0000 2.4501 0.0000 0.0000 2.4501 0.0000 117.9400 117.9400 +21 0.0000 3.8987 0.0000 0.0000 -4.4683 0.0000 118.9000 120.0500 +22 0.0000 -0.1242 0.0000 0.0000 3.4601 0.0000 120.0500 117.9400 +23 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 120.0500 108.4000 +24 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 120.0500 111.0000 +25 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 108.4000 110.7700 +26 -0.2454 0.0000 -0.1136 0.3113 0.4516 -0.1988 112.6700 110.7700 +27 -2.7883 1.5193 1.4796 1.2031 1.3645 -0.7071 111.9100 112.4436 +28 -2.6321 0.9353 -0.8398 -1.3582 0.1465 -0.5729 110.6204 112.4436 +29 -3.3430 4.4558 -0.0346 0.2873 -0.8072 -0.0960 111.9100 110.9538 +30 -3.9582 2.0063 0.3213 -0.4294 -0.4442 -0.6141 110.6204 110.9538 +31 1.3673 0.4528 -2.7700 1.3673 0.4528 -2.7700 111.9100 111.9100 +32 0.5111 1.6328 -1.0155 -1.1075 0.2820 0.8318 110.7700 111.9100 +33 -0.8085 0.5569 -0.2466 -0.8085 0.5569 -0.2466 110.7700 110.7700 +34 0.5623 -0.3041 -0.4015 0.9672 -0.7566 -1.2331 112.6700 111.2700 +35 -0.2454 0.0000 -0.1136 0.3113 0.4516 -0.1988 112.6700 110.7700 +36 0.5511 0.9737 -0.6673 0.5511 0.9737 -0.6673 111.2700 111.2700 +37 -0.1892 0.4918 0.7273 2.3668 2.4920 -1.0122 111.2700 110.7700 +38 2.3668 2.4920 -1.0122 -0.1892 0.4918 0.7273 110.7700 111.2700 +39 -0.8085 0.5569 -0.2466 -0.8085 0.5569 -0.2466 110.7700 110.7700 +40 0.3113 0.4516 -0.1988 -0.2454 0.0000 -0.1136 110.7700 112.6700 +41 -0.8085 0.5569 -0.2466 -0.8085 0.5569 -0.2466 110.7700 110.7700 +42 2.3668 2.4920 -1.0122 -0.1892 0.4918 0.7273 110.7700 111.2700 +43 2.0125 0.9440 -2.7612 -1.9225 -1.3450 0.2210 111.9100 112.6700 +44 -1.1075 0.2820 0.8318 0.5111 1.6328 -1.0155 111.9100 110.7700 +45 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 111.9100 111.2700 +46 -2.7883 1.5193 1.4796 1.2031 1.3645 -0.7071 111.9100 112.4436 +47 -3.3430 4.4558 -0.0346 0.2873 -0.8072 -0.0960 111.9100 110.9538 +48 0.9672 -0.7566 -1.2331 0.5623 -0.3041 -0.4015 111.2700 112.6700 +49 -0.1892 0.4918 0.7273 2.3668 2.4920 -1.0122 111.2700 110.7700 +50 0.5511 0.9737 -0.6673 0.5511 0.9737 -0.6673 111.2700 111.2700 +51 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 111.2700 102.9695 +52 -3.5903 2.5225 0.4888 0.8726 -0.3577 0.3888 111.2700 105.8000 +53 -3.4060 1.6396 0.0737 0.0000 -0.2810 -0.5944 108.7280 105.8000 +54 2.3668 2.4920 -1.0122 -0.1892 0.4918 0.7273 110.7700 111.2700 +55 0.3113 0.4516 -0.1988 -0.2454 0.0000 -0.1136 110.7700 112.6700 +56 2.3668 2.4920 -1.0122 -0.1892 0.4918 0.7273 110.7700 111.2700 +57 2.0125 0.9440 -2.7612 -1.9225 -1.3450 0.2210 111.9100 112.6700 +58 -1.1075 0.2820 0.8318 0.5111 1.6328 -1.0155 111.9100 110.7700 +59 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 111.9100 111.2700 +60 -2.7883 1.5193 1.4796 1.2031 1.3645 -0.7071 111.9100 112.4436 +61 0.9672 -0.7566 -1.2331 0.5623 -0.3041 -0.4015 111.2700 112.6700 +62 0.5511 0.9737 -0.6673 0.5511 0.9737 -0.6673 111.2700 111.2700 +63 -3.5903 2.5225 0.4888 0.8726 -0.3577 0.3888 111.2700 105.8000 +64 -3.4060 1.6396 0.0737 0.0000 -0.2810 -0.5944 108.7280 105.8000 +65 0.8726 -0.3577 0.3888 -3.5903 2.5225 0.4888 105.8000 111.2700 +66 0.0000 -0.2810 -0.5944 -3.4060 1.6396 0.0737 105.8000 108.7280 + +Atoms # full + +1 1 1 0.000000 25.246496201 -1.871744037 -8.651348114 0 0 0 # c2 +2 1 2 0.000000 25.610639572 -3.288228035 -8.165973663 0 0 0 # c3m +3 1 2 0.000000 24.731319427 -4.483242989 -8.675741196 0 0 0 # c3m +4 1 2 0.000000 18.703355789 9.118826866 -4.174236774 0 0 0 # c3m +5 1 2 0.000000 18.099748611 8.263649940 -5.343001842 0 0 0 # c3m +6 1 1 0.000000 19.081827164 7.609607220 -6.334177017 0 0 0 # c2 +7 1 3 0.100000 26.190139771 -4.295329094 -9.220970154 0 0 0 # o3e +8 1 3 0.100000 17.971729279 9.827675819 -5.367077827 0 0 0 # o3e +9 1 4 0.000000 20.263877869 5.733595848 -6.736782074 0 0 0 # cp +10 1 4 0.000000 19.777191162 4.983679771 -7.809411049 0 0 0 # cp +11 1 4 0.000000 20.667026520 4.390971184 -8.707633972 0 0 0 # cp +12 1 4 0.000000 22.043539047 4.548151016 -8.533248901 0 0 0 # cp +13 1 4 0.000000 22.530214310 5.298062801 -7.460619926 0 0 0 # cp +14 1 4 0.000000 21.640394211 5.890783787 -6.562390804 0 0 0 # cp +15 1 5 0.000000 23.005182266 3.906831026 -9.503917694 0 0 0 # c +16 1 6 0.000000 24.286390305 4.758069992 -9.590908051 0 0 0 # c3 +17 1 6 0.000000 22.342786789 3.812531948 -10.891778946 0 0 0 # c3 +18 1 4 0.000000 23.361906052 2.519830942 -9.029184341 0 0 0 # cp +19 1 4 0.000000 24.458705902 2.330889940 -8.185920715 0 0 0 # cp +20 1 4 0.000000 24.788816452 1.047963977 -7.745534897 0 0 0 # cp +21 1 4 0.000000 24.022008896 -0.046867002 -8.149927139 0 0 0 # cp +22 1 4 0.000000 22.925630569 0.140873000 -8.992565155 0 0 0 # cp +23 1 4 0.000000 22.595729828 1.424777985 -9.432847977 0 0 0 # cp +24 1 7 0.000000 19.414030075 6.299984932 -5.878956795 0 0 0 # oc +25 1 7 0.000000 24.338140488 -1.273216963 -7.729548931 0 0 0 # oc +26 1 8 0.000000 26.150024414 -1.266484976 -8.715751648 0 0 0 # hc +27 1 8 0.000000 24.778566360 -1.933199048 -9.633987427 0 0 0 # hc +28 1 8 0.000000 25.929294586 -2.927781105 -7.187973022 0 0 0 # hc +29 1 8 0.000000 24.549385071 -5.308847904 -7.987242222 0 0 0 # hc +30 1 8 0.000000 23.904827118 -4.254271030 -9.348136902 0 0 0 # hc +31 1 8 0.000000 18.194736481 9.091637611 -3.210949898 0 0 0 # hc +32 1 8 0.000000 19.788938522 9.208558083 -4.119643211 0 0 0 # hc +33 1 8 0.000000 17.399309158 7.432216167 -5.407801151 0 0 0 # hc +34 1 8 0.000000 18.616250992 7.545570850 -7.316913128 0 0 0 # hc +35 1 8 0.000000 19.987047195 8.212498665 -6.399401188 0 0 0 # hc +36 1 8 0.000000 18.713207245 4.862418175 -7.944396973 0 0 0 # hc +37 1 8 0.000000 20.290582657 3.811013937 -9.537291527 0 0 0 # hc +38 1 8 0.000000 23.594188690 5.419342995 -7.325634956 0 0 0 # hc +39 1 8 0.000000 22.016828537 6.470753193 -5.732734203 0 0 0 # hc +40 1 8 0.000000 24.982324600 4.297049999 -10.290958405 0 0 0 # hc +41 1 8 0.000000 24.034254074 5.760886192 -9.936174393 0 0 0 # hc +42 1 8 0.000000 24.749143600 4.819462776 -8.606439590 0 0 0 # hc +43 1 8 0.000000 23.034755707 3.349560976 -11.594371796 0 0 0 # hc +44 1 8 0.000000 21.438467026 3.207982063 -10.822364807 0 0 0 # hc +45 1 8 0.000000 22.084871292 4.811752796 -11.239845276 0 0 0 # hc +46 1 8 0.000000 25.050769806 3.177418947 -7.873311996 0 0 0 # hc +47 1 8 0.000000 25.636974335 0.901705027 -7.093626022 0 0 0 # hc +48 1 8 0.000000 22.333581924 -0.705653012 -9.305183411 0 0 0 # hc +49 1 8 0.000000 21.747369766 1.570054054 -10.084861755 0 0 0 # hc +50 1 1 0.000000 25.222612381 -4.200571060 0.463562995 0 0 0 # c2 +51 1 2 0.000000 25.832977295 -5.360119820 -0.347983003 0 0 0 # c3m +52 1 2 0.000000 27.389345169 -5.551681042 -0.290704012 0 0 0 # c3m +53 1 2 0.000000 20.635538101 8.396902084 -1.535487056 0 0 0 # c3m +54 1 2 0.000000 21.957460403 8.158697128 -0.723941982 0 0 0 # c3m +55 1 1 0.000000 22.041673660 6.895174980 0.154822007 0 0 0 # c2 +56 1 3 0.100000 26.447082520 -6.565405846 0.448491007 0 0 0 # o3e +57 1 3 0.100000 20.959102631 9.287891388 -0.285212994 0 0 0 # o3e +58 1 4 0.000000 22.680345535 4.733430862 0.158248007 0 0 0 # cp +59 1 4 0.000000 23.824728012 4.488029957 0.920358002 0 0 0 # cp +60 1 4 0.000000 23.901163101 3.343113899 1.716701984 0 0 0 # cp +61 1 4 0.000000 22.833225250 2.443607092 1.750934958 0 0 0 # cp +62 1 4 0.000000 21.688846588 2.689002037 0.988831997 0 0 0 # cp +63 1 4 0.000000 21.612403870 3.833913088 0.192488998 0 0 0 # cp +64 1 5 0.000000 22.916360855 1.205785036 2.611289978 0 0 0 # c +65 1 6 0.000000 21.501018524 0.810333014 3.075165987 0 0 0 # c3 +66 1 6 0.000000 23.808341980 1.493147969 3.834667921 0 0 0 # c3 +67 1 4 0.000000 23.514062881 0.070205003 1.817157984 0 0 0 # cp +68 1 4 0.000000 22.684833527 -0.782863975 1.085504055 0 0 0 # cp +69 1 4 0.000000 23.237234116 -1.833225965 0.349765003 0 0 0 # cp +70 1 4 0.000000 24.619955063 -2.031138897 0.346872985 0 0 0 # cp +71 1 4 0.000000 25.449554443 -1.179108977 1.077638030 0 0 0 # cp +72 1 4 0.000000 24.896312714 -0.128257006 1.813575983 0 0 0 # cp +73 1 7 0.000000 22.607131958 5.827101231 -0.602173984 0 0 0 # oc +74 1 7 0.000000 25.147769928 -3.035661936 -0.355791986 0 0 0 # oc +75 1 8 0.000000 24.221906662 -4.476489067 0.794990003 0 0 0 # hc +76 1 8 0.000000 25.849754333 -3.994390965 1.331357956 0 0 0 # hc +77 1 8 0.000000 25.097463608 -5.257826805 -1.146129966 0 0 0 # hc +78 1 8 0.000000 27.892013550 -5.893630028 -1.196079969 0 0 0 # hc +79 1 8 0.000000 27.964216232 -4.855231762 0.319745004 0 0 0 # hc +80 1 8 0.000000 20.720872879 8.854673386 -2.520912886 0 0 0 # hc +81 1 8 0.000000 19.840383530 7.656352043 -1.438712001 0 0 0 # hc +82 1 8 0.000000 23.017726898 8.120765686 -0.970986009 0 0 0 # hc +83 1 8 0.000000 22.669095993 7.097908974 1.022259951 0 0 0 # hc +84 1 8 0.000000 21.041725159 6.616360188 0.486577004 0 0 0 # hc +85 1 8 0.000000 24.650087357 5.183434963 0.894133985 0 0 0 # hc +86 1 8 0.000000 24.786277771 3.153367996 2.306194067 0 0 0 # hc +87 1 8 0.000000 20.863473892 1.993592978 1.015051961 0 0 0 # hc +88 1 8 0.000000 20.727291107 4.023673058 -0.397009999 0 0 0 # hc +89 1 8 0.000000 21.558345795 -0.083162002 3.696341038 0 0 0 # hc +90 1 8 0.000000 21.065618515 1.626867056 3.651936054 0 0 0 # hc +91 1 8 0.000000 20.876825333 0.608124971 2.205033064 0 0 0 # hc +92 1 8 0.000000 23.870355606 0.601037025 4.457283974 0 0 0 # hc +93 1 8 0.000000 24.807676315 1.770614982 3.498578072 0 0 0 # hc +94 1 8 0.000000 23.380037308 2.311306953 4.412462234 0 0 0 # hc +95 1 8 0.000000 21.616291046 -0.629218996 1.087699056 0 0 0 # hc +96 1 8 0.000000 22.596149445 -2.493021011 -0.215893999 0 0 0 # hc +97 1 8 0.000000 26.518102646 -1.332759023 1.075448036 0 0 0 # hc +98 1 8 0.000000 25.538236618 0.531040013 2.379035950 0 0 0 # hc +99 1 9 0.000000 16.072591782 12.338866234 -0.174325004 0 0 0 # na +100 1 1 0.000000 16.557256699 11.130316734 0.587288976 0 0 0 # c2 +101 1 1 0.000000 18.074571609 10.998808861 0.366084993 0 0 0 # c2 +102 1 9 -0.025000 18.353967667 10.832372665 -1.107717037 0 0 0 # na +103 1 9 -0.025000 14.920715332 15.017822266 -0.200534001 0 0 0 # na +104 1 1 0.000000 16.390434265 14.791102409 -0.460442007 0 0 0 # c2 +105 1 1 0.000000 16.852983475 13.538317680 0.304865986 0 0 0 # c2 +106 1 10 0.000000 16.263746262 12.190562248 -1.257431984 0 0 0 # hn +107 1 8 0.000000 16.025363922 10.195071220 0.210473999 0 0 0 # hc +108 1 8 0.000000 16.347120285 11.269214630 1.698830962 0 0 0 # hc +109 1 8 0.000000 18.467184067 10.092565536 0.934801996 0 0 0 # hc +110 1 8 0.000000 18.592388153 11.941304207 0.744638979 0 0 0 # hc +111 1 10 0.000000 17.843862534 9.919928551 -1.479779005 0 0 0 # hn +112 1 10 0.000000 19.448190689 10.736482620 -1.267521024 0 0 0 # hn +113 1 10 0.000000 14.344121933 14.136246681 -0.550131977 0 0 0 # hn +114 1 10 0.000000 14.583471298 15.922760963 -0.747138977 0 0 0 # hn +115 1 8 0.000000 16.984062195 15.696007729 -0.102596000 0 0 0 # hc +116 1 8 0.000000 16.562423706 14.639820099 -1.577000022 0 0 0 # hc +117 1 8 0.000000 16.674821854 13.685671806 1.420761943 0 0 0 # hc +118 1 8 0.000000 17.963953018 13.362975121 0.117853999 0 0 0 # hc + +Bonds + +1 1 1 26 +2 2 1 2 +3 1 1 27 +4 3 1 25 +5 4 2 7 +6 5 2 3 +7 6 2 28 +8 4 3 7 +9 6 3 29 +10 6 3 30 +11 6 4 32 +12 4 4 8 +13 5 4 5 +14 6 4 31 +15 4 5 8 +16 2 6 5 +17 6 5 33 +18 3 6 24 +19 1 6 34 +20 1 6 35 +21 7 9 14 +22 7 9 10 +23 8 9 24 +24 7 10 11 +25 9 10 36 +26 7 11 12 +27 9 11 37 +28 7 12 13 +29 10 12 15 +30 7 13 14 +31 9 13 38 +32 9 14 39 +33 11 15 16 +34 11 15 17 +35 10 18 15 +36 12 16 40 +37 12 16 41 +38 12 16 42 +39 12 17 43 +40 12 17 44 +41 12 17 45 +42 7 18 23 +43 7 18 19 +44 7 19 20 +45 9 19 46 +46 7 20 21 +47 9 20 47 +48 7 21 22 +49 8 21 25 +50 7 22 23 +51 9 22 48 +52 9 23 49 +53 1 50 75 +54 2 50 51 +55 1 50 76 +56 3 50 74 +57 4 51 56 +58 5 51 52 +59 6 51 77 +60 4 52 56 +61 6 52 78 +62 6 52 79 +63 6 53 81 +64 4 53 57 +65 5 53 54 +66 6 53 80 +67 4 54 57 +68 2 55 54 +69 6 54 82 +70 3 55 73 +71 1 55 83 +72 1 55 84 +73 7 58 63 +74 7 58 59 +75 8 58 73 +76 7 59 60 +77 9 59 85 +78 7 60 61 +79 9 60 86 +80 7 61 62 +81 10 61 64 +82 7 62 63 +83 9 62 87 +84 9 63 88 +85 11 64 65 +86 11 64 66 +87 10 67 64 +88 12 65 89 +89 12 65 90 +90 12 65 91 +91 12 66 92 +92 12 66 93 +93 12 66 94 +94 7 67 72 +95 7 67 68 +96 7 68 69 +97 9 68 95 +98 7 69 70 +99 9 69 96 +100 7 70 71 +101 8 70 74 +102 7 71 72 +103 9 71 97 +104 9 72 98 +105 13 100 99 +106 13 105 99 +107 14 99 106 +108 15 100 101 +109 1 100 107 +110 1 100 108 +111 13 101 102 +112 1 101 109 +113 1 101 110 +114 14 102 111 +115 14 102 112 +116 13 104 103 +117 14 103 113 +118 14 103 114 +119 15 104 105 +120 1 104 115 +121 1 104 116 +122 1 105 117 +123 1 105 118 + +Angles + +1 1 2 1 26 +2 2 26 1 27 +3 3 25 1 26 +4 1 2 1 27 +5 4 2 1 25 +6 3 25 1 27 +7 5 1 2 7 +8 6 1 2 3 +9 7 1 2 28 +10 8 3 2 7 +11 9 7 2 28 +12 10 3 2 28 +13 8 2 3 7 +14 10 2 3 29 +15 10 2 3 30 +16 9 7 3 29 +17 9 7 3 30 +18 11 29 3 30 +19 9 8 4 32 +20 10 5 4 32 +21 11 32 4 31 +22 8 5 4 8 +23 9 8 4 31 +24 10 5 4 31 +25 8 4 5 8 +26 6 6 5 4 +27 10 4 5 33 +28 5 6 5 8 +29 9 8 5 33 +30 7 6 5 33 +31 4 5 6 24 +32 1 5 6 34 +33 1 5 6 35 +34 3 24 6 34 +35 3 24 6 35 +36 2 34 6 35 +37 12 2 7 3 +38 12 4 8 5 +39 13 14 9 10 +40 14 14 9 24 +41 14 10 9 24 +42 13 9 10 11 +43 15 9 10 36 +44 15 11 10 36 +45 13 10 11 12 +46 15 10 11 37 +47 15 12 11 37 +48 13 11 12 13 +49 16 11 12 15 +50 16 13 12 15 +51 13 12 13 14 +52 15 12 13 38 +53 15 14 13 38 +54 13 9 14 13 +55 15 9 14 39 +56 15 13 14 39 +57 17 12 15 16 +58 17 12 15 17 +59 18 12 15 18 +60 19 16 15 17 +61 17 18 15 16 +62 17 18 15 17 +63 20 15 16 40 +64 20 15 16 41 +65 20 15 16 42 +66 21 40 16 41 +67 21 40 16 42 +68 21 41 16 42 +69 20 15 17 43 +70 20 15 17 44 +71 20 15 17 45 +72 21 43 17 44 +73 21 43 17 45 +74 21 44 17 45 +75 16 23 18 15 +76 16 19 18 15 +77 13 23 18 19 +78 13 18 19 20 +79 15 18 19 46 +80 15 20 19 46 +81 13 19 20 21 +82 15 19 20 47 +83 15 21 20 47 +84 13 20 21 22 +85 14 20 21 25 +86 14 22 21 25 +87 13 21 22 23 +88 15 21 22 48 +89 15 23 22 48 +90 13 18 23 22 +91 15 18 23 49 +92 15 22 23 49 +93 22 6 24 9 +94 22 1 25 21 +95 1 51 50 75 +96 2 75 50 76 +97 3 74 50 75 +98 1 51 50 76 +99 4 51 50 74 +100 3 74 50 76 +101 5 50 51 56 +102 6 50 51 52 +103 7 50 51 77 +104 8 52 51 56 +105 9 56 51 77 +106 10 52 51 77 +107 8 51 52 56 +108 10 51 52 78 +109 10 51 52 79 +110 9 56 52 78 +111 9 56 52 79 +112 11 78 52 79 +113 9 57 53 81 +114 10 54 53 81 +115 11 81 53 80 +116 8 54 53 57 +117 9 57 53 80 +118 10 54 53 80 +119 8 53 54 57 +120 6 55 54 53 +121 10 53 54 82 +122 5 55 54 57 +123 9 57 54 82 +124 7 55 54 82 +125 4 54 55 73 +126 1 54 55 83 +127 1 54 55 84 +128 3 73 55 83 +129 3 73 55 84 +130 2 83 55 84 +131 12 51 56 52 +132 12 53 57 54 +133 13 63 58 59 +134 14 63 58 73 +135 14 59 58 73 +136 13 58 59 60 +137 15 58 59 85 +138 15 60 59 85 +139 13 59 60 61 +140 15 59 60 86 +141 15 61 60 86 +142 13 60 61 62 +143 16 60 61 64 +144 16 62 61 64 +145 13 61 62 63 +146 15 61 62 87 +147 15 63 62 87 +148 13 58 63 62 +149 15 58 63 88 +150 15 62 63 88 +151 17 61 64 65 +152 17 61 64 66 +153 18 61 64 67 +154 19 65 64 66 +155 17 67 64 65 +156 17 67 64 66 +157 20 64 65 89 +158 20 64 65 90 +159 20 64 65 91 +160 21 89 65 90 +161 21 89 65 91 +162 21 90 65 91 +163 20 64 66 92 +164 20 64 66 93 +165 20 64 66 94 +166 21 92 66 93 +167 21 92 66 94 +168 21 93 66 94 +169 16 72 67 64 +170 16 68 67 64 +171 13 72 67 68 +172 13 67 68 69 +173 15 67 68 95 +174 15 69 68 95 +175 13 68 69 70 +176 15 68 69 96 +177 15 70 69 96 +178 13 69 70 71 +179 14 69 70 74 +180 14 71 70 74 +181 13 70 71 72 +182 15 70 71 97 +183 15 72 71 97 +184 13 67 72 71 +185 15 67 72 98 +186 15 71 72 98 +187 22 55 73 58 +188 22 50 74 70 +189 23 100 99 105 +190 24 100 99 106 +191 24 105 99 106 +192 25 101 100 99 +193 26 107 100 99 +194 26 108 100 99 +195 27 101 100 107 +196 27 101 100 108 +197 2 107 100 108 +198 25 100 101 102 +199 27 100 101 109 +200 27 100 101 110 +201 26 109 101 102 +202 26 110 101 102 +203 2 109 101 110 +204 24 101 102 111 +205 24 101 102 112 +206 28 111 102 112 +207 24 104 103 113 +208 24 104 103 114 +209 28 113 103 114 +210 25 105 104 103 +211 26 115 104 103 +212 26 116 104 103 +213 27 105 104 115 +214 27 105 104 116 +215 2 115 104 116 +216 25 104 105 99 +217 26 117 105 99 +218 26 118 105 99 +219 27 104 105 117 +220 27 104 105 118 +221 2 117 105 118 + +Dihedrals + +1 1 26 1 2 7 +2 2 26 1 2 3 +3 3 26 1 2 28 +4 1 27 1 2 7 +5 2 27 1 2 3 +6 3 27 1 2 28 +7 4 25 1 2 7 +8 5 25 1 2 3 +9 6 25 1 2 28 +10 7 26 1 25 21 +11 8 2 1 25 21 +12 7 27 1 25 21 +13 9 1 2 7 3 +14 10 28 2 7 3 +15 11 1 2 3 7 +16 12 1 2 3 29 +17 12 1 2 3 30 +18 13 7 2 3 29 +19 13 7 2 3 30 +20 13 7 3 2 28 +21 14 28 2 3 29 +22 14 28 2 3 30 +23 10 29 3 7 2 +24 10 30 3 7 2 +25 10 32 4 8 5 +26 10 31 4 8 5 +27 13 8 5 4 32 +28 12 6 5 4 32 +29 14 32 4 5 33 +30 11 6 5 4 8 +31 13 8 4 5 33 +32 13 8 5 4 31 +33 12 6 5 4 31 +34 14 31 4 5 33 +35 9 6 5 8 4 +36 10 33 5 8 4 +37 5 24 6 5 4 +38 2 34 6 5 4 +39 2 35 6 5 4 +40 4 24 6 5 8 +41 1 34 6 5 8 +42 1 35 6 5 8 +43 6 24 6 5 33 +44 3 34 6 5 33 +45 3 35 6 5 33 +46 8 5 6 24 9 +47 7 34 6 24 9 +48 7 35 6 24 9 +49 15 10 9 14 13 +50 16 10 9 14 39 +51 17 13 14 9 24 +52 18 24 9 14 39 +53 15 14 9 10 11 +54 16 14 9 10 36 +55 17 11 10 9 24 +56 18 24 9 10 36 +57 19 14 9 24 6 +58 19 10 9 24 6 +59 15 9 10 11 12 +60 16 9 10 11 37 +61 16 12 11 10 36 +62 20 36 10 11 37 +63 15 10 11 12 13 +64 21 10 11 12 15 +65 16 13 12 11 37 +66 22 15 12 11 37 +67 15 11 12 13 14 +68 16 11 12 13 38 +69 21 14 13 12 15 +70 22 15 12 13 38 +71 23 11 12 15 16 +72 23 11 12 15 17 +73 24 11 12 15 18 +74 23 13 12 15 16 +75 23 13 12 15 17 +76 24 13 12 15 18 +77 15 12 13 14 9 +78 16 12 13 14 39 +79 16 9 14 13 38 +80 20 38 13 14 39 +81 25 12 15 16 40 +82 25 12 15 16 41 +83 25 12 15 16 42 +84 26 17 15 16 40 +85 26 17 15 16 41 +86 26 17 15 16 42 +87 25 18 15 16 40 +88 25 18 15 16 41 +89 25 18 15 16 42 +90 25 12 15 17 43 +91 25 12 15 17 44 +92 25 12 15 17 45 +93 26 16 15 17 43 +94 26 16 15 17 44 +95 26 16 15 17 45 +96 25 18 15 17 43 +97 25 18 15 17 44 +98 25 18 15 17 45 +99 24 23 18 15 12 +100 24 19 18 15 12 +101 23 23 18 15 16 +102 23 19 18 15 16 +103 23 23 18 15 17 +104 23 19 18 15 17 +105 21 22 23 18 15 +106 22 15 18 23 49 +107 15 19 18 23 22 +108 16 19 18 23 49 +109 21 20 19 18 15 +110 22 15 18 19 46 +111 15 23 18 19 20 +112 16 23 18 19 46 +113 15 18 19 20 21 +114 16 18 19 20 47 +115 16 21 20 19 46 +116 20 46 19 20 47 +117 15 19 20 21 22 +118 17 19 20 21 25 +119 16 22 21 20 47 +120 18 25 21 20 47 +121 15 20 21 22 23 +122 16 20 21 22 48 +123 17 23 22 21 25 +124 18 25 21 22 48 +125 19 20 21 25 1 +126 19 22 21 25 1 +127 15 21 22 23 18 +128 16 21 22 23 49 +129 16 18 23 22 48 +130 20 48 22 23 49 +131 1 75 50 51 56 +132 2 75 50 51 52 +133 3 75 50 51 77 +134 1 76 50 51 56 +135 2 76 50 51 52 +136 3 76 50 51 77 +137 4 74 50 51 56 +138 5 74 50 51 52 +139 6 74 50 51 77 +140 7 75 50 74 70 +141 8 51 50 74 70 +142 7 76 50 74 70 +143 9 50 51 56 52 +144 10 77 51 56 52 +145 11 50 51 52 56 +146 12 50 51 52 78 +147 12 50 51 52 79 +148 13 56 51 52 78 +149 13 56 51 52 79 +150 13 56 52 51 77 +151 14 77 51 52 78 +152 14 77 51 52 79 +153 10 78 52 56 51 +154 10 79 52 56 51 +155 10 81 53 57 54 +156 10 80 53 57 54 +157 13 57 54 53 81 +158 12 55 54 53 81 +159 14 81 53 54 82 +160 11 55 54 53 57 +161 13 57 53 54 82 +162 13 57 54 53 80 +163 12 55 54 53 80 +164 14 80 53 54 82 +165 9 55 54 57 53 +166 10 82 54 57 53 +167 5 73 55 54 53 +168 2 83 55 54 53 +169 2 84 55 54 53 +170 4 73 55 54 57 +171 1 83 55 54 57 +172 1 84 55 54 57 +173 6 73 55 54 82 +174 3 83 55 54 82 +175 3 84 55 54 82 +176 8 54 55 73 58 +177 7 83 55 73 58 +178 7 84 55 73 58 +179 15 59 58 63 62 +180 16 59 58 63 88 +181 17 62 63 58 73 +182 18 73 58 63 88 +183 15 63 58 59 60 +184 16 63 58 59 85 +185 17 60 59 58 73 +186 18 73 58 59 85 +187 19 63 58 73 55 +188 19 59 58 73 55 +189 15 58 59 60 61 +190 16 58 59 60 86 +191 16 61 60 59 85 +192 20 85 59 60 86 +193 15 59 60 61 62 +194 21 59 60 61 64 +195 16 62 61 60 86 +196 22 64 61 60 86 +197 15 60 61 62 63 +198 16 60 61 62 87 +199 21 63 62 61 64 +200 22 64 61 62 87 +201 23 60 61 64 65 +202 23 60 61 64 66 +203 24 60 61 64 67 +204 23 62 61 64 65 +205 23 62 61 64 66 +206 24 62 61 64 67 +207 15 61 62 63 58 +208 16 61 62 63 88 +209 16 58 63 62 87 +210 20 87 62 63 88 +211 25 61 64 65 89 +212 25 61 64 65 90 +213 25 61 64 65 91 +214 26 66 64 65 89 +215 26 66 64 65 90 +216 26 66 64 65 91 +217 25 67 64 65 89 +218 25 67 64 65 90 +219 25 67 64 65 91 +220 25 61 64 66 92 +221 25 61 64 66 93 +222 25 61 64 66 94 +223 26 65 64 66 92 +224 26 65 64 66 93 +225 26 65 64 66 94 +226 25 67 64 66 92 +227 25 67 64 66 93 +228 25 67 64 66 94 +229 24 72 67 64 61 +230 24 68 67 64 61 +231 23 72 67 64 65 +232 23 68 67 64 65 +233 23 72 67 64 66 +234 23 68 67 64 66 +235 21 71 72 67 64 +236 22 64 67 72 98 +237 15 68 67 72 71 +238 16 68 67 72 98 +239 21 69 68 67 64 +240 22 64 67 68 95 +241 15 72 67 68 69 +242 16 72 67 68 95 +243 15 67 68 69 70 +244 16 67 68 69 96 +245 16 70 69 68 95 +246 20 95 68 69 96 +247 15 68 69 70 71 +248 17 68 69 70 74 +249 16 71 70 69 96 +250 18 74 70 69 96 +251 15 69 70 71 72 +252 16 69 70 71 97 +253 17 72 71 70 74 +254 18 74 70 71 97 +255 19 69 70 74 50 +256 19 71 70 74 50 +257 15 70 71 72 67 +258 16 70 71 72 98 +259 16 67 72 71 97 +260 20 97 71 72 98 +261 27 101 100 99 105 +262 28 107 100 99 105 +263 28 108 100 99 105 +264 29 101 100 99 106 +265 30 107 100 99 106 +266 30 108 100 99 106 +267 27 104 105 99 100 +268 28 117 105 99 100 +269 28 118 105 99 100 +270 29 104 105 99 106 +271 30 117 105 99 106 +272 30 118 105 99 106 +273 31 99 100 101 102 +274 32 109 101 100 99 +275 32 110 101 100 99 +276 32 107 100 101 102 +277 33 107 100 101 109 +278 33 107 100 101 110 +279 32 108 100 101 102 +280 33 108 100 101 109 +281 33 108 100 101 110 +282 29 100 101 102 111 +283 29 100 101 102 112 +284 30 109 101 102 111 +285 30 109 101 102 112 +286 30 110 101 102 111 +287 30 110 101 102 112 +288 29 105 104 103 113 +289 30 115 104 103 113 +290 30 116 104 103 113 +291 29 105 104 103 114 +292 30 115 104 103 114 +293 30 116 104 103 114 +294 31 103 104 105 99 +295 32 117 105 104 103 +296 32 118 105 104 103 +297 32 115 104 105 99 +298 33 115 104 105 117 +299 33 115 104 105 118 +300 32 116 104 105 99 +301 33 116 104 105 117 +302 33 116 104 105 118 + +Impropers + +1 1 14 9 10 24 +2 2 9 10 11 36 +3 2 10 11 12 37 +4 3 11 12 13 15 +5 2 12 13 14 38 +6 2 9 14 13 39 +7 3 23 18 19 15 +8 2 18 19 20 46 +9 2 19 20 21 47 +10 1 20 21 22 25 +11 2 21 22 23 48 +12 2 18 23 22 49 +13 1 63 58 59 73 +14 2 58 59 60 85 +15 2 59 60 61 86 +16 3 60 61 62 64 +17 2 61 62 63 87 +18 2 58 63 62 88 +19 3 72 67 68 64 +20 2 67 68 69 95 +21 2 68 69 70 96 +22 1 69 70 71 74 +23 2 70 71 72 97 +24 2 67 72 71 98 +25 4 100 99 105 106 +26 5 101 102 111 112 +27 5 104 103 113 114 +28 6 2 1 26 27 +29 7 2 1 25 26 +30 8 25 1 27 26 +31 7 2 1 25 27 +32 9 1 2 3 7 +33 10 1 2 7 28 +34 11 1 2 3 28 +35 12 3 2 7 28 +36 12 2 3 7 29 +37 12 2 3 7 30 +38 13 2 3 29 30 +39 14 7 3 29 30 +40 12 5 4 8 32 +41 14 8 4 32 31 +42 13 5 4 32 31 +43 12 5 4 8 31 +44 9 6 5 4 8 +45 12 4 5 8 33 +46 11 6 5 4 33 +47 10 6 5 8 33 +48 7 5 6 24 34 +49 7 5 6 24 35 +50 6 5 6 34 35 +51 8 24 6 34 35 +52 15 12 15 16 17 +53 16 12 15 18 16 +54 16 12 15 18 17 +55 15 18 15 17 16 +56 17 15 16 40 41 +57 17 15 16 40 42 +58 17 15 16 41 42 +59 18 40 16 41 42 +60 17 15 17 43 44 +61 17 15 17 43 45 +62 17 15 17 44 45 +63 18 43 17 44 45 +64 6 51 50 75 76 +65 7 51 50 74 75 +66 8 74 50 76 75 +67 7 51 50 74 76 +68 9 50 51 52 56 +69 10 50 51 56 77 +70 11 50 51 52 77 +71 12 52 51 56 77 +72 12 51 52 56 78 +73 12 51 52 56 79 +74 13 51 52 78 79 +75 14 56 52 78 79 +76 12 54 53 57 81 +77 14 57 53 81 80 +78 13 54 53 81 80 +79 12 54 53 57 80 +80 9 55 54 53 57 +81 12 53 54 57 82 +82 11 55 54 53 82 +83 10 55 54 57 82 +84 7 54 55 73 83 +85 7 54 55 73 84 +86 6 54 55 83 84 +87 8 73 55 83 84 +88 15 61 64 65 66 +89 16 61 64 67 65 +90 16 61 64 67 66 +91 15 67 64 66 65 +92 17 64 65 89 90 +93 17 64 65 89 91 +94 17 64 65 90 91 +95 18 89 65 90 91 +96 17 64 66 92 93 +97 17 64 66 92 94 +98 17 64 66 93 94 +99 18 92 66 93 94 +100 19 101 100 107 99 +101 19 101 100 108 99 +102 20 107 100 108 99 +103 21 101 100 107 108 +104 19 100 101 109 102 +105 19 100 101 110 102 +106 21 100 101 109 110 +107 20 109 101 110 102 +108 19 105 104 115 103 +109 19 105 104 116 103 +110 20 115 104 116 103 +111 21 105 104 115 116 +112 19 104 105 117 99 +113 19 104 105 118 99 +114 20 117 105 118 99 +115 21 104 105 117 118 diff --git a/examples/PACKAGES/reaction/tiny_nylon/in.tiny_nylon.stabilized b/examples/PACKAGES/reaction/tiny_nylon/in.tiny_nylon.stabilized index b152dec00a..81a12b4ccb 100644 --- a/examples/PACKAGES/reaction/tiny_nylon/in.tiny_nylon.stabilized +++ b/examples/PACKAGES/reaction/tiny_nylon/in.tiny_nylon.stabilized @@ -19,14 +19,19 @@ dihedral_style class2 improper_style class2 -read_data tiny_nylon.data +read_data tiny_nylon.data & + extra/bond/per/atom 5 & + extra/angle/per/atom 15 & + extra/dihedral/per/atom 15 & + extra/improper/per/atom 25 & + extra/special/per/atom 25 velocity all create 300.0 4928459 dist gaussian -molecule mol1 rxn1_stp1_unreacted.data_template -molecule mol2 rxn1_stp1_reacted.data_template -molecule mol3 rxn1_stp2_unreacted.data_template -molecule mol4 rxn1_stp2_reacted.data_template +molecule mol1 rxn1_stp1_unreacted.molecule_template +molecule mol2 rxn1_stp1_reacted.molecule_template +molecule mol3 rxn1_stp2_unreacted.molecule_template +molecule mol4 rxn1_stp2_reacted.molecule_template thermo 50 diff --git a/examples/PACKAGES/reaction/tiny_nylon/in.tiny_nylon.stabilized_variable_probability b/examples/PACKAGES/reaction/tiny_nylon/in.tiny_nylon.stabilized_variable_probability index e81fedc34a..515d4cb2f8 100644 --- a/examples/PACKAGES/reaction/tiny_nylon/in.tiny_nylon.stabilized_variable_probability +++ b/examples/PACKAGES/reaction/tiny_nylon/in.tiny_nylon.stabilized_variable_probability @@ -19,7 +19,12 @@ dihedral_style class2 improper_style class2 -read_data tiny_nylon.data +read_data tiny_nylon.data & + extra/bond/per/atom 5 & + extra/angle/per/atom 15 & + extra/dihedral/per/atom 15 & + extra/improper/per/atom 25 & + extra/special/per/atom 25 variable runsteps equal 1000 variable prob1 equal step/v_runsteps*2+0.1 @@ -27,10 +32,10 @@ variable prob2 equal (step/v_runsteps)>0.5 velocity all create 300.0 4928459 dist gaussian -molecule mol1 rxn1_stp1_unreacted.data_template -molecule mol2 rxn1_stp1_reacted.data_template -molecule mol3 rxn1_stp2_unreacted.data_template -molecule mol4 rxn1_stp2_reacted.data_template +molecule mol1 rxn1_stp1_unreacted.molecule_template +molecule mol2 rxn1_stp1_reacted.molecule_template +molecule mol3 rxn1_stp2_unreacted.molecule_template +molecule mol4 rxn1_stp2_reacted.molecule_template thermo 50 diff --git a/examples/PACKAGES/reaction/tiny_nylon/in.tiny_nylon.unstabilized b/examples/PACKAGES/reaction/tiny_nylon/in.tiny_nylon.unstabilized index 1e5a493821..4891e9ebff 100644 --- a/examples/PACKAGES/reaction/tiny_nylon/in.tiny_nylon.unstabilized +++ b/examples/PACKAGES/reaction/tiny_nylon/in.tiny_nylon.unstabilized @@ -19,14 +19,20 @@ dihedral_style class2 improper_style class2 -read_data tiny_nylon.data +read_data tiny_nylon.data & + extra/bond/per/atom 5 & + extra/angle/per/atom 15 & + extra/dihedral/per/atom 15 & + extra/improper/per/atom 25 & + extra/special/per/atom 25 + velocity all create 300.0 4928459 dist gaussian -molecule mol1 rxn1_stp1_unreacted.data_template -molecule mol2 rxn1_stp1_reacted.data_template -molecule mol3 rxn1_stp2_unreacted.data_template -molecule mol4 rxn1_stp2_reacted.data_template +molecule mol1 rxn1_stp1_unreacted.molecule_template +molecule mol2 rxn1_stp1_reacted.molecule_template +molecule mol3 rxn1_stp2_unreacted.molecule_template +molecule mol4 rxn1_stp2_reacted.molecule_template thermo 50 diff --git a/examples/PACKAGES/reaction/tiny_nylon/log.22Apr20.tiny_nylon.stabilized_variable_probability.g++.1 b/examples/PACKAGES/reaction/tiny_nylon/log.22Apr20.tiny_nylon.stabilized_variable_probability.g++.1 deleted file mode 100644 index 57455b04f4..0000000000 --- a/examples/PACKAGES/reaction/tiny_nylon/log.22Apr20.tiny_nylon.stabilized_variable_probability.g++.1 +++ /dev/null @@ -1,201 +0,0 @@ -LAMMPS (15 Apr 2020) -OMP_NUM_THREADS environment is not set. Defaulting to 1 thread. (src/comm.cpp:94) - using 1 OpenMP thread(s) per MPI task -# two monomer nylon example -# reaction produces a condensed water molecule - -units real - -boundary p p p - -atom_style full - -kspace_style pppm 1.0e-4 - -pair_style lj/class2/coul/long 8.5 - -angle_style class2 - -bond_style class2 - -dihedral_style class2 - -improper_style class2 - -read_data tiny_nylon.data - orthogonal box = (-25 -25 -25) to (25 25 25) - 1 by 1 by 1 MPI processor grid - reading atoms ... - 44 atoms - reading velocities ... - 44 velocities - scanning bonds ... - 9 = max bonds/atom - scanning angles ... - 21 = max angles/atom - scanning dihedrals ... - 29 = max dihedrals/atom - scanning impropers ... - 29 = max impropers/atom - reading bonds ... - 42 bonds - reading angles ... - 74 angles - reading dihedrals ... - 100 dihedrals - reading impropers ... - 44 impropers - 4 = max # of 1-2 neighbors - 6 = max # of 1-3 neighbors - 12 = max # of 1-4 neighbors - 41 = max # of special neighbors - special bonds CPU = 0.000385045 secs - read_data CPU = 0.013443 secs - -variable runsteps equal 1000 -variable prob1 equal step/v_runsteps*2 -variable prob2 equal (step/v_runsteps)>0.5 - -velocity all create 300.0 4928459 dist gaussian - -molecule mol1 rxn1_stp1_unreacted.data_template -Read molecule template mol1: - 1 molecules - 18 atoms with max type 8 - 16 bonds with max type 14 - 25 angles with max type 28 - 23 dihedrals with max type 36 - 14 impropers with max type 11 -molecule mol2 rxn1_stp1_reacted.data_template -Read molecule template mol2: - 1 molecules - 18 atoms with max type 9 - 17 bonds with max type 13 - 31 angles with max type 27 - 39 dihedrals with max type 33 - 20 impropers with max type 1 -molecule mol3 rxn1_stp2_unreacted.data_template -Read molecule template mol3: - 1 molecules - 15 atoms with max type 9 - 14 bonds with max type 13 - 25 angles with max type 27 - 30 dihedrals with max type 33 - 16 impropers with max type 1 -molecule mol4 rxn1_stp2_reacted.data_template -Read molecule template mol4: - 1 molecules - 15 atoms with max type 11 - 13 bonds with max type 15 - 19 angles with max type 29 - 16 dihedrals with max type 32 - 10 impropers with max type 13 - -thermo 50 - -# dump 1 all xyz 1 test_vis.xyz - -fix myrxns all bond/react stabilization yes statted_grp .03 react rxn1 all 1 0.0 5.0 mol1 mol2 rxn1_stp1_map prob v_prob1 1234 react rxn2 all 1 0.0 5.0 mol3 mol4 rxn1_stp2_map prob v_prob2 1234 -WARNING: Bond/react: Atom affected by reaction rxn1 too close to template edge (src/REACTION/fix_bond_react.cpp:2051) -WARNING: Bond/react: Atom affected by reaction rxn2 too close to template edge (src/REACTION/fix_bond_react.cpp:2051) -dynamic group bond_react_MASTER_group defined -dynamic group statted_grp_REACT defined - -fix 1 statted_grp_REACT nvt temp 300 300 100 - -# optionally, you can customize behavior of reacting atoms, -# by using the internally-created 'bond_react_MASTER_group', like so: -fix 4 bond_react_MASTER_group temp/rescale 1 300 300 10 1 - -thermo_style custom step temp press density v_prob1 v_prob2 f_myrxns[1] f_myrxns[2] - -# restart 100 restart1 restart2 - -run ${runsteps} -run 1000 -PPPM initialization ... - using 12-bit tables for long-range coulomb (src/kspace.cpp:332) - G vector (1/distance) = 0.0534597 - grid = 2 2 2 - stencil order = 5 - estimated absolute RMS force accuracy = 0.0402256 - estimated relative force accuracy = 0.000121138 - using double precision FFTW3 - 3d grid and FFT values/proc = 343 8 -Neighbor list info ... - update every 1 steps, delay 10 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 = 10 10 10 - 2 neighbor lists, perpetual/occasional/extra = 1 1 0 - (1) pair lj/class2/coul/long, perpetual - attributes: half, newton on - pair build: half/bin/newton - stencil: half/bin/3d/newton - bin: standard - (2) fix bond/react, occasional, copy from (1) - attributes: half, newton on - pair build: copy - stencil: none - bin: none -WARNING: Inconsistent image flags (src/domain.cpp:812) -Per MPI rank memory allocation (min/avg/max) = 33.78 | 33.78 | 33.78 Mbytes -Step Temp Press Density v_prob1 v_prob2 f_myrxns[1] f_myrxns[2] - 0 300 346.78165 0.0034851739 0 0 0 0 - 50 262.63913 -492.10749 0.0034851739 0.1 0 1 0 - 100 766.52962 -29.714349 0.0034851739 0.2 0 1 0 - 150 503.86837 50.220304 0.0034851739 0.3 0 1 0 - 200 456.51295 12.312892 0.0034851739 0.4 0 1 0 - 250 391.54928 9.2335844 0.0034851739 0.5 0 1 0 - 300 336.6988 -47.193937 0.0034851739 0.6 0 1 0 - 350 254.06985 -9.2867898 0.0034851739 0.7 0 1 0 - 400 259.41098 -25.657321 0.0034851739 0.8 0 1 0 - 450 258.10364 22.5086 0.0034851739 0.9 0 1 0 - 500 272.13412 -6.5391448 0.0034851739 1 0 1 0 - 550 202.75504 54.658731 0.0034851739 1.1 1 1 1 - 600 344.79887 23.798478 0.0034851739 1.2 1 1 1 - 650 328.44488 -29.908484 0.0034851739 1.3 1 1 1 - 700 280.13593 -8.3223255 0.0034851739 1.4 1 1 1 - 750 300.67624 1.0632669 0.0034851739 1.5 1 1 1 - 800 376.64234 12.488392 0.0034851739 1.6 1 1 1 - 850 321.07642 19.814074 0.0034851739 1.7 1 1 1 - 900 332.23751 30.814079 0.0034851739 1.8 1 1 1 - 950 311.14029 5.7853136 0.0034851739 1.9 1 1 1 - 1000 253.14634 -37.560642 0.0034851739 2 1 1 1 -Loop time of 0.379454 on 1 procs for 1000 steps with 44 atoms - -Performance: 227.696 ns/day, 0.105 hours/ns, 2635.368 timesteps/s -99.6% CPU use with 1 MPI tasks x 1 OpenMP threads - -MPI task timing breakdown: -Section | min time | avg time | max time |%varavg| %total ---------------------------------------------------------------- -Pair | 0.069723 | 0.069723 | 0.069723 | 0.0 | 18.37 -Bond | 0.14802 | 0.14802 | 0.14802 | 0.0 | 39.01 -Kspace | 0.044252 | 0.044252 | 0.044252 | 0.0 | 11.66 -Neigh | 0.072359 | 0.072359 | 0.072359 | 0.0 | 19.07 -Comm | 0.0044748 | 0.0044748 | 0.0044748 | 0.0 | 1.18 -Output | 0.0022775 | 0.0022775 | 0.0022775 | 0.0 | 0.60 -Modify | 0.036509 | 0.036509 | 0.036509 | 0.0 | 9.62 -Other | | 0.00184 | | | 0.48 - -Nlocal: 44 ave 44 max 44 min -Histogram: 1 0 0 0 0 0 0 0 0 0 -Nghost: 3 ave 3 max 3 min -Histogram: 1 0 0 0 0 0 0 0 0 0 -Neighs: 722 ave 722 max 722 min -Histogram: 1 0 0 0 0 0 0 0 0 0 - -Total # of neighbors = 722 -Ave neighs/atom = 16.4091 -Ave special neighs/atom = 9.77273 -Neighbor list builds = 1000 -Dangerous builds = 0 - -# write_restart restart_longrun -# write_data restart_longrun.data - -Please see the log.cite file for references relevant to this simulation - -Total wall time: 0:00:00 diff --git a/examples/PACKAGES/reaction/tiny_nylon/log.22Apr20.tiny_nylon.stabilized_variable_probability.g++.4 b/examples/PACKAGES/reaction/tiny_nylon/log.22Apr20.tiny_nylon.stabilized_variable_probability.g++.4 deleted file mode 100644 index b6dcdafc54..0000000000 --- a/examples/PACKAGES/reaction/tiny_nylon/log.22Apr20.tiny_nylon.stabilized_variable_probability.g++.4 +++ /dev/null @@ -1,201 +0,0 @@ -LAMMPS (15 Apr 2020) -OMP_NUM_THREADS environment is not set. Defaulting to 1 thread. (src/comm.cpp:94) - using 1 OpenMP thread(s) per MPI task -# two monomer nylon example -# reaction produces a condensed water molecule - -units real - -boundary p p p - -atom_style full - -kspace_style pppm 1.0e-4 - -pair_style lj/class2/coul/long 8.5 - -angle_style class2 - -bond_style class2 - -dihedral_style class2 - -improper_style class2 - -read_data tiny_nylon.data - orthogonal box = (-25 -25 -25) to (25 25 25) - 1 by 2 by 2 MPI processor grid - reading atoms ... - 44 atoms - reading velocities ... - 44 velocities - scanning bonds ... - 9 = max bonds/atom - scanning angles ... - 21 = max angles/atom - scanning dihedrals ... - 29 = max dihedrals/atom - scanning impropers ... - 29 = max impropers/atom - reading bonds ... - 42 bonds - reading angles ... - 74 angles - reading dihedrals ... - 100 dihedrals - reading impropers ... - 44 impropers - 4 = max # of 1-2 neighbors - 6 = max # of 1-3 neighbors - 12 = max # of 1-4 neighbors - 41 = max # of special neighbors - special bonds CPU = 0.000431282 secs - read_data CPU = 0.0129571 secs - -variable runsteps equal 1000 -variable prob1 equal step/v_runsteps*2 -variable prob2 equal (step/v_runsteps)>0.5 - -velocity all create 300.0 4928459 dist gaussian - -molecule mol1 rxn1_stp1_unreacted.data_template -Read molecule template mol1: - 1 molecules - 18 atoms with max type 8 - 16 bonds with max type 14 - 25 angles with max type 28 - 23 dihedrals with max type 36 - 14 impropers with max type 11 -molecule mol2 rxn1_stp1_reacted.data_template -Read molecule template mol2: - 1 molecules - 18 atoms with max type 9 - 17 bonds with max type 13 - 31 angles with max type 27 - 39 dihedrals with max type 33 - 20 impropers with max type 1 -molecule mol3 rxn1_stp2_unreacted.data_template -Read molecule template mol3: - 1 molecules - 15 atoms with max type 9 - 14 bonds with max type 13 - 25 angles with max type 27 - 30 dihedrals with max type 33 - 16 impropers with max type 1 -molecule mol4 rxn1_stp2_reacted.data_template -Read molecule template mol4: - 1 molecules - 15 atoms with max type 11 - 13 bonds with max type 15 - 19 angles with max type 29 - 16 dihedrals with max type 32 - 10 impropers with max type 13 - -thermo 50 - -# dump 1 all xyz 1 test_vis.xyz - -fix myrxns all bond/react stabilization yes statted_grp .03 react rxn1 all 1 0.0 5.0 mol1 mol2 rxn1_stp1_map prob v_prob1 1234 react rxn2 all 1 0.0 5.0 mol3 mol4 rxn1_stp2_map prob v_prob2 1234 -WARNING: Bond/react: Atom affected by reaction rxn1 too close to template edge (src/REACTION/fix_bond_react.cpp:2051) -WARNING: Bond/react: Atom affected by reaction rxn2 too close to template edge (src/REACTION/fix_bond_react.cpp:2051) -dynamic group bond_react_MASTER_group defined -dynamic group statted_grp_REACT defined - -fix 1 statted_grp_REACT nvt temp 300 300 100 - -# optionally, you can customize behavior of reacting atoms, -# by using the internally-created 'bond_react_MASTER_group', like so: -fix 4 bond_react_MASTER_group temp/rescale 1 300 300 10 1 - -thermo_style custom step temp press density v_prob1 v_prob2 f_myrxns[1] f_myrxns[2] - -# restart 100 restart1 restart2 - -run ${runsteps} -run 1000 -PPPM initialization ... - using 12-bit tables for long-range coulomb (src/kspace.cpp:332) - G vector (1/distance) = 0.0534597 - grid = 2 2 2 - stencil order = 5 - estimated absolute RMS force accuracy = 0.0402256 - estimated relative force accuracy = 0.000121138 - using double precision FFTW3 - 3d grid and FFT values/proc = 252 2 -Neighbor list info ... - update every 1 steps, delay 10 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 = 10 10 10 - 2 neighbor lists, perpetual/occasional/extra = 1 1 0 - (1) pair lj/class2/coul/long, perpetual - attributes: half, newton on - pair build: half/bin/newton - stencil: half/bin/3d/newton - bin: standard - (2) fix bond/react, occasional, copy from (1) - attributes: half, newton on - pair build: copy - stencil: none - bin: none -WARNING: Inconsistent image flags (src/domain.cpp:812) -Per MPI rank memory allocation (min/avg/max) = 33.66 | 33.88 | 34.43 Mbytes -Step Temp Press Density v_prob1 v_prob2 f_myrxns[1] f_myrxns[2] - 0 300 346.78165 0.0034851739 0 0 0 0 - 50 266.5092 -90.813802 0.0034851739 0.1 0 1 0 - 100 559.41271 -53.23688 0.0034851739 0.2 0 1 0 - 150 489.90516 31.555817 0.0034851739 0.3 0 1 0 - 200 326.18391 7.7889992 0.0034851739 0.4 0 1 0 - 250 339.78203 2.3919541 0.0034851739 0.5 0 1 0 - 300 370.90263 -32.01673 0.0034851739 0.6 0 1 0 - 350 294.07547 -5.4019813 0.0034851739 0.7 0 1 0 - 400 287.76477 12.254133 0.0034851739 0.8 0 1 0 - 450 293.36482 66.372956 0.0034851739 0.9 0 1 0 - 500 246.84496 26.132317 0.0034851739 1 0 1 0 - 550 253.08778 -15.350262 0.0034851739 1.1 1 1 1 - 600 358.83641 25.007371 0.0034851739 1.2 1 1 1 - 650 320.51492 -32.34823 0.0034851739 1.3 1 1 1 - 700 310.87976 -8.2306669 0.0034851739 1.4 1 1 1 - 750 307.54142 12.025818 0.0034851739 1.5 1 1 1 - 800 272.51724 -22.92823 0.0034851739 1.6 1 1 1 - 850 268.66181 10.069534 0.0034851739 1.7 1 1 1 - 900 265.5531 -10.471377 0.0034851739 1.8 1 1 1 - 950 259.43086 9.4546712 0.0034851739 1.9 1 1 1 - 1000 247.14622 20.250308 0.0034851739 2 1 1 1 -Loop time of 0.357762 on 4 procs for 1000 steps with 44 atoms - -Performance: 241.502 ns/day, 0.099 hours/ns, 2795.157 timesteps/s -99.0% CPU use with 4 MPI tasks x 1 OpenMP threads - -MPI task timing breakdown: -Section | min time | avg time | max time |%varavg| %total ---------------------------------------------------------------- -Pair | 0.0003917 | 0.015545 | 0.033317 | 11.9 | 4.35 -Bond | 0.0010131 | 0.030153 | 0.076975 | 18.2 | 8.43 -Kspace | 0.092857 | 0.1462 | 0.18688 | 10.7 | 40.87 -Neigh | 0.043786 | 0.044014 | 0.044189 | 0.1 | 12.30 -Comm | 0.03636 | 0.038345 | 0.040538 | 0.8 | 10.72 -Output | 0.00091578 | 0.0012541 | 0.0020923 | 1.4 | 0.35 -Modify | 0.075379 | 0.080791 | 0.086052 | 1.8 | 22.58 -Other | | 0.00146 | | | 0.41 - -Nlocal: 11 ave 32 max 0 min -Histogram: 2 0 1 0 0 0 0 0 0 1 -Nghost: 40 ave 51 max 19 min -Histogram: 1 0 0 0 0 0 0 1 0 2 -Neighs: 191 ave 529 max 0 min -Histogram: 2 0 0 0 1 0 0 0 0 1 - -Total # of neighbors = 764 -Ave neighs/atom = 17.3636 -Ave special neighs/atom = 9.77273 -Neighbor list builds = 1000 -Dangerous builds = 0 - -# write_restart restart_longrun -# write_data restart_longrun.data - -Please see the log.cite file for references relevant to this simulation - -Total wall time: 0:00:00 diff --git a/examples/PACKAGES/reaction/tiny_nylon/log.4Nov2020.tiny_nylon.stabilized.g++.1 b/examples/PACKAGES/reaction/tiny_nylon/log.4Nov2020.tiny_nylon.stabilized.g++.1 new file mode 100644 index 0000000000..9a2d240ca4 --- /dev/null +++ b/examples/PACKAGES/reaction/tiny_nylon/log.4Nov2020.tiny_nylon.stabilized.g++.1 @@ -0,0 +1,412 @@ +LAMMPS (4 Nov 2022) +# two monomer nylon example +# reaction produces a condensed water molecule + +units real + +boundary p p p + +atom_style full + +kspace_style pppm 1.0e-4 + +pair_style lj/class2/coul/long 8.5 + +angle_style class2 + +bond_style class2 + +dihedral_style class2 + +improper_style class2 + +read_data tiny_nylon.data extra/bond/per/atom 5 extra/angle/per/atom 15 extra/dihedral/per/atom 15 extra/improper/per/atom 25 extra/special/per/atom 25 +Reading data file ... + orthogonal box = (-25 -25 -25) to (25 25 25) + 1 by 1 by 1 MPI processor grid + reading atom labelmap ... + reading bond labelmap ... + reading angle labelmap ... + reading dihedral labelmap ... + reading improper labelmap ... + reading atoms ... + 44 atoms + reading velocities ... + 44 velocities + scanning bonds ... + 9 = max bonds/atom + scanning angles ... + 21 = max angles/atom + scanning dihedrals ... + 29 = max dihedrals/atom + scanning impropers ... + 29 = max impropers/atom + reading bonds ... + 42 bonds + reading angles ... + 74 angles + reading dihedrals ... + 100 dihedrals + reading impropers ... + 44 impropers +Finding 1-2 1-3 1-4 neighbors ... + special bond factors lj: 0 0 0 + special bond factors coul: 0 0 0 + 4 = max # of 1-2 neighbors + 6 = max # of 1-3 neighbors + 12 = max # of 1-4 neighbors + 41 = max # of special neighbors + special bonds CPU = 0.000 seconds + read_data CPU = 0.007 seconds + +velocity all create 300.0 4928459 dist gaussian + +molecule mol1 rxn1_stp1_unreacted.molecule_template +Read molecule template mol1: + 1 molecules + 0 fragments + 18 atoms with max type 8 + 16 bonds with max type 10 + 25 angles with max type 28 + 23 dihedrals with max type 36 + 2 impropers with max type 3 +molecule mol2 rxn1_stp1_reacted.molecule_template +Read molecule template mol2: + 1 molecules + 0 fragments + 18 atoms with max type 9 + 17 bonds with max type 13 + 31 angles with max type 27 + 39 dihedrals with max type 33 + 0 impropers with max type 0 +molecule mol3 rxn1_stp2_unreacted.molecule_template +Read molecule template mol3: + 1 molecules + 0 fragments + 15 atoms with max type 9 + 14 bonds with max type 13 + 25 angles with max type 27 + 30 dihedrals with max type 33 + 0 impropers with max type 0 +molecule mol4 rxn1_stp2_reacted.molecule_template +Read molecule template mol4: + 1 molecules + 0 fragments + 15 atoms with max type 11 + 13 bonds with max type 15 + 19 angles with max type 29 + 16 dihedrals with max type 32 + 2 impropers with max type 13 + +thermo 50 + +# dump 1 all xyz 1 test_vis.xyz + +fix myrxns all bond/react stabilization yes statted_grp .03 react rxn1 all 1 0.0 2.9 mol1 mol2 rxn1_stp1_map react rxn2 all 1 0.0 5.0 mol3 mol4 rxn1_stp2_map +WARNING: Fix bond/react: Atom affected by reaction rxn2 is too close to template edge (../fix_bond_react.cpp:2624) +dynamic group bond_react_MASTER_group defined +dynamic group statted_grp_REACT defined + +fix 1 statted_grp_REACT nvt temp 300 300 100 + +# optionally, you can customize behavior of reacting atoms, +# by using the internally-created 'bond_react_MASTER_group', like so: +fix 4 bond_react_MASTER_group temp/rescale 1 300 300 10 1 + +thermo_style custom step temp press density f_myrxns[1] f_myrxns[2] + +# restart 100 restart1 restart2 + +run 10000 + +CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE + +Your simulation uses code contributions which should be cited: + +- fix bond/react: reacter.org doi:10.1016/j.polymer.2017.09.038, doi:10.1021/acs.macromol.0c02012 + +@Article{Gissinger17, + author = {J. R. Gissinger and B. D. Jensen and K. E. Wise}, + title = {Modeling Chemical Reactions in Classical Molecular Dynamics Simulations}, + journal = {Polymer}, + year = 2017, + volume = 128, + pages = {211--217} +} + +@Article{Gissinger20, + author = {J. R. Gissinger, B. D. Jensen, K. E. Wise}, + title = {{REACTER}: A Heuristic Method for Reactive Molecular Dynamics}, + journal = {Macromolecules}, + year = 2020, + volume = 53, + number = 22, + pages = {9953--9961} +} + +CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE + +PPPM initialization ... + using 12-bit tables for long-range coulomb (../kspace.cpp:342) + G vector (1/distance) = 0.05345967 + grid = 2 2 2 + stencil order = 5 + estimated absolute RMS force accuracy = 0.040225597 + estimated relative force accuracy = 0.00012113819 + using double precision KISS FFT + 3d grid and FFT values/proc = 343 8 +Generated 55 of 55 mixed pair_coeff terms from sixthpower/geometric mixing rule +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 = 10 10 10 + 2 neighbor lists, perpetual/occasional/extra = 1 1 0 + (1) pair lj/class2/coul/long, perpetual + attributes: half, newton on + pair build: half/bin/newton + stencil: half/bin/3d + bin: standard + (2) fix bond/react, occasional, copy from (1) + attributes: half, newton on + pair build: copy + stencil: none + bin: none +WARNING: Inconsistent image flags (../domain.cpp:819) +Per MPI rank memory allocation (min/avg/max) = 33.78 | 33.78 | 33.78 Mbytes + Step Temp Press Density f_myrxns[1] f_myrxns[2] + 0 300 346.78165 0.0034851739 0 0 + 50 283.51963 -47.16359 0.0034851739 1 0 + 100 256.04648 21.778898 0.0034851739 1 1 + 150 450.78138 -11.7887 0.0034851739 1 1 + 200 400.15754 49.489858 0.0034851739 1 1 + 250 347.06066 68.952063 0.0034851739 1 1 + 300 291.89228 -1.5986302 0.0034851739 1 1 + 350 290.25995 17.634558 0.0034851739 1 1 + 400 234.89168 26.36452 0.0034851739 1 1 + 450 305.80709 -28.923896 0.0034851739 1 1 + 500 375.19218 -37.024375 0.0034851739 1 1 + 550 321.86944 -4.6961825 0.0034851739 1 1 + 600 307.2639 -31.393161 0.0034851739 1 1 + 650 255.95833 8.4995589 0.0034851739 1 1 + 700 294.54665 -17.06105 0.0034851739 1 1 + 750 273.08231 -10.7175 0.0034851739 1 1 + 800 249.69175 9.9777683 0.0034851739 1 1 + 850 307.71806 -6.9950048 0.0034851739 1 1 + 900 367.39855 9.9874985 0.0034851739 1 1 + 950 327.57334 -4.7029779 0.0034851739 1 1 + 1000 348.85247 15.763492 0.0034851739 1 1 + 1050 328.94435 -35.031279 0.0034851739 1 1 + 1100 283.23971 -16.937443 0.0034851739 1 1 + 1150 266.69676 42.308482 0.0034851739 1 1 + 1200 244.61493 -8.291143 0.0034851739 1 1 + 1250 206.68495 6.6280168 0.0034851739 1 1 + 1300 257.83339 -7.0826267 0.0034851739 1 1 + 1350 358.0875 -7.6024741 0.0034851739 1 1 + 1400 353.66614 18.091914 0.0034851739 1 1 + 1450 302.27969 13.828755 0.0034851739 1 1 + 1500 262.57851 9.256794 0.0034851739 1 1 + 1550 252.39493 1.2438641 0.0034851739 1 1 + 1600 247.18352 10.008173 0.0034851739 1 1 + 1650 290.30112 -2.1829035 0.0034851739 1 1 + 1700 272.78999 -57.305766 0.0034851739 1 1 + 1750 253.35258 24.729795 0.0034851739 1 1 + 1800 278.67831 -0.95016566 0.0034851739 1 1 + 1850 302.04743 16.002867 0.0034851739 1 1 + 1900 330.67188 -22.034206 0.0034851739 1 1 + 1950 342.64206 8.0076017 0.0034851739 1 1 + 2000 348.74388 -12.159887 0.0034851739 1 1 + 2050 300.48093 36.01054 0.0034851739 1 1 + 2100 275.01699 8.7612261 0.0034851739 1 1 + 2150 303.92758 10.317056 0.0034851739 1 1 + 2200 308.89457 33.245018 0.0034851739 1 1 + 2250 265.74177 35.857118 0.0034851739 1 1 + 2300 273.40088 53.001593 0.0034851739 1 1 + 2350 287.74746 -0.14590128 0.0034851739 1 1 + 2400 278.76055 -8.2080851 0.0034851739 1 1 + 2450 331.88978 39.025208 0.0034851739 1 1 + 2500 280.04045 -21.423616 0.0034851739 1 1 + 2550 388.81531 -12.350023 0.0034851739 1 1 + 2600 311.13452 -13.287102 0.0034851739 1 1 + 2650 325.07681 88.710878 0.0034851739 1 1 + 2700 319.08502 14.118057 0.0034851739 1 1 + 2750 261.72066 26.051675 0.0034851739 1 1 + 2800 281.03508 -21.200833 0.0034851739 1 1 + 2850 312.27359 4.3892078 0.0034851739 1 1 + 2900 274.81147 -12.738114 0.0034851739 1 1 + 2950 281.76969 11.198451 0.0034851739 1 1 + 3000 291.83918 48.595884 0.0034851739 1 1 + 3050 297.40189 -24.91102 0.0034851739 1 1 + 3100 341.47331 13.82699 0.0034851739 1 1 + 3150 347.51825 -10.458257 0.0034851739 1 1 + 3200 301.24666 26.550464 0.0034851739 1 1 + 3250 281.3679 -23.02985 0.0034851739 1 1 + 3300 279.8332 -53.222264 0.0034851739 1 1 + 3350 289.41496 -8.793156 0.0034851739 1 1 + 3400 288.5722 -25.441134 0.0034851739 1 1 + 3450 259.59524 77.884773 0.0034851739 1 1 + 3500 296.00389 30.3654 0.0034851739 1 1 + 3550 302.14443 -5.1101538 0.0034851739 1 1 + 3600 288.98098 -12.688781 0.0034851739 1 1 + 3650 333.83238 -33.121195 0.0034851739 1 1 + 3700 347.7556 -24.693995 0.0034851739 1 1 + 3750 354.42689 6.7030374 0.0034851739 1 1 + 3800 341.24011 -18.775449 0.0034851739 1 1 + 3850 320.50998 35.492418 0.0034851739 1 1 + 3900 326.81918 -49.073015 0.0034851739 1 1 + 3950 299.55145 -19.487946 0.0034851739 1 1 + 4000 308.81019 30.579971 0.0034851739 1 1 + 4050 251.83279 -17.500379 0.0034851739 1 1 + 4100 242.0783 21.228088 0.0034851739 1 1 + 4150 265.59921 -3.9446469 0.0034851739 1 1 + 4200 369.32464 -14.626205 0.0034851739 1 1 + 4250 346.22904 -32.749662 0.0034851739 1 1 + 4300 369.43175 11.916047 0.0034851739 1 1 + 4350 321.17007 -9.3009147 0.0034851739 1 1 + 4400 312.41821 -31.360537 0.0034851739 1 1 + 4450 281.59211 40.338618 0.0034851739 1 1 + 4500 289.10806 -4.2135222 0.0034851739 1 1 + 4550 317.55705 -4.3727576 0.0034851739 1 1 + 4600 310.64469 -14.403478 0.0034851739 1 1 + 4650 284.43433 37.416848 0.0034851739 1 1 + 4700 353.88469 7.7633789 0.0034851739 1 1 + 4750 328.48834 -60.780145 0.0034851739 1 1 + 4800 390.23986 4.2691385 0.0034851739 1 1 + 4850 364.06188 40.18245 0.0034851739 1 1 + 4900 304.64696 6.3557092 0.0034851739 1 1 + 4950 309.12139 -16.598924 0.0034851739 1 1 + 5000 311.03552 14.748037 0.0034851739 1 1 + 5050 320.97847 -26.733755 0.0034851739 1 1 + 5100 275.1237 -29.734972 0.0034851739 1 1 + 5150 287.76954 -2.5726321 0.0034851739 1 1 + 5200 267.72493 -6.6677739 0.0034851739 1 1 + 5250 290.63862 29.209807 0.0034851739 1 1 + 5300 276.51052 -19.746615 0.0034851739 1 1 + 5350 255.69196 25.130356 0.0034851739 1 1 + 5400 313.43108 -18.556701 0.0034851739 1 1 + 5450 327.91785 -16.08265 0.0034851739 1 1 + 5500 342.03301 33.271603 0.0034851739 1 1 + 5550 272.96564 -5.0247163 0.0034851739 1 1 + 5600 315.93807 -16.793394 0.0034851739 1 1 + 5650 294.66353 19.720691 0.0034851739 1 1 + 5700 283.4631 -6.5193772 0.0034851739 1 1 + 5750 261.06436 12.755679 0.0034851739 1 1 + 5800 274.15767 -9.6693117 0.0034851739 1 1 + 5850 271.1371 18.441828 0.0034851739 1 1 + 5900 283.39277 -4.6324708 0.0034851739 1 1 + 5950 326.30497 12.106133 0.0034851739 1 1 + 6000 316.91847 -32.864812 0.0034851739 1 1 + 6050 344.86369 21.226768 0.0034851739 1 1 + 6100 295.85211 -7.3603837 0.0034851739 1 1 + 6150 256.72292 4.6010174 0.0034851739 1 1 + 6200 248.33379 -20.795929 0.0034851739 1 1 + 6250 259.4054 63.590928 0.0034851739 1 1 + 6300 264.16648 2.6570242 0.0034851739 1 1 + 6350 243.22677 -18.621317 0.0034851739 1 1 + 6400 269.96092 53.832036 0.0034851739 1 1 + 6450 252.06358 -26.231052 0.0034851739 1 1 + 6500 275.4825 25.577441 0.0034851739 1 1 + 6550 298.27441 11.17373 0.0034851739 1 1 + 6600 297.29358 -21.382334 0.0034851739 1 1 + 6650 334.78542 38.892678 0.0034851739 1 1 + 6700 299.48699 -20.336163 0.0034851739 1 1 + 6750 315.01936 21.000444 0.0034851739 1 1 + 6800 244.68344 -6.3625659 0.0034851739 1 1 + 6850 251.56543 27.857872 0.0034851739 1 1 + 6900 280.81518 -12.494398 0.0034851739 1 1 + 6950 273.87437 -34.211085 0.0034851739 1 1 + 7000 274.91068 33.483158 0.0034851739 1 1 + 7050 298.56432 -61.821668 0.0034851739 1 1 + 7100 299.08395 10.365875 0.0034851739 1 1 + 7150 317.38233 29.049831 0.0034851739 1 1 + 7200 317.24932 -27.515026 0.0034851739 1 1 + 7250 305.63931 12.732123 0.0034851739 1 1 + 7300 309.44007 -53.922033 0.0034851739 1 1 + 7350 280.35029 45.495031 0.0034851739 1 1 + 7400 228.60929 1.7072084 0.0034851739 1 1 + 7450 276.206 -19.170327 0.0034851739 1 1 + 7500 257.9851 77.105642 0.0034851739 1 1 + 7550 306.46848 -29.189265 0.0034851739 1 1 + 7600 296.84522 -20.83365 0.0034851739 1 1 + 7650 296.5965 -14.890206 0.0034851739 1 1 + 7700 322.80474 44.883023 0.0034851739 1 1 + 7750 293.7355 -48.487658 0.0034851739 1 1 + 7800 358.41838 13.156339 0.0034851739 1 1 + 7850 293.81457 -19.50566 0.0034851739 1 1 + 7900 309.49618 -28.562417 0.0034851739 1 1 + 7950 285.6339 -22.488886 0.0034851739 1 1 + 8000 262.85312 57.125049 0.0034851739 1 1 + 8050 243.28673 -28.082125 0.0034851739 1 1 + 8100 279.71604 10.011975 0.0034851739 1 1 + 8150 344.77027 -56.89744 0.0034851739 1 1 + 8200 366.36063 21.02453 0.0034851739 1 1 + 8250 347.07209 2.7752885 0.0034851739 1 1 + 8300 337.74753 -10.957676 0.0034851739 1 1 + 8350 300.41188 -22.840776 0.0034851739 1 1 + 8400 282.27447 0.32063982 0.0034851739 1 1 + 8450 285.40722 -3.7167264 0.0034851739 1 1 + 8500 321.32722 -21.308158 0.0034851739 1 1 + 8550 293.65903 15.681219 0.0034851739 1 1 + 8600 293.38929 37.727045 0.0034851739 1 1 + 8650 299.55185 -15.004573 0.0034851739 1 1 + 8700 270.7608 14.615287 0.0034851739 1 1 + 8750 306.46813 67.018302 0.0034851739 1 1 + 8800 308.35025 -91.212286 0.0034851739 1 1 + 8850 349.40419 31.906004 0.0034851739 1 1 + 8900 351.32706 -24.901778 0.0034851739 1 1 + 8950 320.84369 18.380221 0.0034851739 1 1 + 9000 289.2862 9.981138 0.0034851739 1 1 + 9050 270.53883 12.028672 0.0034851739 1 1 + 9100 270.63206 -0.87842772 0.0034851739 1 1 + 9150 274.30671 -4.1228725 0.0034851739 1 1 + 9200 343.78546 20.427647 0.0034851739 1 1 + 9250 348.1019 13.339075 0.0034851739 1 1 + 9300 345.11791 -32.515359 0.0034851739 1 1 + 9350 329.8365 12.644587 0.0034851739 1 1 + 9400 286.41337 -28.79111 0.0034851739 1 1 + 9450 321.92318 32.154255 0.0034851739 1 1 + 9500 302.68527 -42.576022 0.0034851739 1 1 + 9550 335.24034 26.675219 0.0034851739 1 1 + 9600 270.62012 17.230138 0.0034851739 1 1 + 9650 273.71088 35.651219 0.0034851739 1 1 + 9700 286.2141 -26.15835 0.0034851739 1 1 + 9750 262.25352 -4.1954047 0.0034851739 1 1 + 9800 314.29455 23.252049 0.0034851739 1 1 + 9850 273.71272 -29.586039 0.0034851739 1 1 + 9900 300.63743 42.595289 0.0034851739 1 1 + 9950 367.68979 -64.582508 0.0034851739 1 1 + 10000 357.17941 31.607766 0.0034851739 1 1 +Loop time of 1.82433 on 1 procs for 10000 steps with 44 atoms + +Performance: 473.599 ns/day, 0.051 hours/ns, 5481.467 timesteps/s, 241.185 katom-step/s +99.8% CPU use with 1 MPI tasks x no OpenMP threads + +MPI task timing breakdown: +Section | min time | avg time | max time |%varavg| %total +--------------------------------------------------------------- +Pair | 0.25039 | 0.25039 | 0.25039 | 0.0 | 13.72 +Bond | 1.0461 | 1.0461 | 1.0461 | 0.0 | 57.34 +Kspace | 0.34339 | 0.34339 | 0.34339 | 0.0 | 18.82 +Neigh | 0.0097352 | 0.0097352 | 0.0097352 | 0.0 | 0.53 +Comm | 0.0047764 | 0.0047764 | 0.0047764 | 0.0 | 0.26 +Output | 0.0030537 | 0.0030537 | 0.0030537 | 0.0 | 0.17 +Modify | 0.15534 | 0.15534 | 0.15534 | 0.0 | 8.51 +Other | | 0.01155 | | | 0.63 + +Nlocal: 44 ave 44 max 44 min +Histogram: 1 0 0 0 0 0 0 0 0 0 +Nghost: 44 ave 44 max 44 min +Histogram: 1 0 0 0 0 0 0 0 0 0 +Neighs: 823 ave 823 max 823 min +Histogram: 1 0 0 0 0 0 0 0 0 0 + +Total # of neighbors = 823 +Ave neighs/atom = 18.704545 +Ave special neighs/atom = 9.9090909 +Neighbor list builds = 221 +Dangerous builds = 0 + +# write_restart restart_longrun +# write_data restart_longrun.data +Total wall time: 0:00:01 diff --git a/examples/PACKAGES/reaction/tiny_nylon/log.4Nov2020.tiny_nylon.stabilized.g++.4 b/examples/PACKAGES/reaction/tiny_nylon/log.4Nov2020.tiny_nylon.stabilized.g++.4 new file mode 100644 index 0000000000..0a30cd6984 --- /dev/null +++ b/examples/PACKAGES/reaction/tiny_nylon/log.4Nov2020.tiny_nylon.stabilized.g++.4 @@ -0,0 +1,412 @@ +LAMMPS (4 Nov 2022) +# two monomer nylon example +# reaction produces a condensed water molecule + +units real + +boundary p p p + +atom_style full + +kspace_style pppm 1.0e-4 + +pair_style lj/class2/coul/long 8.5 + +angle_style class2 + +bond_style class2 + +dihedral_style class2 + +improper_style class2 + +read_data tiny_nylon.data extra/bond/per/atom 5 extra/angle/per/atom 15 extra/dihedral/per/atom 15 extra/improper/per/atom 25 extra/special/per/atom 25 +Reading data file ... + orthogonal box = (-25 -25 -25) to (25 25 25) + 1 by 2 by 2 MPI processor grid + reading atom labelmap ... + reading bond labelmap ... + reading angle labelmap ... + reading dihedral labelmap ... + reading improper labelmap ... + reading atoms ... + 44 atoms + reading velocities ... + 44 velocities + scanning bonds ... + 9 = max bonds/atom + scanning angles ... + 21 = max angles/atom + scanning dihedrals ... + 29 = max dihedrals/atom + scanning impropers ... + 29 = max impropers/atom + reading bonds ... + 42 bonds + reading angles ... + 74 angles + reading dihedrals ... + 100 dihedrals + reading impropers ... + 44 impropers +Finding 1-2 1-3 1-4 neighbors ... + special bond factors lj: 0 0 0 + special bond factors coul: 0 0 0 + 4 = max # of 1-2 neighbors + 6 = max # of 1-3 neighbors + 12 = max # of 1-4 neighbors + 41 = max # of special neighbors + special bonds CPU = 0.000 seconds + read_data CPU = 0.008 seconds + +velocity all create 300.0 4928459 dist gaussian + +molecule mol1 rxn1_stp1_unreacted.molecule_template +Read molecule template mol1: + 1 molecules + 0 fragments + 18 atoms with max type 8 + 16 bonds with max type 10 + 25 angles with max type 28 + 23 dihedrals with max type 36 + 2 impropers with max type 3 +molecule mol2 rxn1_stp1_reacted.molecule_template +Read molecule template mol2: + 1 molecules + 0 fragments + 18 atoms with max type 9 + 17 bonds with max type 13 + 31 angles with max type 27 + 39 dihedrals with max type 33 + 0 impropers with max type 0 +molecule mol3 rxn1_stp2_unreacted.molecule_template +Read molecule template mol3: + 1 molecules + 0 fragments + 15 atoms with max type 9 + 14 bonds with max type 13 + 25 angles with max type 27 + 30 dihedrals with max type 33 + 0 impropers with max type 0 +molecule mol4 rxn1_stp2_reacted.molecule_template +Read molecule template mol4: + 1 molecules + 0 fragments + 15 atoms with max type 11 + 13 bonds with max type 15 + 19 angles with max type 29 + 16 dihedrals with max type 32 + 2 impropers with max type 13 + +thermo 50 + +# dump 1 all xyz 1 test_vis.xyz + +fix myrxns all bond/react stabilization yes statted_grp .03 react rxn1 all 1 0.0 2.9 mol1 mol2 rxn1_stp1_map react rxn2 all 1 0.0 5.0 mol3 mol4 rxn1_stp2_map +WARNING: Fix bond/react: Atom affected by reaction rxn2 is too close to template edge (../fix_bond_react.cpp:2624) +dynamic group bond_react_MASTER_group defined +dynamic group statted_grp_REACT defined + +fix 1 statted_grp_REACT nvt temp 300 300 100 + +# optionally, you can customize behavior of reacting atoms, +# by using the internally-created 'bond_react_MASTER_group', like so: +fix 4 bond_react_MASTER_group temp/rescale 1 300 300 10 1 + +thermo_style custom step temp press density f_myrxns[1] f_myrxns[2] + +# restart 100 restart1 restart2 + +run 10000 + +CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE + +Your simulation uses code contributions which should be cited: + +- fix bond/react: reacter.org doi:10.1016/j.polymer.2017.09.038, doi:10.1021/acs.macromol.0c02012 + +@Article{Gissinger17, + author = {J. R. Gissinger and B. D. Jensen and K. E. Wise}, + title = {Modeling Chemical Reactions in Classical Molecular Dynamics Simulations}, + journal = {Polymer}, + year = 2017, + volume = 128, + pages = {211--217} +} + +@Article{Gissinger20, + author = {J. R. Gissinger, B. D. Jensen, K. E. Wise}, + title = {{REACTER}: A Heuristic Method for Reactive Molecular Dynamics}, + journal = {Macromolecules}, + year = 2020, + volume = 53, + number = 22, + pages = {9953--9961} +} + +CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE + +PPPM initialization ... + using 12-bit tables for long-range coulomb (../kspace.cpp:342) + G vector (1/distance) = 0.05345967 + grid = 2 2 2 + stencil order = 5 + estimated absolute RMS force accuracy = 0.040225597 + estimated relative force accuracy = 0.00012113819 + using double precision KISS FFT + 3d grid and FFT values/proc = 252 2 +Generated 55 of 55 mixed pair_coeff terms from sixthpower/geometric mixing rule +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 = 10 10 10 + 2 neighbor lists, perpetual/occasional/extra = 1 1 0 + (1) pair lj/class2/coul/long, perpetual + attributes: half, newton on + pair build: half/bin/newton + stencil: half/bin/3d + bin: standard + (2) fix bond/react, occasional, copy from (1) + attributes: half, newton on + pair build: copy + stencil: none + bin: none +WARNING: Inconsistent image flags (../domain.cpp:819) +Per MPI rank memory allocation (min/avg/max) = 33.66 | 33.88 | 34.43 Mbytes + Step Temp Press Density f_myrxns[1] f_myrxns[2] + 0 300 346.78165 0.0034851739 0 0 + 50 283.51963 -47.16359 0.0034851739 1 0 + 100 256.04648 21.778898 0.0034851739 1 1 + 150 450.78138 -11.7887 0.0034851739 1 1 + 200 400.15754 49.489858 0.0034851739 1 1 + 250 347.06066 68.952063 0.0034851739 1 1 + 300 291.89228 -1.5986302 0.0034851739 1 1 + 350 290.25995 17.634558 0.0034851739 1 1 + 400 234.89168 26.36452 0.0034851739 1 1 + 450 305.80709 -28.923896 0.0034851739 1 1 + 500 375.19218 -37.024375 0.0034851739 1 1 + 550 321.86944 -4.6961825 0.0034851739 1 1 + 600 307.2639 -31.393161 0.0034851739 1 1 + 650 255.95833 8.4995589 0.0034851739 1 1 + 700 294.54665 -17.06105 0.0034851739 1 1 + 750 273.08231 -10.7175 0.0034851739 1 1 + 800 249.69175 9.9777684 0.0034851739 1 1 + 850 307.71806 -6.9950047 0.0034851739 1 1 + 900 367.39855 9.9874984 0.0034851739 1 1 + 950 327.57334 -4.702978 0.0034851739 1 1 + 1000 348.85247 15.763492 0.0034851739 1 1 + 1050 328.94435 -35.031279 0.0034851739 1 1 + 1100 283.23971 -16.937443 0.0034851739 1 1 + 1150 266.69676 42.308482 0.0034851739 1 1 + 1200 244.61493 -8.2911432 0.0034851739 1 1 + 1250 206.68495 6.6280166 0.0034851739 1 1 + 1300 257.83339 -7.0826264 0.0034851739 1 1 + 1350 358.0875 -7.602474 0.0034851739 1 1 + 1400 353.66614 18.091914 0.0034851739 1 1 + 1450 302.27969 13.828755 0.0034851739 1 1 + 1500 262.57851 9.2567956 0.0034851739 1 1 + 1550 252.39492 1.2438631 0.0034851739 1 1 + 1600 247.18352 10.008173 0.0034851739 1 1 + 1650 290.30112 -2.1829055 0.0034851739 1 1 + 1700 272.78999 -57.305766 0.0034851739 1 1 + 1750 253.35258 24.729797 0.0034851739 1 1 + 1800 278.67832 -0.95017071 0.0034851739 1 1 + 1850 302.04743 16.002872 0.0034851739 1 1 + 1900 330.67188 -22.034206 0.0034851739 1 1 + 1950 342.64206 8.0075967 0.0034851739 1 1 + 2000 348.74388 -12.159899 0.0034851739 1 1 + 2050 300.48095 36.010534 0.0034851739 1 1 + 2100 275.017 8.7612294 0.0034851739 1 1 + 2150 303.92758 10.317032 0.0034851739 1 1 + 2200 308.89452 33.245012 0.0034851739 1 1 + 2250 265.74176 35.857111 0.0034851739 1 1 + 2300 273.40086 53.001626 0.0034851739 1 1 + 2350 287.74753 -0.14586562 0.0034851739 1 1 + 2400 278.7606 -8.20812 0.0034851739 1 1 + 2450 331.88979 39.02519 0.0034851739 1 1 + 2500 280.04041 -21.423589 0.0034851739 1 1 + 2550 388.81536 -12.350053 0.0034851739 1 1 + 2600 311.13468 -13.286785 0.0034851739 1 1 + 2650 325.07686 88.710881 0.0034851739 1 1 + 2700 319.08471 14.118288 0.0034851739 1 1 + 2750 261.72067 26.051439 0.0034851739 1 1 + 2800 281.03459 -21.201297 0.0034851739 1 1 + 2850 312.27342 4.3904047 0.0034851739 1 1 + 2900 274.81152 -12.739138 0.0034851739 1 1 + 2950 281.76873 11.199981 0.0034851739 1 1 + 3000 291.8377 48.595661 0.0034851739 1 1 + 3050 297.40212 -24.911752 0.0034851739 1 1 + 3100 341.48252 13.825136 0.0034851739 1 1 + 3150 347.5099 -10.452847 0.0034851739 1 1 + 3200 301.24901 26.553909 0.0034851739 1 1 + 3250 281.35392 -23.028031 0.0034851739 1 1 + 3300 279.82881 -53.225332 0.0034851739 1 1 + 3350 289.41016 -8.7866567 0.0034851739 1 1 + 3400 288.56923 -25.445059 0.0034851739 1 1 + 3450 259.59956 77.88466 0.0034851739 1 1 + 3500 295.99591 30.357393 0.0034851739 1 1 + 3550 302.1675 -5.103997 0.0034851739 1 1 + 3600 289.00244 -12.687621 0.0034851739 1 1 + 3650 333.89968 -33.124064 0.0034851739 1 1 + 3700 347.82328 -24.745583 0.0034851739 1 1 + 3750 354.51391 6.7131611 0.0034851739 1 1 + 3800 341.31124 -18.777474 0.0034851739 1 1 + 3850 320.48132 35.547595 0.0034851739 1 1 + 3900 326.8911 -49.153151 0.0034851739 1 1 + 3950 299.65543 -19.443322 0.0034851739 1 1 + 4000 308.97943 30.368402 0.0034851739 1 1 + 4050 251.46183 -17.518988 0.0034851739 1 1 + 4100 241.50223 22.103347 0.0034851739 1 1 + 4150 265.01178 -4.4952098 0.0034851739 1 1 + 4200 369.78569 -14.603579 0.0034851739 1 1 + 4250 348.20071 -33.060693 0.0034851739 1 1 + 4300 368.11836 11.897676 0.0034851739 1 1 + 4350 321.1145 -9.3124104 0.0034851739 1 1 + 4400 313.95395 -31.940883 0.0034851739 1 1 + 4450 280.50985 41.398853 0.0034851739 1 1 + 4500 289.36914 -2.3915112 0.0034851739 1 1 + 4550 318.52735 -5.0086703 0.0034851739 1 1 + 4600 308.68169 -13.642004 0.0034851739 1 1 + 4650 285.24153 35.314806 0.0034851739 1 1 + 4700 357.15021 8.8271927 0.0034851739 1 1 + 4750 359.11051 -59.672314 0.0034851739 1 1 + 4800 453.11584 0.54316266 0.0034851739 1 1 + 4850 392.52232 46.350736 0.0034851739 1 1 + 4900 310.42864 5.9002223 0.0034851739 1 1 + 4950 285.97355 -19.321724 0.0034851739 1 1 + 5000 309.41828 18.331381 0.0034851739 1 1 + 5050 324.96434 -27.143631 0.0034851739 1 1 + 5100 266.49422 -26.977074 0.0034851739 1 1 + 5150 295.35576 -14.271299 0.0034851739 1 1 + 5200 275.8961 14.057873 0.0034851739 1 1 + 5250 332.75955 26.04747 0.0034851739 1 1 + 5300 296.57102 -20.904181 0.0034851739 1 1 + 5350 264.68808 29.533914 0.0034851739 1 1 + 5400 293.373 -13.579532 0.0034851739 1 1 + 5450 290.55933 9.3458628 0.0034851739 1 1 + 5500 340.54834 8.8308229 0.0034851739 1 1 + 5550 336.08713 -6.9696582 0.0034851739 1 1 + 5600 331.77668 -7.9756709 0.0034851739 1 1 + 5650 307.8419 -10.263349 0.0034851739 1 1 + 5700 262.70119 78.855544 0.0034851739 1 1 + 5750 285.37985 -15.4042 0.0034851739 1 1 + 5800 267.44612 -30.053955 0.0034851739 1 1 + 5850 241.52125 3.2904907 0.0034851739 1 1 + 5900 265.13367 27.69901 0.0034851739 1 1 + 5950 277.95155 18.419031 0.0034851739 1 1 + 6000 309.62777 -20.054029 0.0034851739 1 1 + 6050 363.41588 16.435337 0.0034851739 1 1 + 6100 348.85793 -14.513241 0.0034851739 1 1 + 6150 323.73745 56.990265 0.0034851739 1 1 + 6200 338.66823 -19.93498 0.0034851739 1 1 + 6250 325.41329 -13.824943 0.0034851739 1 1 + 6300 279.82345 -9.0557197 0.0034851739 1 1 + 6350 285.90705 52.434161 0.0034851739 1 1 + 6400 260.34102 -15.766595 0.0034851739 1 1 + 6450 304.65686 7.5058044 0.0034851739 1 1 + 6500 265.02097 1.7203356 0.0034851739 1 1 + 6550 293.35057 1.8896974 0.0034851739 1 1 + 6600 284.06837 -9.3674953 0.0034851739 1 1 + 6650 307.29863 -2.3882614 0.0034851739 1 1 + 6700 336.20676 43.913926 0.0034851739 1 1 + 6750 291.53938 -16.749433 0.0034851739 1 1 + 6800 298.4418 -13.340335 0.0034851739 1 1 + 6850 264.13368 -11.219357 0.0034851739 1 1 + 6900 273.63109 -15.897238 0.0034851739 1 1 + 6950 282.64715 6.8275423 0.0034851739 1 1 + 7000 277.4091 -25.381099 0.0034851739 1 1 + 7050 278.07001 63.552969 0.0034851739 1 1 + 7100 293.33358 22.103462 0.0034851739 1 1 + 7150 308.36447 -27.212203 0.0034851739 1 1 + 7200 251.45077 -40.385347 0.0034851739 1 1 + 7250 317.57808 1.0302048 0.0034851739 1 1 + 7300 348.52627 48.392457 0.0034851739 1 1 + 7350 356.5821 27.933626 0.0034851739 1 1 + 7400 311.29835 -18.899768 0.0034851739 1 1 + 7450 274.24476 -19.41577 0.0034851739 1 1 + 7500 261.38075 1.2110527 0.0034851739 1 1 + 7550 299.78907 -17.64954 0.0034851739 1 1 + 7600 271.36191 25.99439 0.0034851739 1 1 + 7650 287.51241 1.532789 0.0034851739 1 1 + 7700 280.87778 -31.828432 0.0034851739 1 1 + 7750 312.22588 45.320976 0.0034851739 1 1 + 7800 312.73849 4.1022573 0.0034851739 1 1 + 7850 299.18742 50.272069 0.0034851739 1 1 + 7900 312.4916 -34.425195 0.0034851739 1 1 + 7950 284.5205 15.716375 0.0034851739 1 1 + 8000 248.39764 -7.1922339 0.0034851739 1 1 + 8050 242.65659 -32.701773 0.0034851739 1 1 + 8100 228.76112 54.351 0.0034851739 1 1 + 8150 308.67672 -15.835344 0.0034851739 1 1 + 8200 304.26746 -11.106867 0.0034851739 1 1 + 8250 338.67601 44.199636 0.0034851739 1 1 + 8300 308.59612 -9.6487546 0.0034851739 1 1 + 8350 287.08027 11.036122 0.0034851739 1 1 + 8400 319.79578 -78.918735 0.0034851739 1 1 + 8450 320.78978 57.275745 0.0034851739 1 1 + 8500 282.90803 33.716746 0.0034851739 1 1 + 8550 235.23686 -44.587941 0.0034851739 1 1 + 8600 265.62925 45.976855 0.0034851739 1 1 + 8650 260.35429 -9.3951434 0.0034851739 1 1 + 8700 236.16314 19.504695 0.0034851739 1 1 + 8750 291.51087 -13.996885 0.0034851739 1 1 + 8800 357.00246 -26.674845 0.0034851739 1 1 + 8850 327.72543 15.954838 0.0034851739 1 1 + 8900 321.17809 -14.794959 0.0034851739 1 1 + 8950 357.51102 39.861567 0.0034851739 1 1 + 9000 286.68385 -52.799636 0.0034851739 1 1 + 9050 283.96224 13.044025 0.0034851739 1 1 + 9100 304.04431 25.510777 0.0034851739 1 1 + 9150 261.33631 -18.611794 0.0034851739 1 1 + 9200 297.50501 25.733551 0.0034851739 1 1 + 9250 279.85018 -26.91045 0.0034851739 1 1 + 9300 336.07358 35.385228 0.0034851739 1 1 + 9350 326.27961 -36.941794 0.0034851739 1 1 + 9400 400.42857 7.5301492 0.0034851739 1 1 + 9450 296.80174 11.898673 0.0034851739 1 1 + 9500 275.98796 41.303486 0.0034851739 1 1 + 9550 278.56924 31.033397 0.0034851739 1 1 + 9600 260.24476 -11.416595 0.0034851739 1 1 + 9650 281.86065 12.60709 0.0034851739 1 1 + 9700 287.26789 -29.086626 0.0034851739 1 1 + 9750 290.82789 3.2830325 0.0034851739 1 1 + 9800 270.99421 -25.824595 0.0034851739 1 1 + 9850 385.1884 4.1048816 0.0034851739 1 1 + 9900 363.1711 18.815879 0.0034851739 1 1 + 9950 344.93572 17.375158 0.0034851739 1 1 + 10000 335.65852 -0.84087429 0.0034851739 1 1 +Loop time of 1.78856 on 4 procs for 10000 steps with 44 atoms + +Performance: 483.070 ns/day, 0.050 hours/ns, 5591.087 timesteps/s, 246.008 katom-step/s +100.0% CPU use with 4 MPI tasks x no OpenMP threads + +MPI task timing breakdown: +Section | min time | avg time | max time |%varavg| %total +--------------------------------------------------------------- +Pair | 0.0021174 | 0.066025 | 0.20024 | 31.5 | 3.69 +Bond | 0.0035593 | 0.2715 | 0.74757 | 58.6 | 15.18 +Kspace | 0.50386 | 1.0492 | 1.3455 | 33.6 | 58.66 +Neigh | 0.0079056 | 0.0079463 | 0.0079766 | 0.0 | 0.44 +Comm | 0.044284 | 0.08173 | 0.10388 | 8.1 | 4.57 +Output | 0.0021661 | 0.0024497 | 0.0031314 | 0.8 | 0.14 +Modify | 0.2648 | 0.29459 | 0.33479 | 5.5 | 16.47 +Other | | 0.01514 | | | 0.85 + +Nlocal: 11 ave 41 max 0 min +Histogram: 3 0 0 0 0 0 0 0 0 1 +Nghost: 27.5 ave 41 max 0 min +Histogram: 1 0 0 0 0 0 0 0 2 1 +Neighs: 205.75 ave 820 max 0 min +Histogram: 3 0 0 0 0 0 0 0 0 1 + +Total # of neighbors = 823 +Ave neighs/atom = 18.704545 +Ave special neighs/atom = 9.9090909 +Neighbor list builds = 225 +Dangerous builds = 0 + +# write_restart restart_longrun +# write_data restart_longrun.data +Total wall time: 0:00:01 diff --git a/examples/PACKAGES/reaction/tiny_nylon/log.4Nov2020.tiny_nylon.stabilized_variable_probability.g++.1 b/examples/PACKAGES/reaction/tiny_nylon/log.4Nov2020.tiny_nylon.stabilized_variable_probability.g++.1 new file mode 100644 index 0000000000..ec822e8b3b --- /dev/null +++ b/examples/PACKAGES/reaction/tiny_nylon/log.4Nov2020.tiny_nylon.stabilized_variable_probability.g++.1 @@ -0,0 +1,237 @@ +LAMMPS (4 Nov 2022) +# two monomer nylon example +# reaction produces a condensed water molecule + +units real + +boundary p p p + +atom_style full + +kspace_style pppm 1.0e-4 + +pair_style lj/class2/coul/long 8.5 + +angle_style class2 + +bond_style class2 + +dihedral_style class2 + +improper_style class2 + +read_data tiny_nylon.data extra/bond/per/atom 5 extra/angle/per/atom 15 extra/dihedral/per/atom 15 extra/improper/per/atom 25 extra/special/per/atom 25 +Reading data file ... + orthogonal box = (-25 -25 -25) to (25 25 25) + 1 by 1 by 1 MPI processor grid + reading atom labelmap ... + reading bond labelmap ... + reading angle labelmap ... + reading dihedral labelmap ... + reading improper labelmap ... + reading atoms ... + 44 atoms + reading velocities ... + 44 velocities + scanning bonds ... + 9 = max bonds/atom + scanning angles ... + 21 = max angles/atom + scanning dihedrals ... + 29 = max dihedrals/atom + scanning impropers ... + 29 = max impropers/atom + reading bonds ... + 42 bonds + reading angles ... + 74 angles + reading dihedrals ... + 100 dihedrals + reading impropers ... + 44 impropers +Finding 1-2 1-3 1-4 neighbors ... + special bond factors lj: 0 0 0 + special bond factors coul: 0 0 0 + 4 = max # of 1-2 neighbors + 6 = max # of 1-3 neighbors + 12 = max # of 1-4 neighbors + 41 = max # of special neighbors + special bonds CPU = 0.000 seconds + read_data CPU = 0.007 seconds + +variable runsteps equal 1000 +variable prob1 equal step/v_runsteps*2+0.1 +variable prob2 equal (step/v_runsteps)>0.5 + +velocity all create 300.0 4928459 dist gaussian + +molecule mol1 rxn1_stp1_unreacted.molecule_template +Read molecule template mol1: + 1 molecules + 0 fragments + 18 atoms with max type 8 + 16 bonds with max type 10 + 25 angles with max type 28 + 23 dihedrals with max type 36 + 2 impropers with max type 3 +molecule mol2 rxn1_stp1_reacted.molecule_template +Read molecule template mol2: + 1 molecules + 0 fragments + 18 atoms with max type 9 + 17 bonds with max type 13 + 31 angles with max type 27 + 39 dihedrals with max type 33 + 0 impropers with max type 0 +molecule mol3 rxn1_stp2_unreacted.molecule_template +Read molecule template mol3: + 1 molecules + 0 fragments + 15 atoms with max type 9 + 14 bonds with max type 13 + 25 angles with max type 27 + 30 dihedrals with max type 33 + 0 impropers with max type 0 +molecule mol4 rxn1_stp2_reacted.molecule_template +Read molecule template mol4: + 1 molecules + 0 fragments + 15 atoms with max type 11 + 13 bonds with max type 15 + 19 angles with max type 29 + 16 dihedrals with max type 32 + 2 impropers with max type 13 + +thermo 50 + +# dump 1 all xyz 1 test_vis.xyz + +fix myrxns all bond/react stabilization yes statted_grp .03 react rxn1 all 1 0.0 5.0 mol1 mol2 rxn1_stp1_map prob v_prob1 1234 react rxn2 all 1 0.0 5.0 mol3 mol4 rxn1_stp2_map prob v_prob2 1234 +WARNING: Fix bond/react: Atom affected by reaction rxn2 is too close to template edge (../fix_bond_react.cpp:2624) +dynamic group bond_react_MASTER_group defined +dynamic group statted_grp_REACT defined + +fix 1 statted_grp_REACT nvt temp 300 300 100 + +# optionally, you can customize behavior of reacting atoms, +# by using the internally-created 'bond_react_MASTER_group', like so: +fix 4 bond_react_MASTER_group temp/rescale 1 300 300 10 1 + +thermo_style custom step temp press density v_prob1 v_prob2 f_myrxns[1] f_myrxns[2] + +# restart 100 restart1 restart2 + +run ${runsteps} +run 1000 + +CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE + +Your simulation uses code contributions which should be cited: + +- fix bond/react: reacter.org doi:10.1016/j.polymer.2017.09.038, doi:10.1021/acs.macromol.0c02012 + +@Article{Gissinger17, + author = {J. R. Gissinger and B. D. Jensen and K. E. Wise}, + title = {Modeling Chemical Reactions in Classical Molecular Dynamics Simulations}, + journal = {Polymer}, + year = 2017, + volume = 128, + pages = {211--217} +} + +@Article{Gissinger20, + author = {J. R. Gissinger, B. D. Jensen, K. E. Wise}, + title = {{REACTER}: A Heuristic Method for Reactive Molecular Dynamics}, + journal = {Macromolecules}, + year = 2020, + volume = 53, + number = 22, + pages = {9953--9961} +} + +CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE + +PPPM initialization ... + using 12-bit tables for long-range coulomb (../kspace.cpp:342) + G vector (1/distance) = 0.05345967 + grid = 2 2 2 + stencil order = 5 + estimated absolute RMS force accuracy = 0.040225597 + estimated relative force accuracy = 0.00012113819 + using double precision KISS FFT + 3d grid and FFT values/proc = 343 8 +Generated 55 of 55 mixed pair_coeff terms from sixthpower/geometric mixing rule +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 = 10 10 10 + 2 neighbor lists, perpetual/occasional/extra = 1 1 0 + (1) pair lj/class2/coul/long, perpetual + attributes: half, newton on + pair build: half/bin/newton + stencil: half/bin/3d + bin: standard + (2) fix bond/react, occasional, copy from (1) + attributes: half, newton on + pair build: copy + stencil: none + bin: none +WARNING: Inconsistent image flags (../domain.cpp:819) +Per MPI rank memory allocation (min/avg/max) = 33.78 | 33.78 | 33.78 Mbytes + Step Temp Press Density v_prob1 v_prob2 f_myrxns[1] f_myrxns[2] + 0 300 346.78165 0.0034851739 0.1 0 0 0 + 50 265.51039 -67.489756 0.0034851739 0.2 0 1 0 + 100 596.03388 -27.815189 0.0034851739 0.3 0 1 0 + 150 500.05269 2.9684972 0.0034851739 0.4 0 1 0 + 200 511.40295 56.791868 0.0034851739 0.5 0 1 0 + 250 375.95679 -4.0587677 0.0034851739 0.6 0 1 0 + 300 371.1629 -60.689059 0.0034851739 0.7 0 1 0 + 350 336.06545 8.6411023 0.0034851739 0.8 0 1 0 + 400 301.41962 50.628044 0.0034851739 0.9 0 1 0 + 450 281.08727 -15.590922 0.0034851739 1 0 1 0 + 500 297.35323 -9.5761786 0.0034851739 1.1 0 1 0 + 550 197.45298 3.6867353 0.0034851739 1.2 1 1 1 + 600 240.1748 -19.889198 0.0034851739 1.3 1 1 1 + 650 231.57018 -13.078808 0.0034851739 1.4 1 1 1 + 700 296.00816 -18.772183 0.0034851739 1.5 1 1 1 + 750 294.94016 15.43915 0.0034851739 1.6 1 1 1 + 800 316.51231 12.070563 0.0034851739 1.7 1 1 1 + 850 348.59373 9.0940092 0.0034851739 1.8 1 1 1 + 900 330.5264 -3.4868175 0.0034851739 1.9 1 1 1 + 950 307.02461 34.643373 0.0034851739 2 1 1 1 + 1000 250.06536 5.8440413 0.0034851739 2.1 1 1 1 +Loop time of 0.202863 on 1 procs for 1000 steps with 44 atoms + +Performance: 425.903 ns/day, 0.056 hours/ns, 4929.437 timesteps/s, 216.895 katom-step/s +100.0% CPU use with 1 MPI tasks x no OpenMP threads + +MPI task timing breakdown: +Section | min time | avg time | max time |%varavg| %total +--------------------------------------------------------------- +Pair | 0.025759 | 0.025759 | 0.025759 | 0.0 | 12.70 +Bond | 0.11024 | 0.11024 | 0.11024 | 0.0 | 54.34 +Kspace | 0.034344 | 0.034344 | 0.034344 | 0.0 | 16.93 +Neigh | 0.0015719 | 0.0015719 | 0.0015719 | 0.0 | 0.77 +Comm | 0.00045259 | 0.00045259 | 0.00045259 | 0.0 | 0.22 +Output | 0.0004759 | 0.0004759 | 0.0004759 | 0.0 | 0.23 +Modify | 0.028713 | 0.028713 | 0.028713 | 0.0 | 14.15 +Other | | 0.001307 | | | 0.64 + +Nlocal: 44 ave 44 max 44 min +Histogram: 1 0 0 0 0 0 0 0 0 0 +Nghost: 3 ave 3 max 3 min +Histogram: 1 0 0 0 0 0 0 0 0 0 +Neighs: 802 ave 802 max 802 min +Histogram: 1 0 0 0 0 0 0 0 0 0 + +Total # of neighbors = 802 +Ave neighs/atom = 18.227273 +Ave special neighs/atom = 9.9090909 +Neighbor list builds = 32 +Dangerous builds = 0 + +# write_restart restart_longrun +# write_data restart_longrun.data +Total wall time: 0:00:00 diff --git a/examples/PACKAGES/reaction/tiny_nylon/log.4Nov2020.tiny_nylon.stabilized_variable_probability.g++.4 b/examples/PACKAGES/reaction/tiny_nylon/log.4Nov2020.tiny_nylon.stabilized_variable_probability.g++.4 new file mode 100644 index 0000000000..d85e7fb474 --- /dev/null +++ b/examples/PACKAGES/reaction/tiny_nylon/log.4Nov2020.tiny_nylon.stabilized_variable_probability.g++.4 @@ -0,0 +1,237 @@ +LAMMPS (4 Nov 2022) +# two monomer nylon example +# reaction produces a condensed water molecule + +units real + +boundary p p p + +atom_style full + +kspace_style pppm 1.0e-4 + +pair_style lj/class2/coul/long 8.5 + +angle_style class2 + +bond_style class2 + +dihedral_style class2 + +improper_style class2 + +read_data tiny_nylon.data extra/bond/per/atom 5 extra/angle/per/atom 15 extra/dihedral/per/atom 15 extra/improper/per/atom 25 extra/special/per/atom 25 +Reading data file ... + orthogonal box = (-25 -25 -25) to (25 25 25) + 1 by 2 by 2 MPI processor grid + reading atom labelmap ... + reading bond labelmap ... + reading angle labelmap ... + reading dihedral labelmap ... + reading improper labelmap ... + reading atoms ... + 44 atoms + reading velocities ... + 44 velocities + scanning bonds ... + 9 = max bonds/atom + scanning angles ... + 21 = max angles/atom + scanning dihedrals ... + 29 = max dihedrals/atom + scanning impropers ... + 29 = max impropers/atom + reading bonds ... + 42 bonds + reading angles ... + 74 angles + reading dihedrals ... + 100 dihedrals + reading impropers ... + 44 impropers +Finding 1-2 1-3 1-4 neighbors ... + special bond factors lj: 0 0 0 + special bond factors coul: 0 0 0 + 4 = max # of 1-2 neighbors + 6 = max # of 1-3 neighbors + 12 = max # of 1-4 neighbors + 41 = max # of special neighbors + special bonds CPU = 0.000 seconds + read_data CPU = 0.008 seconds + +variable runsteps equal 1000 +variable prob1 equal step/v_runsteps*2+0.1 +variable prob2 equal (step/v_runsteps)>0.5 + +velocity all create 300.0 4928459 dist gaussian + +molecule mol1 rxn1_stp1_unreacted.molecule_template +Read molecule template mol1: + 1 molecules + 0 fragments + 18 atoms with max type 8 + 16 bonds with max type 10 + 25 angles with max type 28 + 23 dihedrals with max type 36 + 2 impropers with max type 3 +molecule mol2 rxn1_stp1_reacted.molecule_template +Read molecule template mol2: + 1 molecules + 0 fragments + 18 atoms with max type 9 + 17 bonds with max type 13 + 31 angles with max type 27 + 39 dihedrals with max type 33 + 0 impropers with max type 0 +molecule mol3 rxn1_stp2_unreacted.molecule_template +Read molecule template mol3: + 1 molecules + 0 fragments + 15 atoms with max type 9 + 14 bonds with max type 13 + 25 angles with max type 27 + 30 dihedrals with max type 33 + 0 impropers with max type 0 +molecule mol4 rxn1_stp2_reacted.molecule_template +Read molecule template mol4: + 1 molecules + 0 fragments + 15 atoms with max type 11 + 13 bonds with max type 15 + 19 angles with max type 29 + 16 dihedrals with max type 32 + 2 impropers with max type 13 + +thermo 50 + +# dump 1 all xyz 1 test_vis.xyz + +fix myrxns all bond/react stabilization yes statted_grp .03 react rxn1 all 1 0.0 5.0 mol1 mol2 rxn1_stp1_map prob v_prob1 1234 react rxn2 all 1 0.0 5.0 mol3 mol4 rxn1_stp2_map prob v_prob2 1234 +WARNING: Fix bond/react: Atom affected by reaction rxn2 is too close to template edge (../fix_bond_react.cpp:2624) +dynamic group bond_react_MASTER_group defined +dynamic group statted_grp_REACT defined + +fix 1 statted_grp_REACT nvt temp 300 300 100 + +# optionally, you can customize behavior of reacting atoms, +# by using the internally-created 'bond_react_MASTER_group', like so: +fix 4 bond_react_MASTER_group temp/rescale 1 300 300 10 1 + +thermo_style custom step temp press density v_prob1 v_prob2 f_myrxns[1] f_myrxns[2] + +# restart 100 restart1 restart2 + +run ${runsteps} +run 1000 + +CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE + +Your simulation uses code contributions which should be cited: + +- fix bond/react: reacter.org doi:10.1016/j.polymer.2017.09.038, doi:10.1021/acs.macromol.0c02012 + +@Article{Gissinger17, + author = {J. R. Gissinger and B. D. Jensen and K. E. Wise}, + title = {Modeling Chemical Reactions in Classical Molecular Dynamics Simulations}, + journal = {Polymer}, + year = 2017, + volume = 128, + pages = {211--217} +} + +@Article{Gissinger20, + author = {J. R. Gissinger, B. D. Jensen, K. E. Wise}, + title = {{REACTER}: A Heuristic Method for Reactive Molecular Dynamics}, + journal = {Macromolecules}, + year = 2020, + volume = 53, + number = 22, + pages = {9953--9961} +} + +CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE + +PPPM initialization ... + using 12-bit tables for long-range coulomb (../kspace.cpp:342) + G vector (1/distance) = 0.05345967 + grid = 2 2 2 + stencil order = 5 + estimated absolute RMS force accuracy = 0.040225597 + estimated relative force accuracy = 0.00012113819 + using double precision KISS FFT + 3d grid and FFT values/proc = 252 2 +Generated 55 of 55 mixed pair_coeff terms from sixthpower/geometric mixing rule +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 = 10 10 10 + 2 neighbor lists, perpetual/occasional/extra = 1 1 0 + (1) pair lj/class2/coul/long, perpetual + attributes: half, newton on + pair build: half/bin/newton + stencil: half/bin/3d + bin: standard + (2) fix bond/react, occasional, copy from (1) + attributes: half, newton on + pair build: copy + stencil: none + bin: none +WARNING: Inconsistent image flags (../domain.cpp:819) +Per MPI rank memory allocation (min/avg/max) = 33.66 | 33.88 | 34.43 Mbytes + Step Temp Press Density v_prob1 v_prob2 f_myrxns[1] f_myrxns[2] + 0 300 346.78165 0.0034851739 0.1 0 0 0 + 50 275.80938 -29.158908 0.0034851739 0.2 0 1 0 + 100 751.80013 8.8967942 0.0034851739 0.3 0 1 0 + 150 412.82804 61.44542 0.0034851739 0.4 0 1 0 + 200 432.95275 81.052275 0.0034851739 0.5 0 1 0 + 250 338.65702 -39.770422 0.0034851739 0.6 0 1 0 + 300 326.15993 -46.690912 0.0034851739 0.7 0 1 0 + 350 286.66126 51.986782 0.0034851739 0.8 0 1 0 + 400 244.24575 25.460254 0.0034851739 0.9 0 1 0 + 450 294.06274 5.0448726 0.0034851739 1 0 1 0 + 500 280.71089 0.86710712 0.0034851739 1.1 0 1 0 + 550 241.94123 -5.7812057 0.0034851739 1.2 1 1 1 + 600 235.1535 61.669814 0.0034851739 1.3 1 1 1 + 650 359.33618 -22.053171 0.0034851739 1.4 1 1 1 + 700 329.37555 -4.7839581 0.0034851739 1.5 1 1 1 + 750 285.76974 11.553815 0.0034851739 1.6 1 1 1 + 800 303.29561 16.017529 0.0034851739 1.7 1 1 1 + 850 256.86479 8.7487305 0.0034851739 1.8 1 1 1 + 900 292.29316 -11.376211 0.0034851739 1.9 1 1 1 + 950 293.47531 -2.7153276 0.0034851739 2 1 1 1 + 1000 303.66454 -4.8603249 0.0034851739 2.1 1 1 1 +Loop time of 0.195512 on 4 procs for 1000 steps with 44 atoms + +Performance: 441.916 ns/day, 0.054 hours/ns, 5114.771 timesteps/s, 225.050 katom-step/s +99.9% CPU use with 4 MPI tasks x no OpenMP threads + +MPI task timing breakdown: +Section | min time | avg time | max time |%varavg| %total +--------------------------------------------------------------- +Pair | 0.000163 | 0.0068784 | 0.016583 | 8.5 | 3.52 +Bond | 0.00040383 | 0.028615 | 0.083462 | 20.0 | 14.64 +Kspace | 0.043566 | 0.10199 | 0.13314 | 11.4 | 52.16 +Neigh | 0.00096634 | 0.00097064 | 0.00097509 | 0.0 | 0.50 +Comm | 0.0052532 | 0.0093802 | 0.014076 | 3.2 | 4.80 +Output | 0.00039802 | 0.00043637 | 0.00050031 | 0.0 | 0.22 +Modify | 0.043549 | 0.045538 | 0.049781 | 1.2 | 23.29 +Other | | 0.001708 | | | 0.87 + +Nlocal: 11 ave 29 max 0 min +Histogram: 2 0 0 0 0 1 0 0 0 1 +Nghost: 32.5 ave 45 max 16 min +Histogram: 1 0 0 1 0 0 0 0 1 1 +Neighs: 196.25 ave 448 max 0 min +Histogram: 2 0 0 0 0 0 0 1 0 1 + +Total # of neighbors = 785 +Ave neighs/atom = 17.840909 +Ave special neighs/atom = 9.9090909 +Neighbor list builds = 27 +Dangerous builds = 0 + +# write_restart restart_longrun +# write_data restart_longrun.data +Total wall time: 0:00:00 diff --git a/examples/PACKAGES/reaction/tiny_nylon/log.4Nov2020.tiny_nylon.unstabilized.g++.1 b/examples/PACKAGES/reaction/tiny_nylon/log.4Nov2020.tiny_nylon.unstabilized.g++.1 new file mode 100644 index 0000000000..5d696dae45 --- /dev/null +++ b/examples/PACKAGES/reaction/tiny_nylon/log.4Nov2020.tiny_nylon.unstabilized.g++.1 @@ -0,0 +1,228 @@ +LAMMPS (4 Nov 2022) +# two monomer nylon example +# reaction produces a condensed water molecule + +units real + +boundary p p p + +atom_style full + +kspace_style pppm 1.0e-4 + +pair_style lj/class2/coul/long 8.5 + +angle_style class2 + +bond_style class2 + +dihedral_style class2 + +improper_style class2 + +read_data tiny_nylon.data extra/bond/per/atom 5 extra/angle/per/atom 15 extra/dihedral/per/atom 15 extra/improper/per/atom 25 extra/special/per/atom 25 +Reading data file ... + orthogonal box = (-25 -25 -25) to (25 25 25) + 1 by 1 by 1 MPI processor grid + reading atom labelmap ... + reading bond labelmap ... + reading angle labelmap ... + reading dihedral labelmap ... + reading improper labelmap ... + reading atoms ... + 44 atoms + reading velocities ... + 44 velocities + scanning bonds ... + 9 = max bonds/atom + scanning angles ... + 21 = max angles/atom + scanning dihedrals ... + 29 = max dihedrals/atom + scanning impropers ... + 29 = max impropers/atom + reading bonds ... + 42 bonds + reading angles ... + 74 angles + reading dihedrals ... + 100 dihedrals + reading impropers ... + 44 impropers +Finding 1-2 1-3 1-4 neighbors ... + special bond factors lj: 0 0 0 + special bond factors coul: 0 0 0 + 4 = max # of 1-2 neighbors + 6 = max # of 1-3 neighbors + 12 = max # of 1-4 neighbors + 41 = max # of special neighbors + special bonds CPU = 0.000 seconds + read_data CPU = 0.008 seconds + + +velocity all create 300.0 4928459 dist gaussian + +molecule mol1 rxn1_stp1_unreacted.molecule_template +Read molecule template mol1: + 1 molecules + 0 fragments + 18 atoms with max type 8 + 16 bonds with max type 10 + 25 angles with max type 28 + 23 dihedrals with max type 36 + 2 impropers with max type 3 +molecule mol2 rxn1_stp1_reacted.molecule_template +Read molecule template mol2: + 1 molecules + 0 fragments + 18 atoms with max type 9 + 17 bonds with max type 13 + 31 angles with max type 27 + 39 dihedrals with max type 33 + 0 impropers with max type 0 +molecule mol3 rxn1_stp2_unreacted.molecule_template +Read molecule template mol3: + 1 molecules + 0 fragments + 15 atoms with max type 9 + 14 bonds with max type 13 + 25 angles with max type 27 + 30 dihedrals with max type 33 + 0 impropers with max type 0 +molecule mol4 rxn1_stp2_reacted.molecule_template +Read molecule template mol4: + 1 molecules + 0 fragments + 15 atoms with max type 11 + 13 bonds with max type 15 + 19 angles with max type 29 + 16 dihedrals with max type 32 + 2 impropers with max type 13 + +thermo 50 + +# dump 1 all xyz 1 test_vis.xyz + +fix myrxns all bond/react stabilization no react rxn1 all 1 0.0 2.9 mol1 mol2 rxn1_stp1_map react rxn2 all 1 0.0 5.0 mol3 mol4 rxn1_stp2_map +WARNING: Fix bond/react: Atom affected by reaction rxn2 is too close to template edge (../fix_bond_react.cpp:2624) +dynamic group bond_react_MASTER_group defined + +fix 1 all nve/limit .03 + +thermo_style custom step temp press density f_myrxns[1] f_myrxns[2] + +# restart 100 restart1 restart2 + +run 1000 + +CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE + +Your simulation uses code contributions which should be cited: + +- fix bond/react: reacter.org doi:10.1016/j.polymer.2017.09.038, doi:10.1021/acs.macromol.0c02012 + +@Article{Gissinger17, + author = {J. R. Gissinger and B. D. Jensen and K. E. Wise}, + title = {Modeling Chemical Reactions in Classical Molecular Dynamics Simulations}, + journal = {Polymer}, + year = 2017, + volume = 128, + pages = {211--217} +} + +@Article{Gissinger20, + author = {J. R. Gissinger, B. D. Jensen, K. E. Wise}, + title = {{REACTER}: A Heuristic Method for Reactive Molecular Dynamics}, + journal = {Macromolecules}, + year = 2020, + volume = 53, + number = 22, + pages = {9953--9961} +} + +CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE + +PPPM initialization ... + using 12-bit tables for long-range coulomb (../kspace.cpp:342) + G vector (1/distance) = 0.05345967 + grid = 2 2 2 + stencil order = 5 + estimated absolute RMS force accuracy = 0.040225597 + estimated relative force accuracy = 0.00012113819 + using double precision KISS FFT + 3d grid and FFT values/proc = 343 8 +Generated 55 of 55 mixed pair_coeff terms from sixthpower/geometric mixing rule +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 = 10 10 10 + 2 neighbor lists, perpetual/occasional/extra = 1 1 0 + (1) pair lj/class2/coul/long, perpetual + attributes: half, newton on + pair build: half/bin/newton + stencil: half/bin/3d + bin: standard + (2) fix bond/react, occasional, copy from (1) + attributes: half, newton on + pair build: copy + stencil: none + bin: none +WARNING: Inconsistent image flags (../domain.cpp:819) +Per MPI rank memory allocation (min/avg/max) = 33.72 | 33.72 | 33.72 Mbytes + Step Temp Press Density f_myrxns[1] f_myrxns[2] + 0 300 346.78165 0.0034851739 0 0 + 50 530.51001 -15.418012 0.0034851739 1 0 + 100 677.21327 16.545108 0.0034851739 1 1 + 150 386.79268 -28.445486 0.0034851739 1 1 + 200 380.29074 1.8065066 0.0034851739 1 1 + 250 353.27609 -7.3505628 0.0034851739 1 1 + 300 357.84405 -7.0569 0.0034851739 1 1 + 350 337.65224 54.441683 0.0034851739 1 1 + 400 322.54035 20.338902 0.0034851739 1 1 + 450 316.91217 44.76973 0.0034851739 1 1 + 500 345.40444 -8.2133383 0.0034851739 1 1 + 550 296.22085 -30.331582 0.0034851739 1 1 + 600 263.8024 -36.834323 0.0034851739 1 1 + 650 284.05699 1.2532577 0.0034851739 1 1 + 700 274.86269 4.6881357 0.0034851739 1 1 + 750 298.72284 -18.225831 0.0034851739 1 1 + 800 292.72143 -5.1622029 0.0034851739 1 1 + 850 279.30224 -10.72513 0.0034851739 1 1 + 900 284.97331 30.268801 0.0034851739 1 1 + 950 262.46089 16.98134 0.0034851739 1 1 + 1000 297.55359 28.583097 0.0034851739 1 1 +Loop time of 0.175951 on 1 procs for 1000 steps with 44 atoms + +Performance: 491.045 ns/day, 0.049 hours/ns, 5683.388 timesteps/s, 250.069 katom-step/s +99.6% CPU use with 1 MPI tasks x no OpenMP threads + +MPI task timing breakdown: +Section | min time | avg time | max time |%varavg| %total +--------------------------------------------------------------- +Pair | 0.022992 | 0.022992 | 0.022992 | 0.0 | 13.07 +Bond | 0.1045 | 0.1045 | 0.1045 | 0.0 | 59.39 +Kspace | 0.034057 | 0.034057 | 0.034057 | 0.0 | 19.36 +Neigh | 0.0013592 | 0.0013592 | 0.0013592 | 0.0 | 0.77 +Comm | 0.00040677 | 0.00040677 | 0.00040677 | 0.0 | 0.23 +Output | 0.00030929 | 0.00030929 | 0.00030929 | 0.0 | 0.18 +Modify | 0.01121 | 0.01121 | 0.01121 | 0.0 | 6.37 +Other | | 0.001118 | | | 0.64 + +Nlocal: 44 ave 44 max 44 min +Histogram: 1 0 0 0 0 0 0 0 0 0 +Nghost: 8 ave 8 max 8 min +Histogram: 1 0 0 0 0 0 0 0 0 0 +Neighs: 810 ave 810 max 810 min +Histogram: 1 0 0 0 0 0 0 0 0 0 + +Total # of neighbors = 810 +Ave neighs/atom = 18.409091 +Ave special neighs/atom = 9.9090909 +Neighbor list builds = 28 +Dangerous builds = 0 + +# write_restart restart_longrun +# write_data restart_longrun.data +Total wall time: 0:00:00 diff --git a/examples/PACKAGES/reaction/tiny_nylon/log.4Nov2020.tiny_nylon.unstabilized.g++.4 b/examples/PACKAGES/reaction/tiny_nylon/log.4Nov2020.tiny_nylon.unstabilized.g++.4 new file mode 100644 index 0000000000..0b022918be --- /dev/null +++ b/examples/PACKAGES/reaction/tiny_nylon/log.4Nov2020.tiny_nylon.unstabilized.g++.4 @@ -0,0 +1,228 @@ +LAMMPS (4 Nov 2022) +# two monomer nylon example +# reaction produces a condensed water molecule + +units real + +boundary p p p + +atom_style full + +kspace_style pppm 1.0e-4 + +pair_style lj/class2/coul/long 8.5 + +angle_style class2 + +bond_style class2 + +dihedral_style class2 + +improper_style class2 + +read_data tiny_nylon.data extra/bond/per/atom 5 extra/angle/per/atom 15 extra/dihedral/per/atom 15 extra/improper/per/atom 25 extra/special/per/atom 25 +Reading data file ... + orthogonal box = (-25 -25 -25) to (25 25 25) + 1 by 2 by 2 MPI processor grid + reading atom labelmap ... + reading bond labelmap ... + reading angle labelmap ... + reading dihedral labelmap ... + reading improper labelmap ... + reading atoms ... + 44 atoms + reading velocities ... + 44 velocities + scanning bonds ... + 9 = max bonds/atom + scanning angles ... + 21 = max angles/atom + scanning dihedrals ... + 29 = max dihedrals/atom + scanning impropers ... + 29 = max impropers/atom + reading bonds ... + 42 bonds + reading angles ... + 74 angles + reading dihedrals ... + 100 dihedrals + reading impropers ... + 44 impropers +Finding 1-2 1-3 1-4 neighbors ... + special bond factors lj: 0 0 0 + special bond factors coul: 0 0 0 + 4 = max # of 1-2 neighbors + 6 = max # of 1-3 neighbors + 12 = max # of 1-4 neighbors + 41 = max # of special neighbors + special bonds CPU = 0.000 seconds + read_data CPU = 0.008 seconds + + +velocity all create 300.0 4928459 dist gaussian + +molecule mol1 rxn1_stp1_unreacted.molecule_template +Read molecule template mol1: + 1 molecules + 0 fragments + 18 atoms with max type 8 + 16 bonds with max type 10 + 25 angles with max type 28 + 23 dihedrals with max type 36 + 2 impropers with max type 3 +molecule mol2 rxn1_stp1_reacted.molecule_template +Read molecule template mol2: + 1 molecules + 0 fragments + 18 atoms with max type 9 + 17 bonds with max type 13 + 31 angles with max type 27 + 39 dihedrals with max type 33 + 0 impropers with max type 0 +molecule mol3 rxn1_stp2_unreacted.molecule_template +Read molecule template mol3: + 1 molecules + 0 fragments + 15 atoms with max type 9 + 14 bonds with max type 13 + 25 angles with max type 27 + 30 dihedrals with max type 33 + 0 impropers with max type 0 +molecule mol4 rxn1_stp2_reacted.molecule_template +Read molecule template mol4: + 1 molecules + 0 fragments + 15 atoms with max type 11 + 13 bonds with max type 15 + 19 angles with max type 29 + 16 dihedrals with max type 32 + 2 impropers with max type 13 + +thermo 50 + +# dump 1 all xyz 1 test_vis.xyz + +fix myrxns all bond/react stabilization no react rxn1 all 1 0.0 2.9 mol1 mol2 rxn1_stp1_map react rxn2 all 1 0.0 5.0 mol3 mol4 rxn1_stp2_map +WARNING: Fix bond/react: Atom affected by reaction rxn2 is too close to template edge (../fix_bond_react.cpp:2624) +dynamic group bond_react_MASTER_group defined + +fix 1 all nve/limit .03 + +thermo_style custom step temp press density f_myrxns[1] f_myrxns[2] + +# restart 100 restart1 restart2 + +run 1000 + +CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE + +Your simulation uses code contributions which should be cited: + +- fix bond/react: reacter.org doi:10.1016/j.polymer.2017.09.038, doi:10.1021/acs.macromol.0c02012 + +@Article{Gissinger17, + author = {J. R. Gissinger and B. D. Jensen and K. E. Wise}, + title = {Modeling Chemical Reactions in Classical Molecular Dynamics Simulations}, + journal = {Polymer}, + year = 2017, + volume = 128, + pages = {211--217} +} + +@Article{Gissinger20, + author = {J. R. Gissinger, B. D. Jensen, K. E. Wise}, + title = {{REACTER}: A Heuristic Method for Reactive Molecular Dynamics}, + journal = {Macromolecules}, + year = 2020, + volume = 53, + number = 22, + pages = {9953--9961} +} + +CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE + +PPPM initialization ... + using 12-bit tables for long-range coulomb (../kspace.cpp:342) + G vector (1/distance) = 0.05345967 + grid = 2 2 2 + stencil order = 5 + estimated absolute RMS force accuracy = 0.040225597 + estimated relative force accuracy = 0.00012113819 + using double precision KISS FFT + 3d grid and FFT values/proc = 252 2 +Generated 55 of 55 mixed pair_coeff terms from sixthpower/geometric mixing rule +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 = 10 10 10 + 2 neighbor lists, perpetual/occasional/extra = 1 1 0 + (1) pair lj/class2/coul/long, perpetual + attributes: half, newton on + pair build: half/bin/newton + stencil: half/bin/3d + bin: standard + (2) fix bond/react, occasional, copy from (1) + attributes: half, newton on + pair build: copy + stencil: none + bin: none +WARNING: Inconsistent image flags (../domain.cpp:819) +Per MPI rank memory allocation (min/avg/max) = 33.59 | 33.82 | 34.37 Mbytes + Step Temp Press Density f_myrxns[1] f_myrxns[2] + 0 300 346.78165 0.0034851739 0 0 + 50 530.51001 -15.418012 0.0034851739 1 0 + 100 677.21327 16.545108 0.0034851739 1 1 + 150 386.79268 -28.445486 0.0034851739 1 1 + 200 380.29074 1.8065066 0.0034851739 1 1 + 250 353.27609 -7.3505628 0.0034851739 1 1 + 300 357.84405 -7.0569 0.0034851739 1 1 + 350 337.65224 54.441683 0.0034851739 1 1 + 400 322.54035 20.338902 0.0034851739 1 1 + 450 316.91217 44.76973 0.0034851739 1 1 + 500 345.40444 -8.2133383 0.0034851739 1 1 + 550 296.22085 -30.331582 0.0034851739 1 1 + 600 263.8024 -36.834323 0.0034851739 1 1 + 650 284.05699 1.2532577 0.0034851739 1 1 + 700 274.86269 4.6881357 0.0034851739 1 1 + 750 298.72284 -18.225831 0.0034851739 1 1 + 800 292.72143 -5.1622029 0.0034851739 1 1 + 850 279.30224 -10.72513 0.0034851739 1 1 + 900 284.97331 30.268801 0.0034851739 1 1 + 950 262.46089 16.98134 0.0034851739 1 1 + 1000 297.55359 28.583097 0.0034851739 1 1 +Loop time of 0.179911 on 4 procs for 1000 steps with 44 atoms + +Performance: 480.238 ns/day, 0.050 hours/ns, 5558.315 timesteps/s, 244.566 katom-step/s +99.9% CPU use with 4 MPI tasks x no OpenMP threads + +MPI task timing breakdown: +Section | min time | avg time | max time |%varavg| %total +--------------------------------------------------------------- +Pair | 0.0001131 | 0.0060483 | 0.016546 | 8.7 | 3.36 +Bond | 0.00024262 | 0.027106 | 0.07455 | 18.6 | 15.07 +Kspace | 0.059795 | 0.11105 | 0.13995 | 9.9 | 61.72 +Neigh | 0.0012033 | 0.0012139 | 0.0012228 | 0.0 | 0.67 +Comm | 0.0056243 | 0.0098345 | 0.013482 | 2.9 | 5.47 +Output | 0.00025378 | 0.0002833 | 0.00034961 | 0.0 | 0.16 +Modify | 0.020145 | 0.02287 | 0.027899 | 2.1 | 12.71 +Other | | 0.001506 | | | 0.84 + +Nlocal: 11 ave 41 max 0 min +Histogram: 3 0 0 0 0 0 0 0 0 1 +Nghost: 34.5 ave 46 max 8 min +Histogram: 1 0 0 0 0 0 0 0 2 1 +Neighs: 202.5 ave 807 max 0 min +Histogram: 3 0 0 0 0 0 0 0 0 1 + +Total # of neighbors = 810 +Ave neighs/atom = 18.409091 +Ave special neighs/atom = 9.9090909 +Neighbor list builds = 28 +Dangerous builds = 0 + +# write_restart restart_longrun +# write_data restart_longrun.data +Total wall time: 0:00:00 diff --git a/examples/PACKAGES/reaction/tiny_nylon/log.5Jun19.tiny_nylon.stabilized.g++.1 b/examples/PACKAGES/reaction/tiny_nylon/log.5Jun19.tiny_nylon.stabilized.g++.1 deleted file mode 100644 index de1167c652..0000000000 --- a/examples/PACKAGES/reaction/tiny_nylon/log.5Jun19.tiny_nylon.stabilized.g++.1 +++ /dev/null @@ -1,148 +0,0 @@ -LAMMPS (5 Jun 2019) -Reading data file ... - orthogonal box = (-25 -25 -25) to (25 25 25) - 1 by 1 by 1 MPI processor grid - reading atoms ... - 44 atoms - reading velocities ... - 44 velocities - scanning bonds ... - 9 = max bonds/atom - scanning angles ... - 21 = max angles/atom - scanning dihedrals ... - 29 = max dihedrals/atom - scanning impropers ... - 29 = max impropers/atom - reading bonds ... - 42 bonds - reading angles ... - 74 angles - reading dihedrals ... - 100 dihedrals - reading impropers ... - 44 impropers -Finding 1-2 1-3 1-4 neighbors ... - special bond factors lj: 0 0 0 - special bond factors coul: 0 0 0 - 4 = max # of 1-2 neighbors - 6 = max # of 1-3 neighbors - 12 = max # of 1-4 neighbors - 41 = max # of special neighbors - special bonds CPU = 0.000181113 secs - read_data CPU = 0.0251833 secs -Read molecule mol1: - 18 atoms with max type 8 - 16 bonds with max type 14 - 25 angles with max type 28 - 23 dihedrals with max type 36 - 14 impropers with max type 11 -Read molecule mol2: - 18 atoms with max type 9 - 17 bonds with max type 13 - 31 angles with max type 27 - 39 dihedrals with max type 33 - 20 impropers with max type 1 -Read molecule mol3: - 15 atoms with max type 9 - 14 bonds with max type 13 - 25 angles with max type 27 - 30 dihedrals with max type 33 - 16 impropers with max type 1 -Read molecule mol4: - 15 atoms with max type 11 - 13 bonds with max type 15 - 19 angles with max type 29 - 16 dihedrals with max type 32 - 10 impropers with max type 13 -WARNING: Bond/react: Atom affected by reaction rxn1 too close to template edge (../fix_bond_react.cpp:1785) -WARNING: Bond/react: Atom affected by reaction rxn2 too close to template edge (../fix_bond_react.cpp:1785) -dynamic group bond_react_MASTER_group defined -dynamic group statted_grp_REACT defined -PPPM initialization ... - using 12-bit tables for long-range coulomb (../kspace.cpp:319) - G vector (1/distance) = 0.0534597 - grid = 2 2 2 - stencil order = 5 - estimated absolute RMS force accuracy = 0.0402256 - estimated relative force accuracy = 0.000121138 - using double precision FFTs - 3d grid and FFT values/proc = 343 8 -Neighbor list info ... - update every 1 steps, delay 10 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 = 10 10 10 - 2 neighbor lists, perpetual/occasional/extra = 1 1 0 - (1) pair lj/class2/coul/long, perpetual - attributes: half, newton on - pair build: half/bin/newton - stencil: half/bin/3d/newton - bin: standard - (2) fix bond/react, occasional, copy from (1) - attributes: half, newton on - pair build: copy - stencil: none - bin: none -Setting up Verlet run ... - Unit style : real - Current step : 0 - Time step : 1 -WARNING: Inconsistent image flags (../domain.cpp:784) -Per MPI rank memory allocation (min/avg/max) = 34.41 | 34.41 | 34.41 Mbytes -Step Temp Press Density f_myrxns[1] f_myrxns[2] - 0 300 346.78165 0.0034851739 0 0 - 50 293.70542 -52.547388 0.0034851739 1 0 - 100 276.36755 54.81826 0.0034851739 1 1 - 150 448.65869 16.874435 0.0034851739 1 1 - 200 379.84257 11.578545 0.0034851739 1 1 - 250 298.21983 90.656585 0.0034851739 1 1 - 300 333.3111 -30.139607 0.0034851739 1 1 - 350 266.57108 6.4505134 0.0034851739 1 1 - 400 264.05476 10.513204 0.0034851739 1 1 - 450 250.70418 -18.635379 0.0034851739 1 1 - 500 261.21632 10.231013 0.0034851739 1 1 - 550 309.89024 -8.8299506 0.0034851739 1 1 - 600 373.45851 30.368993 0.0034851739 1 1 - 650 338.26242 9.0362267 0.0034851739 1 1 - 700 295.67794 -5.6007538 0.0034851739 1 1 - 750 310.86563 -59.228181 0.0034851739 1 1 - 800 286.22678 -9.9022407 0.0034851739 1 1 - 850 218.42135 27.845352 0.0034851739 1 1 - 900 259.62551 24.216336 0.0034851739 1 1 - 950 250.21307 -14.560985 0.0034851739 1 1 - 1000 274.29245 -0.38768626 0.0034851739 1 1 -Loop time of 0.341061 on 1 procs for 1000 steps with 44 atoms - -Performance: 253.327 ns/day, 0.095 hours/ns, 2932.025 timesteps/s -87.9% CPU use with 1 MPI tasks x no OpenMP threads - -MPI task timing breakdown: -Section | min time | avg time | max time |%varavg| %total ---------------------------------------------------------------- -Pair | 0.031135 | 0.031135 | 0.031135 | 0.0 | 9.13 -Bond | 0.12623 | 0.12623 | 0.12623 | 0.0 | 37.01 -Kspace | 0.036491 | 0.036491 | 0.036491 | 0.0 | 10.70 -Neigh | 0.046395 | 0.046395 | 0.046395 | 0.0 | 13.60 -Comm | 0.0025396 | 0.0025396 | 0.0025396 | 0.0 | 0.74 -Output | 0.07775 | 0.07775 | 0.07775 | 0.0 | 22.80 -Modify | 0.019219 | 0.019219 | 0.019219 | 0.0 | 5.64 -Other | | 0.001306 | | | 0.38 - -Nlocal: 44 ave 44 max 44 min -Histogram: 1 0 0 0 0 0 0 0 0 0 -Nghost: 2 ave 2 max 2 min -Histogram: 1 0 0 0 0 0 0 0 0 0 -Neighs: 740 ave 740 max 740 min -Histogram: 1 0 0 0 0 0 0 0 0 0 - -Total # of neighbors = 740 -Ave neighs/atom = 16.8182 -Ave special neighs/atom = 9.77273 -Neighbor list builds = 1000 -Dangerous builds = 0 - -Please see the log.cite file for references relevant to this simulation - -Total wall time: 0:00:00 diff --git a/examples/PACKAGES/reaction/tiny_nylon/log.5Jun19.tiny_nylon.stabilized.g++.4 b/examples/PACKAGES/reaction/tiny_nylon/log.5Jun19.tiny_nylon.stabilized.g++.4 deleted file mode 100644 index b9c7a3ba15..0000000000 --- a/examples/PACKAGES/reaction/tiny_nylon/log.5Jun19.tiny_nylon.stabilized.g++.4 +++ /dev/null @@ -1,148 +0,0 @@ -LAMMPS (5 Jun 2019) -Reading data file ... - orthogonal box = (-25 -25 -25) to (25 25 25) - 1 by 2 by 2 MPI processor grid - reading atoms ... - 44 atoms - reading velocities ... - 44 velocities - scanning bonds ... - 9 = max bonds/atom - scanning angles ... - 21 = max angles/atom - scanning dihedrals ... - 29 = max dihedrals/atom - scanning impropers ... - 29 = max impropers/atom - reading bonds ... - 42 bonds - reading angles ... - 74 angles - reading dihedrals ... - 100 dihedrals - reading impropers ... - 44 impropers -Finding 1-2 1-3 1-4 neighbors ... - special bond factors lj: 0 0 0 - special bond factors coul: 0 0 0 - 4 = max # of 1-2 neighbors - 6 = max # of 1-3 neighbors - 12 = max # of 1-4 neighbors - 41 = max # of special neighbors - special bonds CPU = 0.000178751 secs - read_data CPU = 0.0385782 secs -Read molecule mol1: - 18 atoms with max type 8 - 16 bonds with max type 14 - 25 angles with max type 28 - 23 dihedrals with max type 36 - 14 impropers with max type 11 -Read molecule mol2: - 18 atoms with max type 9 - 17 bonds with max type 13 - 31 angles with max type 27 - 39 dihedrals with max type 33 - 20 impropers with max type 1 -Read molecule mol3: - 15 atoms with max type 9 - 14 bonds with max type 13 - 25 angles with max type 27 - 30 dihedrals with max type 33 - 16 impropers with max type 1 -Read molecule mol4: - 15 atoms with max type 11 - 13 bonds with max type 15 - 19 angles with max type 29 - 16 dihedrals with max type 32 - 10 impropers with max type 13 -WARNING: Bond/react: Atom affected by reaction rxn1 too close to template edge (../fix_bond_react.cpp:1785) -WARNING: Bond/react: Atom affected by reaction rxn2 too close to template edge (../fix_bond_react.cpp:1785) -dynamic group bond_react_MASTER_group defined -dynamic group statted_grp_REACT defined -PPPM initialization ... - using 12-bit tables for long-range coulomb (../kspace.cpp:319) - G vector (1/distance) = 0.0534597 - grid = 2 2 2 - stencil order = 5 - estimated absolute RMS force accuracy = 0.0402256 - estimated relative force accuracy = 0.000121138 - using double precision FFTs - 3d grid and FFT values/proc = 252 2 -Neighbor list info ... - update every 1 steps, delay 10 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 = 10 10 10 - 2 neighbor lists, perpetual/occasional/extra = 1 1 0 - (1) pair lj/class2/coul/long, perpetual - attributes: half, newton on - pair build: half/bin/newton - stencil: half/bin/3d/newton - bin: standard - (2) fix bond/react, occasional, copy from (1) - attributes: half, newton on - pair build: copy - stencil: none - bin: none -Setting up Verlet run ... - Unit style : real - Current step : 0 - Time step : 1 -WARNING: Inconsistent image flags (../domain.cpp:784) -Per MPI rank memory allocation (min/avg/max) = 34.42 | 34.77 | 35.45 Mbytes -Step Temp Press Density f_myrxns[1] f_myrxns[2] - 0 300 346.78165 0.0034851739 0 0 - 50 293.70542 -52.547388 0.0034851739 1 0 - 100 276.36755 54.81826 0.0034851739 1 1 - 150 448.65869 16.874435 0.0034851739 1 1 - 200 379.84257 11.578545 0.0034851739 1 1 - 250 298.21983 90.656585 0.0034851739 1 1 - 300 333.3111 -30.139607 0.0034851739 1 1 - 350 266.57108 6.4505134 0.0034851739 1 1 - 400 264.05476 10.513204 0.0034851739 1 1 - 450 250.70418 -18.635379 0.0034851739 1 1 - 500 261.21632 10.231013 0.0034851739 1 1 - 550 309.89024 -8.8299506 0.0034851739 1 1 - 600 373.45851 30.368993 0.0034851739 1 1 - 650 338.26242 9.0362267 0.0034851739 1 1 - 700 295.67794 -5.6007538 0.0034851739 1 1 - 750 310.86563 -59.228181 0.0034851739 1 1 - 800 286.22678 -9.9022407 0.0034851739 1 1 - 850 218.42135 27.845352 0.0034851739 1 1 - 900 259.62551 24.216336 0.0034851739 1 1 - 950 250.21307 -14.560985 0.0034851739 1 1 - 1000 274.29245 -0.38768626 0.0034851739 1 1 -Loop time of 0.271242 on 4 procs for 1000 steps with 44 atoms - -Performance: 318.535 ns/day, 0.075 hours/ns, 3686.747 timesteps/s -98.6% CPU use with 4 MPI tasks x no OpenMP threads - -MPI task timing breakdown: -Section | min time | avg time | max time |%varavg| %total ---------------------------------------------------------------- -Pair | 0.00023773 | 0.0077322 | 0.016042 | 8.4 | 2.85 -Bond | 0.00073385 | 0.032108 | 0.08446 | 19.4 | 11.84 -Kspace | 0.041659 | 0.098095 | 0.13373 | 12.3 | 36.16 -Neigh | 0.028894 | 0.029247 | 0.029558 | 0.1 | 10.78 -Comm | 0.012367 | 0.013642 | 0.01503 | 0.9 | 5.03 -Output | 0.032475 | 0.040504 | 0.061019 | 5.9 | 14.93 -Modify | 0.032934 | 0.049086 | 0.0577 | 4.3 | 18.10 -Other | | 0.0008281 | | | 0.31 - -Nlocal: 11 ave 21 max 0 min -Histogram: 1 1 0 0 0 0 0 0 0 2 -Nghost: 32.5 ave 43 max 23 min -Histogram: 2 0 0 0 0 0 0 0 0 2 -Neighs: 185 ave 376 max 0 min -Histogram: 2 0 0 0 0 0 0 0 0 2 - -Total # of neighbors = 740 -Ave neighs/atom = 16.8182 -Ave special neighs/atom = 9.77273 -Neighbor list builds = 1000 -Dangerous builds = 0 - -Please see the log.cite file for references relevant to this simulation - -Total wall time: 0:00:00 diff --git a/examples/PACKAGES/reaction/tiny_nylon/log.5Jun19.tiny_nylon.unstabilized.g++.1 b/examples/PACKAGES/reaction/tiny_nylon/log.5Jun19.tiny_nylon.unstabilized.g++.1 deleted file mode 100644 index 14cac1dfad..0000000000 --- a/examples/PACKAGES/reaction/tiny_nylon/log.5Jun19.tiny_nylon.unstabilized.g++.1 +++ /dev/null @@ -1,147 +0,0 @@ -LAMMPS (5 Jun 2019) -Reading data file ... - orthogonal box = (-25 -25 -25) to (25 25 25) - 1 by 1 by 1 MPI processor grid - reading atoms ... - 44 atoms - reading velocities ... - 44 velocities - scanning bonds ... - 9 = max bonds/atom - scanning angles ... - 21 = max angles/atom - scanning dihedrals ... - 29 = max dihedrals/atom - scanning impropers ... - 29 = max impropers/atom - reading bonds ... - 42 bonds - reading angles ... - 74 angles - reading dihedrals ... - 100 dihedrals - reading impropers ... - 44 impropers -Finding 1-2 1-3 1-4 neighbors ... - special bond factors lj: 0 0 0 - special bond factors coul: 0 0 0 - 4 = max # of 1-2 neighbors - 6 = max # of 1-3 neighbors - 12 = max # of 1-4 neighbors - 41 = max # of special neighbors - special bonds CPU = 0.000217102 secs - read_data CPU = 0.00630778 secs -Read molecule mol1: - 18 atoms with max type 8 - 16 bonds with max type 14 - 25 angles with max type 28 - 23 dihedrals with max type 36 - 14 impropers with max type 11 -Read molecule mol2: - 18 atoms with max type 9 - 17 bonds with max type 13 - 31 angles with max type 27 - 39 dihedrals with max type 33 - 20 impropers with max type 1 -Read molecule mol3: - 15 atoms with max type 9 - 14 bonds with max type 13 - 25 angles with max type 27 - 30 dihedrals with max type 33 - 16 impropers with max type 1 -Read molecule mol4: - 15 atoms with max type 11 - 13 bonds with max type 15 - 19 angles with max type 29 - 16 dihedrals with max type 32 - 10 impropers with max type 13 -WARNING: Bond/react: Atom affected by reaction rxn1 too close to template edge (../fix_bond_react.cpp:1785) -WARNING: Bond/react: Atom affected by reaction rxn2 too close to template edge (../fix_bond_react.cpp:1785) -dynamic group bond_react_MASTER_group defined -PPPM initialization ... - using 12-bit tables for long-range coulomb (../kspace.cpp:319) - G vector (1/distance) = 0.0534597 - grid = 2 2 2 - stencil order = 5 - estimated absolute RMS force accuracy = 0.0402256 - estimated relative force accuracy = 0.000121138 - using double precision FFTs - 3d grid and FFT values/proc = 343 8 -Neighbor list info ... - update every 1 steps, delay 10 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 = 10 10 10 - 2 neighbor lists, perpetual/occasional/extra = 1 1 0 - (1) pair lj/class2/coul/long, perpetual - attributes: half, newton on - pair build: half/bin/newton - stencil: half/bin/3d/newton - bin: standard - (2) fix bond/react, occasional, copy from (1) - attributes: half, newton on - pair build: copy - stencil: none - bin: none -Setting up Verlet run ... - Unit style : real - Current step : 0 - Time step : 1 -WARNING: Inconsistent image flags (../domain.cpp:784) -Per MPI rank memory allocation (min/avg/max) = 34.35 | 34.35 | 34.35 Mbytes -Step Temp Press Density f_myrxns[1] f_myrxns[2] - 0 300 346.78165 0.0034851739 0 0 - 50 416.49412 -20.293038 0.0034851739 1 0 - 100 746.49323 91.912227 0.0034851739 1 1 - 150 515.15907 -1.4024709 0.0034851739 1 1 - 200 441.14572 -19.333087 0.0034851739 1 1 - 250 376.40996 30.717679 0.0034851739 1 1 - 300 326.15127 -3.0433799 0.0034851739 1 1 - 350 326.21116 6.235391 0.0034851739 1 1 - 400 366.48556 3.9807338 0.0034851739 1 1 - 450 313.79097 7.6674629 0.0034851739 1 1 - 500 278.89836 14.102052 0.0034851739 1 1 - 550 267.50214 18.241417 0.0034851739 1 1 - 600 276.28064 7.4649611 0.0034851739 1 1 - 650 255.26713 -8.5258573 0.0034851739 1 1 - 700 258.59752 -5.3341215 0.0034851739 1 1 - 750 263.71264 33.369869 0.0034851739 1 1 - 800 246.22976 -15.349137 0.0034851739 1 1 - 850 255.93887 16.331669 0.0034851739 1 1 - 900 239.72525 -0.20075789 0.0034851739 1 1 - 950 213.73064 12.17619 0.0034851739 1 1 - 1000 218.25094 -9.0955642 0.0034851739 1 1 -Loop time of 0.348252 on 1 procs for 1000 steps with 44 atoms - -Performance: 248.096 ns/day, 0.097 hours/ns, 2871.483 timesteps/s -91.8% CPU use with 1 MPI tasks x no OpenMP threads - -MPI task timing breakdown: -Section | min time | avg time | max time |%varavg| %total ---------------------------------------------------------------- -Pair | 0.031941 | 0.031941 | 0.031941 | 0.0 | 9.17 -Bond | 0.13031 | 0.13031 | 0.13031 | 0.0 | 37.42 -Kspace | 0.037554 | 0.037554 | 0.037554 | 0.0 | 10.78 -Neigh | 0.047397 | 0.047397 | 0.047397 | 0.0 | 13.61 -Comm | 0.0025814 | 0.0025814 | 0.0025814 | 0.0 | 0.74 -Output | 0.083526 | 0.083526 | 0.083526 | 0.0 | 23.98 -Modify | 0.013602 | 0.013602 | 0.013602 | 0.0 | 3.91 -Other | | 0.001336 | | | 0.38 - -Nlocal: 44 ave 44 max 44 min -Histogram: 1 0 0 0 0 0 0 0 0 0 -Nghost: 3 ave 3 max 3 min -Histogram: 1 0 0 0 0 0 0 0 0 0 -Neighs: 818 ave 818 max 818 min -Histogram: 1 0 0 0 0 0 0 0 0 0 - -Total # of neighbors = 818 -Ave neighs/atom = 18.5909 -Ave special neighs/atom = 9.77273 -Neighbor list builds = 1000 -Dangerous builds = 0 - -Please see the log.cite file for references relevant to this simulation - -Total wall time: 0:00:00 diff --git a/examples/PACKAGES/reaction/tiny_nylon/log.5Jun19.tiny_nylon.unstabilized.g++.4 b/examples/PACKAGES/reaction/tiny_nylon/log.5Jun19.tiny_nylon.unstabilized.g++.4 deleted file mode 100644 index 6b13dd60d3..0000000000 --- a/examples/PACKAGES/reaction/tiny_nylon/log.5Jun19.tiny_nylon.unstabilized.g++.4 +++ /dev/null @@ -1,147 +0,0 @@ -LAMMPS (5 Jun 2019) -Reading data file ... - orthogonal box = (-25 -25 -25) to (25 25 25) - 1 by 2 by 2 MPI processor grid - reading atoms ... - 44 atoms - reading velocities ... - 44 velocities - scanning bonds ... - 9 = max bonds/atom - scanning angles ... - 21 = max angles/atom - scanning dihedrals ... - 29 = max dihedrals/atom - scanning impropers ... - 29 = max impropers/atom - reading bonds ... - 42 bonds - reading angles ... - 74 angles - reading dihedrals ... - 100 dihedrals - reading impropers ... - 44 impropers -Finding 1-2 1-3 1-4 neighbors ... - special bond factors lj: 0 0 0 - special bond factors coul: 0 0 0 - 4 = max # of 1-2 neighbors - 6 = max # of 1-3 neighbors - 12 = max # of 1-4 neighbors - 41 = max # of special neighbors - special bonds CPU = 0.000163256 secs - read_data CPU = 0.0244579 secs -Read molecule mol1: - 18 atoms with max type 8 - 16 bonds with max type 14 - 25 angles with max type 28 - 23 dihedrals with max type 36 - 14 impropers with max type 11 -Read molecule mol2: - 18 atoms with max type 9 - 17 bonds with max type 13 - 31 angles with max type 27 - 39 dihedrals with max type 33 - 20 impropers with max type 1 -Read molecule mol3: - 15 atoms with max type 9 - 14 bonds with max type 13 - 25 angles with max type 27 - 30 dihedrals with max type 33 - 16 impropers with max type 1 -Read molecule mol4: - 15 atoms with max type 11 - 13 bonds with max type 15 - 19 angles with max type 29 - 16 dihedrals with max type 32 - 10 impropers with max type 13 -WARNING: Bond/react: Atom affected by reaction rxn1 too close to template edge (../fix_bond_react.cpp:1785) -WARNING: Bond/react: Atom affected by reaction rxn2 too close to template edge (../fix_bond_react.cpp:1785) -dynamic group bond_react_MASTER_group defined -PPPM initialization ... - using 12-bit tables for long-range coulomb (../kspace.cpp:319) - G vector (1/distance) = 0.0534597 - grid = 2 2 2 - stencil order = 5 - estimated absolute RMS force accuracy = 0.0402256 - estimated relative force accuracy = 0.000121138 - using double precision FFTs - 3d grid and FFT values/proc = 252 2 -Neighbor list info ... - update every 1 steps, delay 10 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 = 10 10 10 - 2 neighbor lists, perpetual/occasional/extra = 1 1 0 - (1) pair lj/class2/coul/long, perpetual - attributes: half, newton on - pair build: half/bin/newton - stencil: half/bin/3d/newton - bin: standard - (2) fix bond/react, occasional, copy from (1) - attributes: half, newton on - pair build: copy - stencil: none - bin: none -Setting up Verlet run ... - Unit style : real - Current step : 0 - Time step : 1 -WARNING: Inconsistent image flags (../domain.cpp:784) -Per MPI rank memory allocation (min/avg/max) = 33.34 | 33.69 | 34.37 Mbytes -Step Temp Press Density f_myrxns[1] f_myrxns[2] - 0 300 346.78165 0.0034851739 0 0 - 50 416.49412 -20.293038 0.0034851739 1 0 - 100 746.49323 91.912227 0.0034851739 1 1 - 150 515.15907 -1.4024709 0.0034851739 1 1 - 200 441.14572 -19.333087 0.0034851739 1 1 - 250 376.40996 30.717679 0.0034851739 1 1 - 300 326.15127 -3.0433799 0.0034851739 1 1 - 350 326.21116 6.235391 0.0034851739 1 1 - 400 366.48556 3.9807338 0.0034851739 1 1 - 450 313.79097 7.6674629 0.0034851739 1 1 - 500 278.89836 14.102052 0.0034851739 1 1 - 550 267.50214 18.241417 0.0034851739 1 1 - 600 276.28064 7.4649611 0.0034851739 1 1 - 650 255.26713 -8.5258573 0.0034851739 1 1 - 700 258.59752 -5.3341215 0.0034851739 1 1 - 750 263.71264 33.369869 0.0034851739 1 1 - 800 246.22976 -15.349137 0.0034851739 1 1 - 850 255.93887 16.331669 0.0034851739 1 1 - 900 239.72525 -0.20075789 0.0034851739 1 1 - 950 213.73064 12.17619 0.0034851739 1 1 - 1000 218.25094 -9.0955642 0.0034851739 1 1 -Loop time of 0.254903 on 4 procs for 1000 steps with 44 atoms - -Performance: 338.952 ns/day, 0.071 hours/ns, 3923.053 timesteps/s -99.8% CPU use with 4 MPI tasks x no OpenMP threads - -MPI task timing breakdown: -Section | min time | avg time | max time |%varavg| %total ---------------------------------------------------------------- -Pair | 0.00014252 | 0.0090715 | 0.021332 | 9.6 | 3.56 -Bond | 0.00047028 | 0.037261 | 0.10789 | 22.7 | 14.62 -Kspace | 0.051006 | 0.12756 | 0.1693 | 13.6 | 50.04 -Neigh | 0.035644 | 0.036088 | 0.036523 | 0.2 | 14.16 -Comm | 0.013984 | 0.016074 | 0.018676 | 1.6 | 6.31 -Output | 0.0002816 | 0.00033726 | 0.00044251 | 0.0 | 0.13 -Modify | 0.023697 | 0.027803 | 0.033552 | 2.5 | 10.91 -Other | | 0.0007123 | | | 0.28 - -Nlocal: 11 ave 29 max 0 min -Histogram: 1 1 0 0 1 0 0 0 0 1 -Nghost: 25 ave 31 max 12 min -Histogram: 1 0 0 0 0 0 0 0 2 1 -Neighs: 204.5 ave 443 max 0 min -Histogram: 2 0 0 0 0 0 0 0 1 1 - -Total # of neighbors = 818 -Ave neighs/atom = 18.5909 -Ave special neighs/atom = 9.77273 -Neighbor list builds = 1000 -Dangerous builds = 0 - -Please see the log.cite file for references relevant to this simulation - -Total wall time: 0:00:00 diff --git a/examples/PACKAGES/reaction/tiny_nylon/rxn1_stp1_reacted.data_template b/examples/PACKAGES/reaction/tiny_nylon/rxn1_stp1_reacted.data_template deleted file mode 100644 index d7256f43d2..0000000000 --- a/examples/PACKAGES/reaction/tiny_nylon/rxn1_stp1_reacted.data_template +++ /dev/null @@ -1,189 +0,0 @@ -this is a molecule template for: initial nylon crosslink, post-reacting - -18 atoms -17 bonds -31 angles -39 dihedrals -20 impropers - -Types - -1 9 -2 1 -3 1 -4 8 -5 8 -6 4 -7 4 -8 1 -9 1 -10 2 -11 6 -12 3 -13 4 -14 4 -15 5 -16 1 -17 4 -18 4 - -Charges - -1 -0.300000 -2 0.000000 -3 0.000000 -4 0.000000 -5 0.000000 -6 0.000000 -7 0.000000 -8 0.000000 -9 0.000000 -10 0.300000 -11 0.000000 -12 0.000000 -13 0.000000 -14 0.000000 -15 0.000000 -16 0.000000 -17 0.000000 -18 0.000000 - -Coords - -1 -5.522237 -0.752722 1.631158 -2 -5.170398 -0.545733 0.178130 -3 -6.469695 -0.553072 -0.648889 -4 -6.052076 -1.721152 1.744648 -5 -6.183059 0.071387 1.971497 -6 -4.489340 -1.389197 -0.173156 -7 -4.637591 0.453703 0.051252 -8 -5.618658 0.138919 4.386107 -9 -4.669492 -0.989819 3.943591 -10 -4.270194 -0.766405 2.474102 -11 -3.348470 -1.875393 2.024289 -12 -3.569794 0.564183 2.345995 -13 -5.201079 -1.993301 4.044219 -14 -3.736682 -0.984819 4.598305 -15 -4.255402 1.370923 2.679069 -16 -6.136394 -0.339866 -2.136775 -17 -6.996331 -1.555519 -0.517408 -18 -7.153308 0.284949 -0.289930 - -Bonds - -1 11 1 2 -2 12 1 4 -3 12 1 5 -4 13 1 10 -5 2 2 3 -6 1 2 6 -7 1 2 7 -8 2 3 16 -9 1 3 17 -10 1 3 18 -11 2 8 9 -12 4 9 10 -13 1 9 13 -14 1 9 14 -15 5 10 11 -16 3 10 12 -17 6 12 15 - -Angles - -1 17 2 1 4 -2 17 2 1 5 -3 18 2 1 10 -4 19 4 1 5 -5 20 4 1 10 -6 20 5 1 10 -7 21 1 2 3 -8 22 1 2 6 -9 22 1 2 7 -10 2 3 2 6 -11 2 3 2 7 -12 1 6 2 7 -13 3 2 3 16 -14 2 2 3 17 -15 2 2 3 18 -16 2 16 3 17 -17 2 16 3 18 -18 1 17 3 18 -19 8 8 9 10 -20 2 8 9 13 -21 2 8 9 14 -22 23 13 9 10 -23 23 14 9 10 -24 1 13 9 14 -25 6 9 10 11 -26 4 9 10 12 -27 24 1 10 9 -28 25 11 10 12 -29 26 1 10 11 -30 27 1 10 12 -31 7 10 12 15 - -Dihedrals - -1 19 4 1 2 3 -2 20 4 1 2 6 -3 20 4 1 2 7 -4 19 5 1 2 3 -5 20 5 1 2 6 -6 20 5 1 2 7 -7 21 10 1 2 3 -8 22 10 1 2 6 -9 22 10 1 2 7 -10 23 2 1 10 9 -11 24 2 1 10 11 -12 25 2 1 10 12 -13 26 4 1 10 9 -14 27 4 1 10 11 -15 28 4 1 10 12 -16 26 5 1 10 9 -17 27 5 1 10 11 -18 28 5 1 10 12 -19 29 1 2 3 16 -20 30 1 2 3 17 -21 30 1 2 3 18 -22 4 16 3 2 6 -23 2 6 2 3 17 -24 2 6 2 3 18 -25 4 16 3 2 7 -26 2 7 2 3 17 -27 2 7 2 3 18 -28 10 8 9 10 11 -29 8 8 9 10 12 -30 31 8 9 10 1 -31 11 13 9 10 11 -32 9 13 9 10 12 -33 32 13 9 10 1 -34 11 14 9 10 11 -35 9 14 9 10 12 -36 32 14 9 10 1 -37 6 9 10 12 15 -38 7 11 10 12 15 -39 33 1 10 12 15 - -Impropers - -1 1 2 1 4 5 -2 1 2 1 4 10 -3 1 2 1 5 10 -4 1 4 1 5 10 -5 1 1 2 3 6 -6 1 1 2 3 7 -7 1 1 2 6 7 -8 1 3 2 6 7 -9 1 2 3 16 17 -10 1 2 3 16 18 -11 1 2 3 17 18 -12 1 16 3 17 18 -13 1 8 9 13 10 -14 1 8 9 14 10 -15 1 8 9 13 14 -16 1 13 9 14 10 -17 1 9 10 11 12 -18 1 1 10 9 11 -19 1 1 10 9 12 -20 1 1 10 11 12 diff --git a/examples/PACKAGES/reaction/tiny_nylon/rxn1_stp1_reacted.molecule_template b/examples/PACKAGES/reaction/tiny_nylon/rxn1_stp1_reacted.molecule_template new file mode 100644 index 0000000000..40f3aa8276 --- /dev/null +++ b/examples/PACKAGES/reaction/tiny_nylon/rxn1_stp1_reacted.molecule_template @@ -0,0 +1,187 @@ +this is a molecule template for: initial nylon crosslink, post-reacting + + 18 atoms + 17 bonds + 31 angles + 39 dihedrals + 0 impropers + +Coords + + 1 -5.522237178 -0.752722499 1.631158408 + 2 -5.170398325 -0.545733378 0.178129978 + 3 -6.469694974 -0.553071841 -0.648889109 + 4 -6.052075697 -1.721152483 1.744647858 + 5 -6.183058842 0.071386755 1.971497329 + 6 -4.489339595 -1.389196844 -0.173156276 + 7 -4.637590712 0.453703382 0.051251954 + 8 -5.618657658 0.138918810 4.386106928 + 9 -4.669491736 -0.989818781 3.943591338 + 10 -4.270193542 -0.766405234 2.474102239 + 11 -3.348470373 -1.875393291 2.024289246 + 12 -3.569793683 0.564183226 2.345995471 + 13 -5.201078949 -1.993301389 4.044218837 + 14 -3.736681607 -0.984819193 4.598304847 + 15 -4.255401979 1.370923174 2.679069013 + 16 -6.136393628 -0.339866195 -2.136774990 + 17 -6.996331494 -1.555519161 -0.517408063 + 18 -7.153308038 0.284949373 -0.289930394 + +Types + + 1 n + 2 c2 + 3 c2 + 4 hn + 5 hn + 6 hc + 7 hc + 8 c2 + 9 c2 + 10 c_1 + 11 o_1 + 12 o + 13 hc + 14 hc + 15 ho + 16 c2 + 17 hc + 18 hc + +Charges + + 1 -0.300000 + 2 0.000000 + 3 0.000000 + 4 0.000000 + 5 0.000000 + 6 0.000000 + 7 0.000000 + 8 0.000000 + 9 0.000000 + 10 0.300000 + 11 0.000000 + 12 0.000000 + 13 0.000000 + 14 0.000000 + 15 0.000000 + 16 0.000000 + 17 0.000000 + 18 0.000000 + +Molecules + + 1 1 + 2 1 + 3 1 + 4 1 + 5 1 + 6 1 + 7 1 + 8 1 + 9 1 + 10 1 + 11 1 + 12 1 + 13 1 + 14 1 + 15 1 + 16 1 + 17 1 + 18 1 + +Bonds + + 1 n-c2 1 2 + 2 n-hn 1 4 + 3 n-hn 1 5 + 4 n-c_1 1 10 + 5 c2-c2 2 3 + 6 c2-hc 2 6 + 7 c2-hc 2 7 + 8 c2-c2 3 16 + 9 c2-hc 3 17 + 10 c2-hc 3 18 + 11 c2-c2 8 9 + 12 c2-c_1 9 10 + 13 c2-hc 9 13 + 14 c2-hc 9 14 + 15 c_1-o_1 10 11 + 16 c_1-o 10 12 + 17 o-ho 12 15 + +Angles + + 1 c2-n-hn 2 1 4 + 2 c2-n-hn 2 1 5 + 3 c2-n-c_1 2 1 10 + 4 hn-n-hn 4 1 5 + 5 hn-n-c_1 4 1 10 + 6 hn-n-c_1 5 1 10 + 7 n-c2-c2 1 2 3 + 8 n-c2-hc 1 2 6 + 9 n-c2-hc 1 2 7 + 10 c2-c2-hc 3 2 6 + 11 c2-c2-hc 3 2 7 + 12 hc-c2-hc 6 2 7 + 13 c2-c2-c2 2 3 16 + 14 c2-c2-hc 2 3 17 + 15 c2-c2-hc 2 3 18 + 16 c2-c2-hc 16 3 17 + 17 c2-c2-hc 16 3 18 + 18 hc-c2-hc 17 3 18 + 19 c2-c2-c_1 8 9 10 + 20 c2-c2-hc 8 9 13 + 21 c2-c2-hc 8 9 14 + 22 hc-c2-c_1 13 9 10 + 23 hc-c2-c_1 14 9 10 + 24 hc-c2-hc 13 9 14 + 25 c2-c_1-o_1 9 10 11 + 26 c2-c_1-o 9 10 12 + 27 n-c_1-c2 1 10 9 + 28 o_1-c_1-o 11 10 12 + 29 n-c_1-o_1 1 10 11 + 30 n-c_1-o 1 10 12 + 31 c_1-o-ho 10 12 15 + +Dihedrals + + 1 hn-n-c2-c2 4 1 2 3 + 2 hn-n-c2-hc 4 1 2 6 + 3 hn-n-c2-hc 4 1 2 7 + 4 hn-n-c2-c2 5 1 2 3 + 5 hn-n-c2-hc 5 1 2 6 + 6 hn-n-c2-hc 5 1 2 7 + 7 c_1-n-c2-c2 10 1 2 3 + 8 c_1-n-c2-hc 10 1 2 6 + 9 c_1-n-c2-hc 10 1 2 7 + 10 c2-n-c_1-c2 2 1 10 9 + 11 c2-n-c_1-o_1 2 1 10 11 + 12 c2-n-c_1-o 2 1 10 12 + 13 hn-n-c_1-c2 4 1 10 9 + 14 hn-n-c_1-o_1 4 1 10 11 + 15 hn-n-c_1-o 4 1 10 12 + 16 hn-n-c_1-c2 5 1 10 9 + 17 hn-n-c_1-o_1 5 1 10 11 + 18 hn-n-c_1-o 5 1 10 12 + 19 n-c2-c2-c2 1 2 3 16 + 20 n-c2-c2-hc 1 2 3 17 + 21 n-c2-c2-hc 1 2 3 18 + 22 c2-c2-c2-hc 16 3 2 6 + 23 hc-c2-c2-hc 6 2 3 17 + 24 hc-c2-c2-hc 6 2 3 18 + 25 c2-c2-c2-hc 16 3 2 7 + 26 hc-c2-c2-hc 7 2 3 17 + 27 hc-c2-c2-hc 7 2 3 18 + 28 c2-c2-c_1-o_1 8 9 10 11 + 29 c2-c2-c_1-o 8 9 10 12 + 30 c2-c2-c_1-n 8 9 10 1 + 31 hc-c2-c_1-o_1 13 9 10 11 + 32 hc-c2-c_1-o 13 9 10 12 + 33 hc-c2-c_1-n 13 9 10 1 + 34 hc-c2-c_1-o_1 14 9 10 11 + 35 hc-c2-c_1-o 14 9 10 12 + 36 hc-c2-c_1-n 14 9 10 1 + 37 c2-c_1-o-ho 9 10 12 15 + 38 o_1-c_1-o-ho 11 10 12 15 + 39 n-c_1-o-ho 1 10 12 15 diff --git a/examples/PACKAGES/reaction/tiny_nylon/rxn1_stp1_unreacted.data_template b/examples/PACKAGES/reaction/tiny_nylon/rxn1_stp1_unreacted.data_template deleted file mode 100644 index ec3f109d7b..0000000000 --- a/examples/PACKAGES/reaction/tiny_nylon/rxn1_stp1_unreacted.data_template +++ /dev/null @@ -1,160 +0,0 @@ -this is a molecule template for: initial nylon crosslink, pre-reacting - -18 atoms -16 bonds -25 angles -23 dihedrals -14 impropers - -Types - -1 7 -2 1 -3 1 -4 8 -5 8 -6 4 -7 4 -8 1 -9 1 -10 2 -11 6 -12 3 -13 4 -14 4 -15 5 -16 1 -17 4 -18 4 - -Charges - -1 -0.300000 -2 0.000000 -3 0.000000 -4 0.000000 -5 0.000000 -6 0.000000 -7 0.000000 -8 0.000000 -9 0.000000 -10 0.300000 -11 0.000000 -12 0.000000 -13 0.000000 -14 0.000000 -15 0.000000 -16 0.000000 -17 0.000000 -18 0.000000 - -Coords - -1 -4.922858 -0.946982 1.146055 -2 -5.047195 -0.935267 -0.358173 -3 -6.526281 -0.755366 -0.743523 -4 -5.282604 0.020447 1.552710 -5 -3.860697 -1.095850 1.428305 -6 -4.662382 -1.920900 -0.781524 -7 -4.433977 -0.072765 -0.784071 -8 -5.506279 0.202610 4.825816 -9 -4.449177 -0.844592 4.423366 -10 -4.103916 -0.749629 2.925195 -11 -3.376249 -1.886171 2.245643 -12 -4.493235 0.477214 2.137199 -13 -4.849053 -1.888877 4.663994 -14 -3.491823 -0.662913 5.018510 -15 -5.020777 1.189745 2.805427 -16 -3.964987 2.900602 -1.551341 -17 -4.460694 2.836102 0.668882 -18 -4.828494 3.219656 -0.122111 - -Bonds - -1 14 1 2 -2 10 1 4 -3 10 1 5 -4 2 2 3 -5 1 2 6 -6 1 2 7 -7 2 3 16 -8 1 3 17 -9 1 3 18 -10 2 8 9 -11 4 9 10 -12 1 9 13 -13 1 9 14 -14 5 10 11 -15 3 10 12 -16 6 12 15 - -Angles - -1 15 2 1 4 -2 15 2 1 5 -3 16 4 1 5 -4 28 1 2 3 -5 14 1 2 6 -6 14 1 2 7 -7 2 3 2 6 -8 2 3 2 7 -9 1 6 2 7 -10 3 2 3 16 -11 2 2 3 17 -12 2 2 3 18 -13 2 16 3 17 -14 2 16 3 18 -15 1 17 3 18 -16 8 8 9 10 -17 2 8 9 13 -18 2 8 9 14 -19 23 13 9 10 -20 23 14 9 10 -21 1 13 9 14 -22 6 9 10 11 -23 4 9 10 12 -24 25 11 10 12 -25 7 10 12 15 - -Dihedrals - -1 34 4 1 2 3 -2 35 4 1 2 6 -3 35 4 1 2 7 -4 34 5 1 2 3 -5 35 5 1 2 6 -6 35 5 1 2 7 -7 36 1 2 3 16 -8 12 1 2 3 17 -9 12 1 2 3 18 -10 4 16 3 2 6 -11 2 6 2 3 17 -12 2 6 2 3 18 -13 4 16 3 2 7 -14 2 7 2 3 17 -15 2 7 2 3 18 -16 10 8 9 10 11 -17 8 8 9 10 12 -18 11 13 9 10 11 -19 9 13 9 10 12 -20 11 14 9 10 11 -21 9 14 9 10 12 -22 6 9 10 12 15 -23 7 11 10 12 15 - -Impropers - -1 6 2 1 4 5 -2 11 9 10 11 12 -3 1 1 2 3 6 -4 1 1 2 3 7 -5 1 1 2 6 7 -6 1 3 2 6 7 -7 1 2 3 16 17 -8 1 2 3 16 18 -9 1 2 3 17 18 -10 1 16 3 17 18 -11 1 8 9 13 10 -12 1 8 9 14 10 -13 1 8 9 13 14 -14 1 13 9 14 10 diff --git a/examples/PACKAGES/reaction/tiny_nylon/rxn1_stp1_unreacted.molecule_template b/examples/PACKAGES/reaction/tiny_nylon/rxn1_stp1_unreacted.molecule_template new file mode 100644 index 0000000000..7de7512f1c --- /dev/null +++ b/examples/PACKAGES/reaction/tiny_nylon/rxn1_stp1_unreacted.molecule_template @@ -0,0 +1,169 @@ +this is a molecule template for: initial nylon crosslink, pre-reacting + + 18 atoms + 16 bonds + 25 angles + 23 dihedrals + 2 impropers + +Coords + + 1 -4.922858499 -0.946981747 1.146055346 + 2 -5.047194816 -0.935266843 -0.358172771 + 3 -6.526281447 -0.755365854 -0.743523227 + 4 -5.282604074 0.020446894 1.552710361 + 5 -3.860696509 -1.095850190 1.428304925 + 6 -4.662381862 -1.920899862 -0.781524026 + 7 -4.433976540 -0.072765142 -0.784070641 + 8 -5.506279186 0.202610302 4.825815562 + 9 -4.449176624 -0.844592213 4.423366146 + 10 -4.103915981 -0.749628655 2.925195217 + 11 -3.376248536 -1.886171498 2.245643443 + 12 -4.493235430 0.477213651 2.137199034 + 13 -4.849052953 -1.888876753 4.663993750 + 14 -3.491822950 -0.662913310 5.018510248 + 15 -5.020776528 1.189745133 2.805427194 + 16 -3.964987378 2.900602044 -1.551341170 + 17 -4.460693773 2.836101897 0.668881952 + 18 -4.828494000 3.219655862 -0.122111278 + +Types + + 1 na + 2 c2 + 3 c2 + 4 hn + 5 hn + 6 hc + 7 hc + 8 c2 + 9 c2 + 10 c_1 + 11 o_1 + 12 o + 13 hc + 14 hc + 15 ho + 16 c2 + 17 hc + 18 hc + +Charges + + 1 -0.300000 + 2 0.000000 + 3 0.000000 + 4 0.000000 + 5 0.000000 + 6 0.000000 + 7 0.000000 + 8 0.000000 + 9 0.000000 + 10 0.300000 + 11 0.000000 + 12 0.000000 + 13 0.000000 + 14 0.000000 + 15 0.000000 + 16 0.000000 + 17 0.000000 + 18 0.000000 + +Molecules + + 1 1 + 2 1 + 3 1 + 4 1 + 5 1 + 6 1 + 7 1 + 8 1 + 9 1 + 10 1 + 11 1 + 12 1 + 13 1 + 14 1 + 15 1 + 16 1 + 17 1 + 18 1 + +Bonds + + 1 na-c2 1 2 + 2 na-hn 1 4 + 3 na-hn 1 5 + 4 c2-c2 2 3 + 5 c2-hc 2 6 + 6 c2-hc 2 7 + 7 c2-c2 3 16 + 8 c2-hc 3 17 + 9 c2-hc 3 18 + 10 c2-c2 8 9 + 11 c2-c_1 9 10 + 12 c2-hc 9 13 + 13 c2-hc 9 14 + 14 c_1-o_1 10 11 + 15 c_1-o 10 12 + 16 o-ho 12 15 + +Angles + + 1 c2-na-hn 2 1 4 + 2 c2-na-hn 2 1 5 + 3 hn-na-hn 4 1 5 + 4 na-c2-c2 1 2 3 + 5 na-c2-hc 1 2 6 + 6 na-c2-hc 1 2 7 + 7 c2-c2-hc 3 2 6 + 8 c2-c2-hc 3 2 7 + 9 hc-c2-hc 6 2 7 + 10 c2-c2-c2 2 3 16 + 11 c2-c2-hc 2 3 17 + 12 c2-c2-hc 2 3 18 + 13 c2-c2-hc 16 3 17 + 14 c2-c2-hc 16 3 18 + 15 hc-c2-hc 17 3 18 + 16 c2-c2-c_1 8 9 10 + 17 c2-c2-hc 8 9 13 + 18 c2-c2-hc 8 9 14 + 19 hc-c2-c_1 13 9 10 + 20 hc-c2-c_1 14 9 10 + 21 hc-c2-hc 13 9 14 + 22 c2-c_1-o_1 9 10 11 + 23 c2-c_1-o 9 10 12 + 24 o_1-c_1-o 11 10 12 + 25 c_1-o-ho 10 12 15 + +Dihedrals + + 1 hn-na-c2-c2 4 1 2 3 + 2 hn-na-c2-hc 4 1 2 6 + 3 hn-na-c2-hc 4 1 2 7 + 4 hn-na-c2-c2 5 1 2 3 + 5 hn-na-c2-hc 5 1 2 6 + 6 hn-na-c2-hc 5 1 2 7 + 7 na-c2-c2-c2 1 2 3 16 + 8 na-c2-c2-hc 1 2 3 17 + 9 na-c2-c2-hc 1 2 3 18 + 10 c2-c2-c2-hc 16 3 2 6 + 11 hc-c2-c2-hc 6 2 3 17 + 12 hc-c2-c2-hc 6 2 3 18 + 13 c2-c2-c2-hc 16 3 2 7 + 14 hc-c2-c2-hc 7 2 3 17 + 15 hc-c2-c2-hc 7 2 3 18 + 16 c2-c2-c_1-o_1 8 9 10 11 + 17 c2-c2-c_1-o 8 9 10 12 + 18 hc-c2-c_1-o_1 13 9 10 11 + 19 hc-c2-c_1-o 13 9 10 12 + 20 hc-c2-c_1-o_1 14 9 10 11 + 21 hc-c2-c_1-o 14 9 10 12 + 22 c2-c_1-o-ho 9 10 12 15 + 23 o_1-c_1-o-ho 11 10 12 15 + +Impropers + + 1 c2-na-hn-hn 2 1 4 5 + 2 c2-c_1-o_1-o 9 10 11 12 diff --git a/examples/PACKAGES/reaction/tiny_nylon/rxn1_stp2_reacted.data_template b/examples/PACKAGES/reaction/tiny_nylon/rxn1_stp2_reacted.data_template deleted file mode 100644 index 7853634646..0000000000 --- a/examples/PACKAGES/reaction/tiny_nylon/rxn1_stp2_reacted.data_template +++ /dev/null @@ -1,131 +0,0 @@ -this is a molecule template for: water condensation, post-reacting - -15 atoms -13 bonds -19 angles -16 dihedrals -10 impropers - -Types - -1 9 -2 1 -3 1 -4 10 -5 8 -6 4 -7 4 -8 1 -9 1 -10 2 -11 6 -12 11 -13 4 -14 4 -15 10 - -Charges - -1 -0.300000 -2 0.000000 -3 0.000000 -4 0.410000 -5 0.000000 -6 0.000000 -7 0.000000 -8 0.000000 -9 0.000000 -10 0.300000 -11 0.000000 -12 -0.820000 -13 0.000000 -14 0.000000 -15 0.410000 - -Coords - -1 -4.856280 -1.050468 1.432625 -2 -5.047195 -0.935267 -0.358173 -3 -6.526281 -0.755366 -0.743523 -4 -5.282604 0.020447 1.552710 -5 -3.860697 -1.095850 1.428305 -6 -4.662382 -1.920900 -0.781524 -7 -4.433977 -0.072765 -0.784071 -8 -5.506279 0.202610 4.825816 -9 -4.449177 -0.844592 4.423366 -10 -4.103916 -0.749629 2.925195 -11 -3.376249 -1.886171 2.245643 -12 -4.493235 0.477214 2.137199 -13 -4.849053 -1.888877 4.663994 -14 -3.491823 -0.662913 5.018510 -15 -5.020777 1.189745 2.805427 - -Bonds - -1 11 1 2 -2 12 1 5 -3 13 1 10 -4 2 2 3 -5 1 2 6 -6 1 2 7 -7 15 4 12 -8 2 8 9 -9 4 9 10 -10 1 9 13 -11 1 9 14 -12 5 10 11 -13 15 15 12 - -Angles - -1 17 2 1 5 -2 18 2 1 10 -3 20 5 1 10 -4 21 1 2 3 -5 22 1 2 6 -6 22 1 2 7 -7 2 3 2 6 -8 2 3 2 7 -9 1 6 2 7 -10 8 8 9 10 -11 2 8 9 13 -12 2 8 9 14 -13 23 13 9 10 -14 23 14 9 10 -15 1 13 9 14 -16 6 9 10 11 -17 24 1 10 9 -18 26 1 10 11 -19 29 15 12 4 - -Dihedrals - -1 19 5 1 2 3 -2 20 5 1 2 6 -3 20 5 1 2 7 -4 21 10 1 2 3 -5 22 10 1 2 6 -6 22 10 1 2 7 -7 23 2 1 10 9 -8 24 2 1 10 11 -9 26 5 1 10 9 -10 27 5 1 10 11 -11 10 8 9 10 11 -12 31 8 9 10 1 -13 11 13 9 10 11 -14 32 13 9 10 1 -15 11 14 9 10 11 -16 32 14 9 10 1 - -Impropers - -1 12 2 1 5 10 -2 13 1 10 9 11 -3 1 1 2 3 6 -4 1 1 2 3 7 -5 1 1 2 6 7 -6 1 3 2 6 7 -7 1 8 9 13 10 -8 1 8 9 14 10 -9 1 8 9 13 14 -10 1 13 9 14 10 diff --git a/examples/PACKAGES/reaction/tiny_nylon/rxn1_stp2_reacted.molecule_template b/examples/PACKAGES/reaction/tiny_nylon/rxn1_stp2_reacted.molecule_template new file mode 100644 index 0000000000..2e91261468 --- /dev/null +++ b/examples/PACKAGES/reaction/tiny_nylon/rxn1_stp2_reacted.molecule_template @@ -0,0 +1,141 @@ +this is a molecule template for: water condensation, post-reacting + + 15 atoms + 13 bonds + 19 angles + 16 dihedrals + 2 impropers + +Coords + + 1 -4.856280281 -1.050467974 1.432625159 + 2 -5.047194816 -0.935266843 -0.358172771 + 3 -6.526281447 -0.755365854 -0.743523227 + 4 -5.282604074 0.020446894 1.552710361 + 5 -3.860696509 -1.095850190 1.428304925 + 6 -4.662381862 -1.920899862 -0.781524026 + 7 -4.433976540 -0.072765142 -0.784070641 + 8 -5.506279186 0.202610302 4.825815562 + 9 -4.449176624 -0.844592213 4.423366146 + 10 -4.103915981 -0.749628655 2.925195217 + 11 -3.376248536 -1.886171498 2.245643443 + 12 -4.493235430 0.477213651 2.137199034 + 13 -4.849052953 -1.888876753 4.663993750 + 14 -3.491822950 -0.662913310 5.018510248 + 15 -5.020776528 1.189745133 2.805427194 + +Types + + 1 n + 2 c2 + 3 c2 + 4 hw + 5 hn + 6 hc + 7 hc + 8 c2 + 9 c2 + 10 c_1 + 11 o_1 + 12 o* + 13 hc + 14 hc + 15 hw + +Charges + + 1 -0.300000 + 2 0.000000 + 3 0.000000 + 4 0.410000 + 5 0.000000 + 6 0.000000 + 7 0.000000 + 8 0.000000 + 9 0.000000 + 10 0.300000 + 11 0.000000 + 12 -0.820000 + 13 0.000000 + 14 0.000000 + 15 0.410000 + +Molecules + + 1 1 + 2 1 + 3 1 + 4 1 + 5 1 + 6 1 + 7 1 + 8 1 + 9 1 + 10 1 + 11 1 + 12 1 + 13 1 + 14 1 + 15 1 + +Bonds + + 1 n-c2 1 2 + 2 n-hn 1 5 + 3 n-c_1 1 10 + 4 c2-c2 2 3 + 5 c2-hc 2 6 + 6 c2-hc 2 7 + 7 hw-o* 4 12 + 8 c2-c2 8 9 + 9 c2-c_1 9 10 + 10 c2-hc 9 13 + 11 c2-hc 9 14 + 12 c_1-o_1 10 11 + 13 hw-o* 15 12 + +Angles + + 1 c2-n-hn 2 1 5 + 2 c2-n-c_1 2 1 10 + 3 hn-n-c_1 5 1 10 + 4 n-c2-c2 1 2 3 + 5 n-c2-hc 1 2 6 + 6 n-c2-hc 1 2 7 + 7 c2-c2-hc 3 2 6 + 8 c2-c2-hc 3 2 7 + 9 hc-c2-hc 6 2 7 + 10 c2-c2-c_1 8 9 10 + 11 c2-c2-hc 8 9 13 + 12 c2-c2-hc 8 9 14 + 13 hc-c2-c_1 13 9 10 + 14 hc-c2-c_1 14 9 10 + 15 hc-c2-hc 13 9 14 + 16 c2-c_1-o_1 9 10 11 + 17 n-c_1-c2 1 10 9 + 18 n-c_1-o_1 1 10 11 + 19 hw-o*-hw 15 12 4 + +Dihedrals + + 1 hn-n-c2-c2 5 1 2 3 + 2 hn-n-c2-hc 5 1 2 6 + 3 hn-n-c2-hc 5 1 2 7 + 4 c_1-n-c2-c2 10 1 2 3 + 5 c_1-n-c2-hc 10 1 2 6 + 6 c_1-n-c2-hc 10 1 2 7 + 7 c2-n-c_1-c2 2 1 10 9 + 8 c2-n-c_1-o_1 2 1 10 11 + 9 hn-n-c_1-c2 5 1 10 9 + 10 hn-n-c_1-o_1 5 1 10 11 + 11 c2-c2-c_1-o_1 8 9 10 11 + 12 c2-c2-c_1-n 8 9 10 1 + 13 hc-c2-c_1-o_1 13 9 10 11 + 14 hc-c2-c_1-n 13 9 10 1 + 15 hc-c2-c_1-o_1 14 9 10 11 + 16 hc-c2-c_1-n 14 9 10 1 + +Impropers + + 1 c2-n-hn-c_1 2 1 5 10 + 2 n-c_1-c2-o_1 1 10 9 11 diff --git a/examples/PACKAGES/reaction/tiny_nylon/rxn1_stp2_unreacted.data_template b/examples/PACKAGES/reaction/tiny_nylon/rxn1_stp2_unreacted.data_template deleted file mode 100644 index 847f0622e5..0000000000 --- a/examples/PACKAGES/reaction/tiny_nylon/rxn1_stp2_unreacted.data_template +++ /dev/null @@ -1,158 +0,0 @@ -this is a molecule template for: water condensation, pre-reacting - -15 atoms -14 bonds -25 angles -30 dihedrals -16 impropers - -Types - -1 9 -2 1 -3 1 -4 8 -5 8 -6 4 -7 4 -8 1 -9 1 -10 2 -11 6 -12 3 -13 4 -14 4 -15 5 - -Charges - -1 -0.300000 -2 0.000000 -3 0.000000 -4 0.000000 -5 0.000000 -6 0.000000 -7 0.000000 -8 0.000000 -9 0.000000 -10 0.300000 -11 0.000000 -12 0.000000 -13 0.000000 -14 0.000000 -15 0.000000 - -Coords - -1 -4.922858 -0.946982 1.146055 -2 -5.047195 -0.935267 -0.358173 -3 -6.526281 -0.755366 -0.743523 -4 -5.282604 0.020447 1.552710 -5 -3.860697 -1.095850 1.428305 -6 -4.662382 -1.920900 -0.781524 -7 -4.433977 -0.072765 -0.784071 -8 -5.506279 0.202610 4.825816 -9 -4.449177 -0.844592 4.423366 -10 -4.103916 -0.749629 2.925195 -11 -3.376249 -1.886171 2.245643 -12 -4.493235 0.477214 2.137199 -13 -4.849053 -1.888877 4.663994 -14 -3.491823 -0.662913 5.018510 -15 -5.020777 1.189745 2.805427 - -Bonds - -1 11 1 2 -2 12 1 4 -3 12 1 5 -4 13 1 10 -5 2 2 3 -6 1 2 6 -7 1 2 7 -8 2 8 9 -9 4 9 10 -10 1 9 13 -11 1 9 14 -12 5 10 11 -13 3 10 12 -14 6 12 15 - -Angles - -1 17 2 1 4 -2 17 2 1 5 -3 18 2 1 10 -4 19 4 1 5 -5 20 4 1 10 -6 20 5 1 10 -7 21 1 2 3 -8 22 1 2 6 -9 22 1 2 7 -10 2 3 2 6 -11 2 3 2 7 -12 1 6 2 7 -13 8 8 9 10 -14 2 8 9 13 -15 2 8 9 14 -16 23 13 9 10 -17 23 14 9 10 -18 1 13 9 14 -19 6 9 10 11 -20 4 9 10 12 -21 24 1 10 9 -22 25 11 10 12 -23 26 1 10 11 -24 27 1 10 12 -25 7 10 12 15 - -Dihedrals - -1 19 4 1 2 3 -2 20 4 1 2 6 -3 20 4 1 2 7 -4 19 5 1 2 3 -5 20 5 1 2 6 -6 20 5 1 2 7 -7 21 10 1 2 3 -8 22 10 1 2 6 -9 22 10 1 2 7 -10 23 2 1 10 9 -11 24 2 1 10 11 -12 25 2 1 10 12 -13 26 4 1 10 9 -14 27 4 1 10 11 -15 28 4 1 10 12 -16 26 5 1 10 9 -17 27 5 1 10 11 -18 28 5 1 10 12 -19 10 8 9 10 11 -20 8 8 9 10 12 -21 31 8 9 10 1 -22 11 13 9 10 11 -23 9 13 9 10 12 -24 32 13 9 10 1 -25 11 14 9 10 11 -26 9 14 9 10 12 -27 32 14 9 10 1 -28 6 9 10 12 15 -29 7 11 10 12 15 -30 33 1 10 12 15 - -Impropers - -1 1 2 1 4 5 -2 1 2 1 4 10 -3 1 2 1 5 10 -4 1 4 1 5 10 -5 1 1 2 3 6 -6 1 1 2 3 7 -7 1 1 2 6 7 -8 1 3 2 6 7 -9 1 8 9 13 10 -10 1 8 9 14 10 -11 1 8 9 13 14 -12 1 13 9 14 10 -13 1 9 10 11 12 -14 1 1 10 9 11 -15 1 1 10 9 12 -16 1 1 10 11 12 diff --git a/examples/PACKAGES/reaction/tiny_nylon/rxn1_stp2_unreacted.molecule_template b/examples/PACKAGES/reaction/tiny_nylon/rxn1_stp2_unreacted.molecule_template new file mode 100644 index 0000000000..86a772634d --- /dev/null +++ b/examples/PACKAGES/reaction/tiny_nylon/rxn1_stp2_unreacted.molecule_template @@ -0,0 +1,157 @@ +this is a molecule template for: water condensation, pre-reacting + + 15 atoms + 14 bonds + 25 angles + 30 dihedrals + 0 impropers + +Coords + + 1 -4.922858499 -0.946981747 1.146055346 + 2 -5.047194816 -0.935266843 -0.358172771 + 3 -6.526281447 -0.755365854 -0.743523227 + 4 -5.282604074 0.020446894 1.552710361 + 5 -3.860696509 -1.095850190 1.428304925 + 6 -4.662381862 -1.920899862 -0.781524026 + 7 -4.433976540 -0.072765142 -0.784070641 + 8 -5.506279186 0.202610302 4.825815562 + 9 -4.449176624 -0.844592213 4.423366146 + 10 -4.103915981 -0.749628655 2.925195217 + 11 -3.376248536 -1.886171498 2.245643443 + 12 -4.493235430 0.477213651 2.137199034 + 13 -4.849052953 -1.888876753 4.663993750 + 14 -3.491822950 -0.662913310 5.018510248 + 15 -5.020776528 1.189745133 2.805427194 + +Types + + 1 n + 2 c2 + 3 c2 + 4 hn + 5 hn + 6 hc + 7 hc + 8 c2 + 9 c2 + 10 c_1 + 11 o_1 + 12 o + 13 hc + 14 hc + 15 ho + +Charges + + 1 -0.300000 + 2 0.000000 + 3 0.000000 + 4 0.000000 + 5 0.000000 + 6 0.000000 + 7 0.000000 + 8 0.000000 + 9 0.000000 + 10 0.300000 + 11 0.000000 + 12 0.000000 + 13 0.000000 + 14 0.000000 + 15 0.000000 + +Molecules + + 1 1 + 2 1 + 3 1 + 4 1 + 5 1 + 6 1 + 7 1 + 8 1 + 9 1 + 10 1 + 11 1 + 12 1 + 13 1 + 14 1 + 15 1 + +Bonds + + 1 n-c2 1 2 + 2 n-hn 1 4 + 3 n-hn 1 5 + 4 n-c_1 1 10 + 5 c2-c2 2 3 + 6 c2-hc 2 6 + 7 c2-hc 2 7 + 8 c2-c2 8 9 + 9 c2-c_1 9 10 + 10 c2-hc 9 13 + 11 c2-hc 9 14 + 12 c_1-o_1 10 11 + 13 c_1-o 10 12 + 14 o-ho 12 15 + +Angles + + 1 c2-n-hn 2 1 4 + 2 c2-n-hn 2 1 5 + 3 c2-n-c_1 2 1 10 + 4 hn-n-hn 4 1 5 + 5 hn-n-c_1 4 1 10 + 6 hn-n-c_1 5 1 10 + 7 n-c2-c2 1 2 3 + 8 n-c2-hc 1 2 6 + 9 n-c2-hc 1 2 7 + 10 c2-c2-hc 3 2 6 + 11 c2-c2-hc 3 2 7 + 12 hc-c2-hc 6 2 7 + 13 c2-c2-c_1 8 9 10 + 14 c2-c2-hc 8 9 13 + 15 c2-c2-hc 8 9 14 + 16 hc-c2-c_1 13 9 10 + 17 hc-c2-c_1 14 9 10 + 18 hc-c2-hc 13 9 14 + 19 c2-c_1-o_1 9 10 11 + 20 c2-c_1-o 9 10 12 + 21 n-c_1-c2 1 10 9 + 22 o_1-c_1-o 11 10 12 + 23 n-c_1-o_1 1 10 11 + 24 n-c_1-o 1 10 12 + 25 c_1-o-ho 10 12 15 + +Dihedrals + + 1 hn-n-c2-c2 4 1 2 3 + 2 hn-n-c2-hc 4 1 2 6 + 3 hn-n-c2-hc 4 1 2 7 + 4 hn-n-c2-c2 5 1 2 3 + 5 hn-n-c2-hc 5 1 2 6 + 6 hn-n-c2-hc 5 1 2 7 + 7 c_1-n-c2-c2 10 1 2 3 + 8 c_1-n-c2-hc 10 1 2 6 + 9 c_1-n-c2-hc 10 1 2 7 + 10 c2-n-c_1-c2 2 1 10 9 + 11 c2-n-c_1-o_1 2 1 10 11 + 12 c2-n-c_1-o 2 1 10 12 + 13 hn-n-c_1-c2 4 1 10 9 + 14 hn-n-c_1-o_1 4 1 10 11 + 15 hn-n-c_1-o 4 1 10 12 + 16 hn-n-c_1-c2 5 1 10 9 + 17 hn-n-c_1-o_1 5 1 10 11 + 18 hn-n-c_1-o 5 1 10 12 + 19 c2-c2-c_1-o_1 8 9 10 11 + 20 c2-c2-c_1-o 8 9 10 12 + 21 c2-c2-c_1-n 8 9 10 1 + 22 hc-c2-c_1-o_1 13 9 10 11 + 23 hc-c2-c_1-o 13 9 10 12 + 24 hc-c2-c_1-n 13 9 10 1 + 25 hc-c2-c_1-o_1 14 9 10 11 + 26 hc-c2-c_1-o 14 9 10 12 + 27 hc-c2-c_1-n 14 9 10 1 + 28 c2-c_1-o-ho 9 10 12 15 + 29 o_1-c_1-o-ho 11 10 12 15 + 30 n-c_1-o-ho 1 10 12 15 diff --git a/examples/PACKAGES/reaction/tiny_nylon/tiny_nylon.data b/examples/PACKAGES/reaction/tiny_nylon/tiny_nylon.data index 8466e68ea5..ee8e397956 100644 --- a/examples/PACKAGES/reaction/tiny_nylon/tiny_nylon.data +++ b/examples/PACKAGES/reaction/tiny_nylon/tiny_nylon.data @@ -10,16 +10,130 @@ this is LAMMPS data file containing two nylon monomers 36 dihedral types 44 impropers 13 improper types -5 extra bond per atom -15 extra angle per atom -15 extra dihedral per atom -25 extra improper per atom -25 extra special per atom -25 25 xlo xhi -25 25 ylo yhi -25 25 zlo zhi +Atom Type Labels + +1 c2 +2 c_1 +3 o +4 hc +5 ho +6 o_1 +7 na +8 hn +9 n +10 hw +11 o* + +Bond Type Labels + +1 c2-hc +2 c2-c2 +3 c_1-o +4 c2-c_1 +5 c_1-o_1 +6 o-ho +7 c2-c2-repeat +8 c2-hc-repeat +9 na-c2 +10 na-hn +11 n-c2 +12 n-hn +13 n-c_1 +14 c2-na +15 hw-o* + +Angle Type Labels + +1 hc-c2-hc +2 c2-c2-hc +3 c2-c2-c2 +4 c2-c_1-o_1 +5 o-c_1-o_1 +6 c2-c_1-o +7 c_1-o-ho +8 c2-c2-c_1 +9 c_1-c2-hc +10 c2-c2-hc-repeat +11 c2-c2-c2-repeat +12 hc-c2-hc-repeat +13 c2-c2-na +14 na-c2-hc +15 c2-na-hn +16 hn-na-hn +17 c2-n-hn +18 c2-n-c_1 +19 hn-n-hn +20 hn-n-c_1 +21 n-c2-c2 +22 n-c2-hc +23 hc-c2-c_1 +24 n-c_1-c2 +25 o_1-c_1-o +26 n-c_1-o_1 +27 n-c_1-o +28 na-c2-c2 +29 hw-o*-hw + +Dihedral Type Labels + +1 c_1-c2-c2-hc +2 hc-c2-c2-hc +3 c2-c2-c2-c_1 +4 c2-c2-c2-hc +5 c2-c2-c2-c2 +6 c2-c_1-o-ho +7 o_1-c_1-o-ho +8 c2-c2-c_1-o +9 hc-c2-c_1-o +10 c2-c2-c_1-o_1 +11 hc-c2-c_1-o_1 +12 na-c2-c2-hc +13 hc-c2-c2-hc-repeat +14 c2-c2-c2-na +15 c2-c2-c2-hc-repeat +16 c2-c2-c2-c2-repeat +17 c2-c2-na-hn +18 hn-na-c2-hc +19 hn-n-c2-c2 +20 hn-n-c2-hc +21 c_1-n-c2-c2 +22 c_1-n-c2-hc +23 c2-n-c_1-c2 +24 c2-n-c_1-o_1 +25 c2-n-c_1-o +26 hn-n-c_1-c2 +27 hn-n-c_1-o_1 +28 hn-n-c_1-o +29 n-c2-c2-c2 +30 n-c2-c2-hc +31 c2-c2-c_1-n +32 hc-c2-c_1-n +33 n-c_1-o-ho +34 hn-na-c2-c2 +35 hc-c2-na-hn +36 na-c2-c2-c2 + +Improper Type Labels + +1 c2-c_1-o-o_1 +2 c2-na-hn-hn +3 c2-c_1-o_1-o +4 c2-n-hn-c_1 +5 zero5 +6 zero6 +7 zero7 +8 zero8 +9 zero9 +10 zero10 +11 zero11 +12 zero12 +13 n-c_1-c2-o_1 + Masses 1 12.0112 @@ -94,7 +208,7 @@ Angle Coeffs # class2 24 116.926 39.4193 -10.9945 -8.7733 25 118.986 98.6813 -22.2485 10.3673 26 125.542 92.572 -34.48 -11.1871 -27 0 0 0 0 +27 125.542 92.572 -34.48 -11.1871 28 111.91 60.7147 -13.3366 -13.0785 29 103.7 49.84 -11.6 -8 diff --git a/examples/PACKAGES/reaction/tiny_polystyrene/2styrene_reacted.data_template b/examples/PACKAGES/reaction/tiny_polystyrene/2styrene_reacted.data_template deleted file mode 100644 index c4fa646e9f..0000000000 --- a/examples/PACKAGES/reaction/tiny_polystyrene/2styrene_reacted.data_template +++ /dev/null @@ -1,312 +0,0 @@ -2styrene_reacted - -32 atoms -33 bonds -54 angles -79 dihedrals -22 impropers - -Types - -1 1 -2 2 -3 1 -4 5 -5 1 -6 2 -7 1 -8 2 -9 1 -10 2 -11 1 -12 2 -13 2 -14 6 -15 2 -16 2 -17 1 -18 2 -19 1 -20 5 -21 1 -22 2 -23 1 -24 2 -25 1 -26 2 -27 1 -28 2 -29 2 -30 6 -31 2 -32 2 - -Charges - -1 -0.129000 -2 0.123700 -3 0.026600 -4 -0.018200 -5 -0.129000 -6 0.123700 -7 -0.173400 -8 0.140300 -9 -0.113400 -10 0.128800 -11 -0.173400 -12 0.140300 -13 0.051600 -14 -0.069600 -15 0.035400 -16 0.035400 -17 -0.129000 -18 0.123700 -19 0.026600 -20 -0.018200 -21 -0.129000 -22 0.123700 -23 -0.173400 -24 0.140300 -25 -0.113400 -26 0.128800 -27 -0.173400 -28 0.140300 -29 0.051600 -30 -0.069600 -31 0.035400 -32 0.035400 - -Coords - -1 13.465810 0.682530 -1.658940 -2 14.397820 1.221530 -1.658940 -3 12.235820 1.392530 -1.658940 -4 12.235820 2.892530 -1.658940 -5 11.005820 0.682530 -1.658940 -6 10.073820 1.221530 -1.658940 -7 11.005820 -0.737470 -1.658940 -8 10.073820 -1.276460 -1.658940 -9 12.235820 -1.447460 -1.658940 -10 12.235820 -2.524470 -1.658940 -11 13.465810 -0.737470 -1.658940 -12 14.397820 -1.276460 -1.658940 -13 13.101820 3.297530 -1.301940 -14 10.957820 3.441530 -2.220940 -15 11.007810 4.183540 -2.319940 -16 10.314820 2.618530 -2.514940 -17 18.663521 0.855480 -1.372130 -18 19.595510 1.394480 -1.372130 -19 17.433510 1.565480 -1.372130 -20 17.433510 3.065480 -1.372130 -21 16.203510 0.855480 -1.372130 -22 15.271510 1.394480 -1.372130 -23 16.203510 -0.564520 -1.372130 -24 15.271510 -1.103520 -1.372130 -25 17.433510 -1.274520 -1.372130 -26 17.433510 -2.351520 -1.372130 -27 18.663521 -0.564520 -1.372130 -28 19.595510 -1.103520 -1.372130 -29 18.299509 3.470480 -1.015130 -30 16.155510 3.614480 -1.934130 -31 16.205509 4.356480 -2.033130 -32 15.512510 2.791480 -2.228130 - -Bonds - -1 1 1 2 -2 2 1 3 -3 2 1 11 -4 7 3 4 -5 2 3 5 -6 8 13 4 -7 9 4 14 -8 9 4 30 -9 1 5 6 -10 2 5 7 -11 1 7 8 -12 2 7 9 -13 1 9 10 -14 2 9 11 -15 1 11 12 -16 10 15 14 -17 10 16 14 -18 1 17 18 -19 2 17 19 -20 2 17 27 -21 7 19 20 -22 2 19 21 -23 8 29 20 -24 9 20 30 -25 1 21 22 -26 2 21 23 -27 1 23 24 -28 2 23 25 -29 1 25 26 -30 2 25 27 -31 1 27 28 -32 10 31 30 -33 10 32 30 - -Angles - -1 1 3 1 2 -2 1 11 1 2 -3 2 3 1 11 -4 9 1 3 4 -5 2 1 3 5 -6 9 5 3 4 -7 10 3 4 13 -8 11 3 4 14 -9 11 3 4 30 -10 12 13 4 14 -11 12 13 4 30 -12 13 14 4 30 -13 1 3 5 6 -14 2 3 5 7 -15 1 7 5 6 -16 1 5 7 8 -17 2 5 7 9 -18 1 9 7 8 -19 1 7 9 10 -20 2 7 9 11 -21 1 11 9 10 -22 2 1 11 9 -23 1 1 11 12 -24 1 9 11 12 -25 14 15 14 4 -26 14 16 14 4 -27 15 15 14 16 -28 1 19 17 18 -29 1 27 17 18 -30 2 19 17 27 -31 9 17 19 20 -32 2 17 19 21 -33 9 21 19 20 -34 10 19 20 29 -35 11 19 20 30 -36 12 29 20 30 -37 1 19 21 22 -38 2 19 21 23 -39 1 23 21 22 -40 1 21 23 24 -41 2 21 23 25 -42 1 25 23 24 -43 1 23 25 26 -44 2 23 25 27 -45 1 27 25 26 -46 2 17 27 25 -47 1 17 27 28 -48 1 25 27 28 -49 16 4 30 20 -50 14 31 30 4 -51 14 32 30 4 -52 14 31 30 20 -53 14 32 30 20 -54 15 31 30 32 - -Dihedrals - -1 10 2 1 3 4 -2 2 5 3 1 2 -3 11 11 1 3 4 -4 4 11 1 3 5 -5 2 9 11 1 2 -6 5 2 1 11 12 -7 4 3 1 11 9 -8 2 3 1 11 12 -9 12 1 3 4 13 -10 13 1 3 4 14 -11 13 1 3 4 30 -12 12 5 3 4 13 -13 13 5 3 4 14 -14 13 5 3 4 30 -15 2 1 3 5 6 -16 4 1 3 5 7 -17 10 6 5 3 4 -18 11 7 5 3 4 -19 14 3 4 14 15 -20 14 3 4 14 16 -21 15 13 4 14 15 -22 15 13 4 14 16 -23 16 30 4 14 15 -24 16 30 4 14 16 -25 17 3 4 30 20 -26 14 3 4 30 31 -27 14 3 4 30 32 -28 18 13 4 30 20 -29 15 13 4 30 31 -30 15 13 4 30 32 -31 19 14 4 30 20 -32 16 14 4 30 31 -33 16 14 4 30 32 -34 2 3 5 7 8 -35 4 3 5 7 9 -36 5 6 5 7 8 -37 2 9 7 5 6 -38 2 5 7 9 10 -39 4 5 7 9 11 -40 5 8 7 9 10 -41 2 11 9 7 8 -42 4 7 9 11 1 -43 2 7 9 11 12 -44 2 1 11 9 10 -45 5 10 9 11 12 -46 10 18 17 19 20 -47 2 21 19 17 18 -48 11 27 17 19 20 -49 4 27 17 19 21 -50 2 25 27 17 18 -51 5 18 17 27 28 -52 4 19 17 27 25 -53 2 19 17 27 28 -54 12 17 19 20 29 -55 13 17 19 20 30 -56 12 21 19 20 29 -57 13 21 19 20 30 -58 2 17 19 21 22 -59 4 17 19 21 23 -60 10 22 21 19 20 -61 11 23 21 19 20 -62 17 19 20 30 4 -63 14 19 20 30 31 -64 14 19 20 30 32 -65 18 29 20 30 4 -66 15 29 20 30 31 -67 15 29 20 30 32 -68 2 19 21 23 24 -69 4 19 21 23 25 -70 5 22 21 23 24 -71 2 25 23 21 22 -72 2 21 23 25 26 -73 4 21 23 25 27 -74 5 24 23 25 26 -75 2 27 25 23 24 -76 4 23 25 27 17 -77 2 23 25 27 28 -78 2 17 27 25 26 -79 5 26 25 27 28 - -Impropers - -1 1 3 1 11 2 -2 5 1 3 5 4 -3 1 3 5 7 6 -4 1 5 7 9 8 -5 1 7 9 11 10 -6 1 1 11 9 12 -7 6 15 14 16 4 -8 1 19 17 27 18 -9 5 17 19 21 20 -10 7 19 20 29 30 -11 1 19 21 23 22 -12 1 21 23 25 24 -13 1 23 25 27 26 -14 1 17 27 25 28 -15 1 3 4 13 14 -16 1 3 4 13 30 -17 1 3 4 14 30 -18 1 13 4 14 30 -19 1 31 30 20 4 -20 1 32 30 20 4 -21 1 31 30 32 4 -22 1 31 30 32 20 diff --git a/examples/PACKAGES/reaction/tiny_polystyrene/2styrene_reacted.molecule_template b/examples/PACKAGES/reaction/tiny_polystyrene/2styrene_reacted.molecule_template new file mode 100644 index 0000000000..a321d5f6bb --- /dev/null +++ b/examples/PACKAGES/reaction/tiny_polystyrene/2styrene_reacted.molecule_template @@ -0,0 +1,339 @@ +2styrene_reacted + + 32 atoms + 33 bonds + 54 angles + 79 dihedrals + 14 impropers + +Coords + + 1 13.465809822 0.682529986 -1.658939958 + 2 14.397820473 1.221529961 -1.658939958 + 3 12.235819817 1.392529964 -1.658939958 + 4 12.235819817 2.892529964 -1.658939958 + 5 11.005820274 0.682529986 -1.658939958 + 6 10.073820114 1.221529961 -1.658939958 + 7 11.005820274 -0.737469971 -1.658939958 + 8 10.073820114 -1.276460052 -1.658939958 + 9 12.235819817 -1.447460055 -1.658939958 + 10 12.235819817 -2.524470091 -1.658939958 + 11 13.465809822 -0.737469971 -1.658939958 + 12 14.397820473 -1.276460052 -1.658939958 + 13 13.101819992 3.297529936 -1.301939964 + 14 10.957819939 3.441529989 -2.220940113 + 15 11.007809639 4.183539867 -2.319940090 + 16 10.314820290 2.618530035 -2.514940023 + 17 18.663520813 0.855480015 -1.372130036 + 18 19.595510483 1.394479990 -1.372130036 + 19 17.433509827 1.565479994 -1.372130036 + 20 17.433509827 3.065479994 -1.372130036 + 21 16.203510284 0.855480015 -1.372130036 + 22 15.271510124 1.394479990 -1.372130036 + 23 16.203510284 -0.564520001 -1.372130036 + 24 15.271510124 -1.103520036 -1.372130036 + 25 17.433509827 -1.274520040 -1.372130036 + 26 17.433509827 -2.351520061 -1.372130036 + 27 18.663520813 -0.564520001 -1.372130036 + 28 19.595510483 -1.103520036 -1.372130036 + 29 18.299509048 3.470479965 -1.015130043 + 30 16.155509949 3.614480019 -1.934129953 + 31 16.205509186 4.356480122 -2.033129930 + 32 15.512510300 2.791480064 -2.228130102 + +Types + + 1 cp + 2 hc + 3 cp + 4 c1 + 5 cp + 6 hc + 7 cp + 8 hc + 9 cp + 10 hc + 11 cp + 12 hc + 13 hc + 14 c2 + 15 hc + 16 hc + 17 cp + 18 hc + 19 cp + 20 c1 + 21 cp + 22 hc + 23 cp + 24 hc + 25 cp + 26 hc + 27 cp + 28 hc + 29 hc + 30 c2 + 31 hc + 32 hc + +Charges + + 1 -0.129000 + 2 0.123700 + 3 0.026600 + 4 -0.018200 + 5 -0.129000 + 6 0.123700 + 7 -0.173400 + 8 0.140300 + 9 -0.113400 + 10 0.128800 + 11 -0.173400 + 12 0.140300 + 13 0.051600 + 14 -0.069600 + 15 0.035400 + 16 0.035400 + 17 -0.129000 + 18 0.123700 + 19 0.026600 + 20 -0.018200 + 21 -0.129000 + 22 0.123700 + 23 -0.173400 + 24 0.140300 + 25 -0.113400 + 26 0.128800 + 27 -0.173400 + 28 0.140300 + 29 0.051600 + 30 -0.069600 + 31 0.035400 + 32 0.035400 + +Molecules + + 1 1 + 2 1 + 3 1 + 4 1 + 5 1 + 6 1 + 7 1 + 8 1 + 9 1 + 10 1 + 11 1 + 12 1 + 13 1 + 14 1 + 15 1 + 16 1 + 17 1 + 18 1 + 19 1 + 20 1 + 21 1 + 22 1 + 23 1 + 24 1 + 25 1 + 26 1 + 27 1 + 28 1 + 29 1 + 30 1 + 31 1 + 32 1 + +Bonds + + 1 cp-hc 1 2 + 2 cp-cp 1 3 + 3 cp-cp 1 11 + 4 cp-c1 3 4 + 5 cp-cp 3 5 + 6 hc-c1 13 4 + 7 c1-c2 4 14 + 8 c1-c2 4 30 + 9 cp-hc 5 6 + 10 cp-cp 5 7 + 11 cp-hc 7 8 + 12 cp-cp 7 9 + 13 cp-hc 9 10 + 14 cp-cp 9 11 + 15 cp-hc 11 12 + 16 hc-c2 15 14 + 17 hc-c2 16 14 + 18 cp-hc 17 18 + 19 cp-cp 17 19 + 20 cp-cp 17 27 + 21 cp-c1 19 20 + 22 cp-cp 19 21 + 23 hc-c1 29 20 + 24 c1-c2 20 30 + 25 cp-hc 21 22 + 26 cp-cp 21 23 + 27 cp-hc 23 24 + 28 cp-cp 23 25 + 29 cp-hc 25 26 + 30 cp-cp 25 27 + 31 cp-hc 27 28 + 32 hc-c2 31 30 + 33 hc-c2 32 30 + +Angles + + 1 cp-cp-hc 3 1 2 + 2 cp-cp-hc 11 1 2 + 3 cp-cp-cp 3 1 11 + 4 cp-cp-c1 1 3 4 + 5 cp-cp-cp 1 3 5 + 6 cp-cp-c1 5 3 4 + 7 cp-c1-hc 3 4 13 + 8 cp-c1-c2 3 4 14 + 9 cp-c1-c2 3 4 30 + 10 hc-c1-c2 13 4 14 + 11 hc-c1-c2 13 4 30 + 12 c2-c1-c2 14 4 30 + 13 cp-cp-hc 3 5 6 + 14 cp-cp-cp 3 5 7 + 15 cp-cp-hc 7 5 6 + 16 cp-cp-hc 5 7 8 + 17 cp-cp-cp 5 7 9 + 18 cp-cp-hc 9 7 8 + 19 cp-cp-hc 7 9 10 + 20 cp-cp-cp 7 9 11 + 21 cp-cp-hc 11 9 10 + 22 cp-cp-cp 1 11 9 + 23 cp-cp-hc 1 11 12 + 24 cp-cp-hc 9 11 12 + 25 hc-c2-c1 15 14 4 + 26 hc-c2-c1 16 14 4 + 27 hc-c2-hc 15 14 16 + 28 cp-cp-hc 19 17 18 + 29 cp-cp-hc 27 17 18 + 30 cp-cp-cp 19 17 27 + 31 cp-cp-c1 17 19 20 + 32 cp-cp-cp 17 19 21 + 33 cp-cp-c1 21 19 20 + 34 cp-c1-hc 19 20 29 + 35 cp-c1-c2 19 20 30 + 36 hc-c1-c2 29 20 30 + 37 cp-cp-hc 19 21 22 + 38 cp-cp-cp 19 21 23 + 39 cp-cp-hc 23 21 22 + 40 cp-cp-hc 21 23 24 + 41 cp-cp-cp 21 23 25 + 42 cp-cp-hc 25 23 24 + 43 cp-cp-hc 23 25 26 + 44 cp-cp-cp 23 25 27 + 45 cp-cp-hc 27 25 26 + 46 cp-cp-cp 17 27 25 + 47 cp-cp-hc 17 27 28 + 48 cp-cp-hc 25 27 28 + 49 c1-c2-c1 4 30 20 + 50 hc-c2-c1 31 30 4 + 51 hc-c2-c1 32 30 4 + 52 hc-c2-c1 31 30 20 + 53 hc-c2-c1 32 30 20 + 54 hc-c2-hc 31 30 32 + +Dihedrals + + 1 hc-cp-cp-c1 2 1 3 4 + 2 cp-cp-cp-hc 5 3 1 2 + 3 cp-cp-cp-c1 11 1 3 4 + 4 cp-cp-cp-cp 11 1 3 5 + 5 cp-cp-cp-hc 9 11 1 2 + 6 hc-cp-cp-hc 2 1 11 12 + 7 cp-cp-cp-cp 3 1 11 9 + 8 cp-cp-cp-hc 3 1 11 12 + 9 cp-cp-c1-hc 1 3 4 13 + 10 cp-cp-c1-c2 1 3 4 14 + 11 cp-cp-c1-c2 1 3 4 30 + 12 cp-cp-c1-hc 5 3 4 13 + 13 cp-cp-c1-c2 5 3 4 14 + 14 cp-cp-c1-c2 5 3 4 30 + 15 cp-cp-cp-hc 1 3 5 6 + 16 cp-cp-cp-cp 1 3 5 7 + 17 hc-cp-cp-c1 6 5 3 4 + 18 cp-cp-cp-c1 7 5 3 4 + 19 cp-c1-c2-hc 3 4 14 15 + 20 cp-c1-c2-hc 3 4 14 16 + 21 hc-c1-c2-hc 13 4 14 15 + 22 hc-c1-c2-hc 13 4 14 16 + 23 c2-c1-c2-hc 30 4 14 15 + 24 c2-c1-c2-hc 30 4 14 16 + 25 cp-c1-c2-c1 3 4 30 20 + 26 cp-c1-c2-hc 3 4 30 31 + 27 cp-c1-c2-hc 3 4 30 32 + 28 hc-c1-c2-c1 13 4 30 20 + 29 hc-c1-c2-hc 13 4 30 31 + 30 hc-c1-c2-hc 13 4 30 32 + 31 c2-c1-c2-c1 14 4 30 20 + 32 c2-c1-c2-hc 14 4 30 31 + 33 c2-c1-c2-hc 14 4 30 32 + 34 cp-cp-cp-hc 3 5 7 8 + 35 cp-cp-cp-cp 3 5 7 9 + 36 hc-cp-cp-hc 6 5 7 8 + 37 cp-cp-cp-hc 9 7 5 6 + 38 cp-cp-cp-hc 5 7 9 10 + 39 cp-cp-cp-cp 5 7 9 11 + 40 hc-cp-cp-hc 8 7 9 10 + 41 cp-cp-cp-hc 11 9 7 8 + 42 cp-cp-cp-cp 7 9 11 1 + 43 cp-cp-cp-hc 7 9 11 12 + 44 cp-cp-cp-hc 1 11 9 10 + 45 hc-cp-cp-hc 10 9 11 12 + 46 hc-cp-cp-c1 18 17 19 20 + 47 cp-cp-cp-hc 21 19 17 18 + 48 cp-cp-cp-c1 27 17 19 20 + 49 cp-cp-cp-cp 27 17 19 21 + 50 cp-cp-cp-hc 25 27 17 18 + 51 hc-cp-cp-hc 18 17 27 28 + 52 cp-cp-cp-cp 19 17 27 25 + 53 cp-cp-cp-hc 19 17 27 28 + 54 cp-cp-c1-hc 17 19 20 29 + 55 cp-cp-c1-c2 17 19 20 30 + 56 cp-cp-c1-hc 21 19 20 29 + 57 cp-cp-c1-c2 21 19 20 30 + 58 cp-cp-cp-hc 17 19 21 22 + 59 cp-cp-cp-cp 17 19 21 23 + 60 hc-cp-cp-c1 22 21 19 20 + 61 cp-cp-cp-c1 23 21 19 20 + 62 cp-c1-c2-c1 19 20 30 4 + 63 cp-c1-c2-hc 19 20 30 31 + 64 cp-c1-c2-hc 19 20 30 32 + 65 hc-c1-c2-c1 29 20 30 4 + 66 hc-c1-c2-hc 29 20 30 31 + 67 hc-c1-c2-hc 29 20 30 32 + 68 cp-cp-cp-hc 19 21 23 24 + 69 cp-cp-cp-cp 19 21 23 25 + 70 hc-cp-cp-hc 22 21 23 24 + 71 cp-cp-cp-hc 25 23 21 22 + 72 cp-cp-cp-hc 21 23 25 26 + 73 cp-cp-cp-cp 21 23 25 27 + 74 hc-cp-cp-hc 24 23 25 26 + 75 cp-cp-cp-hc 27 25 23 24 + 76 cp-cp-cp-cp 23 25 27 17 + 77 cp-cp-cp-hc 23 25 27 28 + 78 cp-cp-cp-hc 17 27 25 26 + 79 hc-cp-cp-hc 26 25 27 28 + +Impropers + + 1 cp-cp-cp-hc 3 1 11 2 + 2 cp-cp-cp-c1 1 3 5 4 + 3 cp-cp-cp-hc 3 5 7 6 + 4 cp-cp-cp-hc 5 7 9 8 + 5 cp-cp-cp-hc 7 9 11 10 + 6 cp-cp-cp-hc 1 11 9 12 + 7 hc-c2-hc-c1 15 14 16 4 + 8 cp-cp-cp-hc 19 17 27 18 + 9 cp-cp-cp-c1 17 19 21 20 + 10 cp-c1-hc-c2 19 20 29 30 + 11 cp-cp-cp-hc 19 21 23 22 + 12 cp-cp-cp-hc 21 23 25 24 + 13 cp-cp-cp-hc 23 25 27 26 + 14 cp-cp-cp-hc 17 27 25 28 diff --git a/examples/PACKAGES/reaction/tiny_polystyrene/2styrene_unreacted.data_template b/examples/PACKAGES/reaction/tiny_polystyrene/2styrene_unreacted.data_template deleted file mode 100644 index fc0a893191..0000000000 --- a/examples/PACKAGES/reaction/tiny_polystyrene/2styrene_unreacted.data_template +++ /dev/null @@ -1,284 +0,0 @@ -2styrene_unreacted - -32 atoms -32 bonds -48 angles -64 dihedrals -16 impropers - -Types - -1 1 -2 2 -3 1 -4 3 -5 1 -6 2 -7 1 -8 2 -9 1 -10 2 -11 1 -12 2 -13 2 -14 4 -15 2 -16 2 -17 1 -18 2 -19 1 -20 3 -21 1 -22 2 -23 1 -24 2 -25 1 -26 2 -27 1 -28 2 -29 2 -30 4 -31 2 -32 2 - -Charges - -1 -0.129000 -2 0.123700 -3 0.026600 -4 -0.018200 -5 -0.129000 -6 0.123700 -7 -0.173400 -8 0.140300 -9 -0.113400 -10 0.128800 -11 -0.173400 -12 0.140300 -13 0.051600 -14 -0.069600 -15 0.035400 -16 0.035400 -17 -0.129000 -18 0.123700 -19 0.026600 -20 -0.018200 -21 -0.129000 -22 0.123700 -23 -0.173400 -24 0.140300 -25 -0.113400 -26 0.128800 -27 -0.173400 -28 0.140300 -29 0.051600 -30 -0.069600 -31 0.035400 -32 0.035400 - -Coords - -1 13.465815 0.682534 -1.658941 -2 14.397816 1.221534 -1.658941 -3 12.235815 1.392534 -1.658941 -4 12.235815 2.892534 -1.658941 -5 11.005816 0.682534 -1.658941 -6 10.073815 1.221534 -1.658941 -7 11.005816 -0.737466 -1.658941 -8 10.073815 -1.276465 -1.658941 -9 12.235815 -1.447465 -1.658941 -10 12.235815 -2.524465 -1.658941 -11 13.465815 -0.737466 -1.658941 -12 14.397816 -1.276465 -1.658941 -13 13.101815 3.297535 -1.301941 -14 10.957815 3.441535 -2.220941 -15 11.007814 4.183536 -2.319941 -16 10.314816 2.618534 -2.514940 -17 18.663515 0.855482 -1.372128 -18 19.595514 1.394482 -1.372128 -19 17.433512 1.565481 -1.372128 -20 17.433512 3.065482 -1.372128 -21 16.203512 0.855482 -1.372128 -22 15.271511 1.394482 -1.372128 -23 16.203512 -0.564518 -1.372128 -24 15.271511 -1.103518 -1.372128 -25 17.433512 -1.274518 -1.372128 -26 17.433512 -2.351518 -1.372128 -27 18.663515 -0.564518 -1.372128 -28 19.595514 -1.103518 -1.372128 -29 18.299513 3.470482 -1.015128 -30 16.155512 3.614482 -1.934128 -31 16.205513 4.356482 -2.033128 -32 15.512512 2.791482 -2.228127 - -Bonds - -1 1 1 2 -2 2 1 3 -3 2 1 11 -4 3 3 4 -5 2 3 5 -6 4 13 4 -7 5 4 14 -8 1 5 6 -9 2 5 7 -10 1 7 8 -11 2 7 9 -12 1 9 10 -13 2 9 11 -14 1 11 12 -15 6 15 14 -16 6 16 14 -17 1 17 18 -18 2 17 19 -19 2 17 27 -20 3 19 20 -21 2 19 21 -22 4 29 20 -23 5 20 30 -24 1 21 22 -25 2 21 23 -26 1 23 24 -27 2 23 25 -28 1 25 26 -29 2 25 27 -30 1 27 28 -31 6 31 30 -32 6 32 30 - -Angles - -1 1 3 1 2 -2 1 11 1 2 -3 2 3 1 11 -4 3 1 3 4 -5 2 1 3 5 -6 3 5 3 4 -7 4 3 4 13 -8 5 3 4 14 -9 6 13 4 14 -10 1 3 5 6 -11 2 3 5 7 -12 1 7 5 6 -13 1 5 7 8 -14 2 5 7 9 -15 1 9 7 8 -16 1 7 9 10 -17 2 7 9 11 -18 1 11 9 10 -19 2 1 11 9 -20 1 1 11 12 -21 1 9 11 12 -22 7 15 14 4 -23 7 16 14 4 -24 8 15 14 16 -25 1 19 17 18 -26 1 27 17 18 -27 2 19 17 27 -28 3 17 19 20 -29 2 17 19 21 -30 3 21 19 20 -31 4 19 20 29 -32 5 19 20 30 -33 6 29 20 30 -34 1 19 21 22 -35 2 19 21 23 -36 1 23 21 22 -37 1 21 23 24 -38 2 21 23 25 -39 1 25 23 24 -40 1 23 25 26 -41 2 23 25 27 -42 1 27 25 26 -43 2 17 27 25 -44 1 17 27 28 -45 1 25 27 28 -46 7 31 30 20 -47 7 32 30 20 -48 8 31 30 32 - -Dihedrals - -1 1 2 1 3 4 -2 2 5 3 1 2 -3 3 11 1 3 4 -4 4 11 1 3 5 -5 2 9 11 1 2 -6 5 2 1 11 12 -7 4 3 1 11 9 -8 2 3 1 11 12 -9 6 1 3 4 13 -10 7 1 3 4 14 -11 6 5 3 4 13 -12 7 5 3 4 14 -13 2 1 3 5 6 -14 4 1 3 5 7 -15 1 6 5 3 4 -16 3 7 5 3 4 -17 8 3 4 14 15 -18 8 3 4 14 16 -19 9 13 4 14 15 -20 9 13 4 14 16 -21 2 3 5 7 8 -22 4 3 5 7 9 -23 5 6 5 7 8 -24 2 9 7 5 6 -25 2 5 7 9 10 -26 4 5 7 9 11 -27 5 8 7 9 10 -28 2 11 9 7 8 -29 4 7 9 11 1 -30 2 7 9 11 12 -31 2 1 11 9 10 -32 5 10 9 11 12 -33 1 18 17 19 20 -34 2 21 19 17 18 -35 3 27 17 19 20 -36 4 27 17 19 21 -37 2 25 27 17 18 -38 5 18 17 27 28 -39 4 19 17 27 25 -40 2 19 17 27 28 -41 6 17 19 20 29 -42 7 17 19 20 30 -43 6 21 19 20 29 -44 7 21 19 20 30 -45 2 17 19 21 22 -46 4 17 19 21 23 -47 1 22 21 19 20 -48 3 23 21 19 20 -49 8 19 20 30 31 -50 8 19 20 30 32 -51 9 29 20 30 31 -52 9 29 20 30 32 -53 2 19 21 23 24 -54 4 19 21 23 25 -55 5 22 21 23 24 -56 2 25 23 21 22 -57 2 21 23 25 26 -58 4 21 23 25 27 -59 5 24 23 25 26 -60 2 27 25 23 24 -61 4 23 25 27 17 -62 2 23 25 27 28 -63 2 17 27 25 26 -64 5 26 25 27 28 - -Impropers - -1 1 3 1 11 2 -2 2 1 3 5 4 -3 3 3 4 13 14 -4 1 3 5 7 6 -5 1 5 7 9 8 -6 1 7 9 11 10 -7 1 1 11 9 12 -8 4 15 14 16 4 -9 1 19 17 27 18 -10 2 17 19 21 20 -11 3 19 20 29 30 -12 1 19 21 23 22 -13 1 21 23 25 24 -14 1 23 25 27 26 -15 1 17 27 25 28 -16 4 31 30 32 20 diff --git a/examples/PACKAGES/reaction/tiny_polystyrene/2styrene_unreacted.molecule_template b/examples/PACKAGES/reaction/tiny_polystyrene/2styrene_unreacted.molecule_template new file mode 100644 index 0000000000..44d01d7582 --- /dev/null +++ b/examples/PACKAGES/reaction/tiny_polystyrene/2styrene_unreacted.molecule_template @@ -0,0 +1,319 @@ +2styrene_unreacted + + 32 atoms + 32 bonds + 48 angles + 64 dihedrals + 16 impropers + +Coords + + 1 13.465814590 0.682534277 -1.658940911 + 2 14.397815704 1.221534133 -1.658940911 + 3 12.235815048 1.392534137 -1.658940911 + 4 12.235815048 2.892534256 -1.658940911 + 5 11.005815506 0.682534277 -1.658940911 + 6 10.073815346 1.221534133 -1.658940911 + 7 11.005815506 -0.737465739 -1.658940911 + 8 10.073815346 -1.276464581 -1.658940911 + 9 12.235815048 -1.447464824 -1.658940911 + 10 12.235815048 -2.524465084 -1.658940911 + 11 13.465814590 -0.737465739 -1.658940911 + 12 14.397815704 -1.276464581 -1.658940911 + 13 13.101815224 3.297534943 -1.301940918 + 14 10.957815170 3.441534996 -2.220940590 + 15 11.007814407 4.183535576 -2.319940567 + 16 10.314815521 2.618533611 -2.514940262 + 17 18.663515091 0.855481565 -1.372127652 + 18 19.595514297 1.394481659 -1.372127652 + 19 17.433511734 1.565481424 -1.372127652 + 20 17.433511734 3.065481663 -1.372127652 + 21 16.203512192 0.855481565 -1.372127652 + 22 15.271511078 1.394481659 -1.372127652 + 23 16.203512192 -0.564518392 -1.372127652 + 24 15.271511078 -1.103518248 -1.372127652 + 25 17.433511734 -1.274518251 -1.372127652 + 26 17.433511734 -2.351518154 -1.372127652 + 27 18.663515091 -0.564518392 -1.372127652 + 28 19.595514297 -1.103518248 -1.372127652 + 29 18.299512863 3.470481873 -1.015127659 + 30 16.155511856 3.614481926 -1.934127688 + 31 16.205513000 4.356481552 -2.033127785 + 32 15.512512207 2.791481972 -2.228127480 + +Types + + 1 cp + 2 hc + 3 cp + 4 c=1 + 5 cp + 6 hc + 7 cp + 8 hc + 9 cp + 10 hc + 11 cp + 12 hc + 13 hc + 14 c= + 15 hc + 16 hc + 17 cp + 18 hc + 19 cp + 20 c=1 + 21 cp + 22 hc + 23 cp + 24 hc + 25 cp + 26 hc + 27 cp + 28 hc + 29 hc + 30 c= + 31 hc + 32 hc + +Charges + + 1 -0.129000 + 2 0.123700 + 3 0.026600 + 4 -0.018200 + 5 -0.129000 + 6 0.123700 + 7 -0.173400 + 8 0.140300 + 9 -0.113400 + 10 0.128800 + 11 -0.173400 + 12 0.140300 + 13 0.051600 + 14 -0.069600 + 15 0.035400 + 16 0.035400 + 17 -0.129000 + 18 0.123700 + 19 0.026600 + 20 -0.018200 + 21 -0.129000 + 22 0.123700 + 23 -0.173400 + 24 0.140300 + 25 -0.113400 + 26 0.128800 + 27 -0.173400 + 28 0.140300 + 29 0.051600 + 30 -0.069600 + 31 0.035400 + 32 0.035400 + +Molecules + + 1 1 + 2 1 + 3 1 + 4 1 + 5 1 + 6 1 + 7 1 + 8 1 + 9 1 + 10 1 + 11 1 + 12 1 + 13 1 + 14 1 + 15 1 + 16 1 + 17 1 + 18 1 + 19 1 + 20 1 + 21 1 + 22 1 + 23 1 + 24 1 + 25 1 + 26 1 + 27 1 + 28 1 + 29 1 + 30 1 + 31 1 + 32 1 + +Bonds + + 1 cp-hc 1 2 + 2 cp-cp 1 3 + 3 cp-cp 1 11 + 4 cp-c=1 3 4 + 5 cp-cp 3 5 + 6 hc-c=1 13 4 + 7 c=1-c= 4 14 + 8 cp-hc 5 6 + 9 cp-cp 5 7 + 10 cp-hc 7 8 + 11 cp-cp 7 9 + 12 cp-hc 9 10 + 13 cp-cp 9 11 + 14 cp-hc 11 12 + 15 hc-c= 15 14 + 16 hc-c= 16 14 + 17 cp-hc 17 18 + 18 cp-cp 17 19 + 19 cp-cp 17 27 + 20 cp-c=1 19 20 + 21 cp-cp 19 21 + 22 hc-c=1 29 20 + 23 c=1-c= 20 30 + 24 cp-hc 21 22 + 25 cp-cp 21 23 + 26 cp-hc 23 24 + 27 cp-cp 23 25 + 28 cp-hc 25 26 + 29 cp-cp 25 27 + 30 cp-hc 27 28 + 31 hc-c= 31 30 + 32 hc-c= 32 30 + +Angles + + 1 cp-cp-hc 3 1 2 + 2 cp-cp-hc 11 1 2 + 3 cp-cp-cp 3 1 11 + 4 cp-cp-c=1 1 3 4 + 5 cp-cp-cp 1 3 5 + 6 cp-cp-c=1 5 3 4 + 7 cp-c=1-hc 3 4 13 + 8 cp-c=1-c= 3 4 14 + 9 hc-c=1-c= 13 4 14 + 10 cp-cp-hc 3 5 6 + 11 cp-cp-cp 3 5 7 + 12 cp-cp-hc 7 5 6 + 13 cp-cp-hc 5 7 8 + 14 cp-cp-cp 5 7 9 + 15 cp-cp-hc 9 7 8 + 16 cp-cp-hc 7 9 10 + 17 cp-cp-cp 7 9 11 + 18 cp-cp-hc 11 9 10 + 19 cp-cp-cp 1 11 9 + 20 cp-cp-hc 1 11 12 + 21 cp-cp-hc 9 11 12 + 22 hc-c=-c=1 15 14 4 + 23 hc-c=-c=1 16 14 4 + 24 hc-c=-hc 15 14 16 + 25 cp-cp-hc 19 17 18 + 26 cp-cp-hc 27 17 18 + 27 cp-cp-cp 19 17 27 + 28 cp-cp-c=1 17 19 20 + 29 cp-cp-cp 17 19 21 + 30 cp-cp-c=1 21 19 20 + 31 cp-c=1-hc 19 20 29 + 32 cp-c=1-c= 19 20 30 + 33 hc-c=1-c= 29 20 30 + 34 cp-cp-hc 19 21 22 + 35 cp-cp-cp 19 21 23 + 36 cp-cp-hc 23 21 22 + 37 cp-cp-hc 21 23 24 + 38 cp-cp-cp 21 23 25 + 39 cp-cp-hc 25 23 24 + 40 cp-cp-hc 23 25 26 + 41 cp-cp-cp 23 25 27 + 42 cp-cp-hc 27 25 26 + 43 cp-cp-cp 17 27 25 + 44 cp-cp-hc 17 27 28 + 45 cp-cp-hc 25 27 28 + 46 hc-c=-c=1 31 30 20 + 47 hc-c=-c=1 32 30 20 + 48 hc-c=-hc 31 30 32 + +Dihedrals + + 1 hc-cp-cp-c=1 2 1 3 4 + 2 cp-cp-cp-hc 5 3 1 2 + 3 cp-cp-cp-c=1 11 1 3 4 + 4 cp-cp-cp-cp 11 1 3 5 + 5 cp-cp-cp-hc 9 11 1 2 + 6 hc-cp-cp-hc 2 1 11 12 + 7 cp-cp-cp-cp 3 1 11 9 + 8 cp-cp-cp-hc 3 1 11 12 + 9 cp-cp-c=1-hc 1 3 4 13 + 10 cp-cp-c=1-c= 1 3 4 14 + 11 cp-cp-c=1-hc 5 3 4 13 + 12 cp-cp-c=1-c= 5 3 4 14 + 13 cp-cp-cp-hc 1 3 5 6 + 14 cp-cp-cp-cp 1 3 5 7 + 15 hc-cp-cp-c=1 6 5 3 4 + 16 cp-cp-cp-c=1 7 5 3 4 + 17 cp-c=1-c=-hc 3 4 14 15 + 18 cp-c=1-c=-hc 3 4 14 16 + 19 hc-c=1-c=-hc 13 4 14 15 + 20 hc-c=1-c=-hc 13 4 14 16 + 21 cp-cp-cp-hc 3 5 7 8 + 22 cp-cp-cp-cp 3 5 7 9 + 23 hc-cp-cp-hc 6 5 7 8 + 24 cp-cp-cp-hc 9 7 5 6 + 25 cp-cp-cp-hc 5 7 9 10 + 26 cp-cp-cp-cp 5 7 9 11 + 27 hc-cp-cp-hc 8 7 9 10 + 28 cp-cp-cp-hc 11 9 7 8 + 29 cp-cp-cp-cp 7 9 11 1 + 30 cp-cp-cp-hc 7 9 11 12 + 31 cp-cp-cp-hc 1 11 9 10 + 32 hc-cp-cp-hc 10 9 11 12 + 33 hc-cp-cp-c=1 18 17 19 20 + 34 cp-cp-cp-hc 21 19 17 18 + 35 cp-cp-cp-c=1 27 17 19 20 + 36 cp-cp-cp-cp 27 17 19 21 + 37 cp-cp-cp-hc 25 27 17 18 + 38 hc-cp-cp-hc 18 17 27 28 + 39 cp-cp-cp-cp 19 17 27 25 + 40 cp-cp-cp-hc 19 17 27 28 + 41 cp-cp-c=1-hc 17 19 20 29 + 42 cp-cp-c=1-c= 17 19 20 30 + 43 cp-cp-c=1-hc 21 19 20 29 + 44 cp-cp-c=1-c= 21 19 20 30 + 45 cp-cp-cp-hc 17 19 21 22 + 46 cp-cp-cp-cp 17 19 21 23 + 47 hc-cp-cp-c=1 22 21 19 20 + 48 cp-cp-cp-c=1 23 21 19 20 + 49 cp-c=1-c=-hc 19 20 30 31 + 50 cp-c=1-c=-hc 19 20 30 32 + 51 hc-c=1-c=-hc 29 20 30 31 + 52 hc-c=1-c=-hc 29 20 30 32 + 53 cp-cp-cp-hc 19 21 23 24 + 54 cp-cp-cp-cp 19 21 23 25 + 55 hc-cp-cp-hc 22 21 23 24 + 56 cp-cp-cp-hc 25 23 21 22 + 57 cp-cp-cp-hc 21 23 25 26 + 58 cp-cp-cp-cp 21 23 25 27 + 59 hc-cp-cp-hc 24 23 25 26 + 60 cp-cp-cp-hc 27 25 23 24 + 61 cp-cp-cp-cp 23 25 27 17 + 62 cp-cp-cp-hc 23 25 27 28 + 63 cp-cp-cp-hc 17 27 25 26 + 64 hc-cp-cp-hc 26 25 27 28 + +Impropers + + 1 cp-cp-cp-hc 3 1 11 2 + 2 cp-cp-cp-c=1 1 3 5 4 + 3 cp-c=1-hc-c= 3 4 13 14 + 4 cp-cp-cp-hc 3 5 7 6 + 5 cp-cp-cp-hc 5 7 9 8 + 6 cp-cp-cp-hc 7 9 11 10 + 7 cp-cp-cp-hc 1 11 9 12 + 8 hc-c=-hc-c=1 15 14 16 4 + 9 cp-cp-cp-hc 19 17 27 18 + 10 cp-cp-cp-c=1 17 19 21 20 + 11 cp-c=1-hc-c= 19 20 29 30 + 12 cp-cp-cp-hc 19 21 23 22 + 13 cp-cp-cp-hc 21 23 25 24 + 14 cp-cp-cp-hc 23 25 27 26 + 15 cp-cp-cp-hc 17 27 25 28 + 16 hc-c=-hc-c=1 31 30 32 20 diff --git a/examples/PACKAGES/reaction/tiny_polystyrene/chain_chain_reacted.data_template b/examples/PACKAGES/reaction/tiny_polystyrene/chain_chain_reacted.data_template deleted file mode 100644 index e01d42b7fb..0000000000 --- a/examples/PACKAGES/reaction/tiny_polystyrene/chain_chain_reacted.data_template +++ /dev/null @@ -1,497 +0,0 @@ -chain_chain_reacted - -50 atoms -52 bonds -90 angles -135 dihedrals -42 impropers - -Types - -1 1 -2 2 -3 1 -4 5 -5 1 -6 2 -7 1 -8 2 -9 1 -10 2 -11 1 -12 2 -13 2 -14 6 -15 2 -16 2 -17 5 -18 6 -19 2 -20 2 -21 1 -22 2 -23 1 -24 5 -25 1 -26 2 -27 1 -28 2 -29 1 -30 2 -31 1 -32 2 -33 2 -34 6 -35 1 -36 2 -37 1 -38 5 -39 1 -40 2 -41 1 -42 2 -43 1 -44 2 -45 1 -46 2 -47 2 -48 6 -49 2 -50 2 - -Charges - -1 -0.129000 -2 0.123700 -3 0.026600 -4 -0.018200 -5 -0.129000 -6 0.123700 -7 -0.173400 -8 0.140300 -9 -0.113400 -10 0.128800 -11 -0.173400 -12 0.140300 -13 0.051600 -14 -0.069600 -15 0.035400 -16 0.035400 -17 -0.018200 -18 -0.069600 -19 0.035400 -20 0.035400 -21 -0.129000 -22 0.123700 -23 0.026600 -24 -0.018200 -25 -0.129000 -26 0.123700 -27 -0.173400 -28 0.140300 -29 -0.113400 -30 0.128800 -31 -0.173400 -32 0.140300 -33 0.051600 -34 -0.069600 -35 -0.129000 -36 0.123700 -37 0.026600 -38 -0.018200 -39 -0.129000 -40 0.123700 -41 -0.173400 -42 0.140300 -43 -0.113400 -44 0.128800 -45 -0.173400 -46 0.140300 -47 0.051600 -48 -0.069600 -49 0.035400 -50 0.035400 - -Coords - -1 24.391510 0.871570 -1.658940 -2 25.323530 1.410570 -1.658940 -3 23.161520 1.581570 -1.658940 -4 23.161520 3.081570 -1.658940 -5 21.931530 0.871570 -1.658940 -6 20.999531 1.410570 -1.658940 -7 21.931530 -0.548430 -1.658940 -8 20.999531 -1.087420 -1.658940 -9 23.161520 -1.258420 -1.658940 -10 23.161520 -2.335430 -1.658940 -11 24.391510 -0.548430 -1.658940 -12 25.323530 -1.087420 -1.658940 -13 24.027519 3.486570 -1.301940 -14 21.883520 3.630570 -2.220940 -15 21.933510 4.372580 -2.319940 -16 21.240520 2.807570 -2.514940 -17 28.359209 3.254520 -1.372130 -18 27.081209 3.803520 -1.934130 -19 27.131210 4.545520 -2.033130 -20 26.438219 2.980520 -2.228130 -21 13.465810 0.682530 -1.658940 -22 14.397820 1.221530 -1.658940 -23 12.235820 1.392530 -1.658940 -24 12.235820 2.892530 -1.658940 -25 11.005820 0.682530 -1.658940 -26 10.073820 1.221530 -1.658940 -27 11.005820 -0.737470 -1.658940 -28 10.073820 -1.276460 -1.658940 -29 12.235820 -1.447460 -1.658940 -30 12.235820 -2.524470 -1.658940 -31 13.465810 -0.737470 -1.658940 -32 14.397820 -1.276460 -1.658940 -33 13.101820 3.297530 -1.301940 -34 10.957820 3.441530 -2.220940 -35 18.663521 0.855480 -1.372130 -36 19.595510 1.394480 -1.372130 -37 17.433510 1.565480 -1.372130 -38 17.433510 3.065480 -1.372130 -39 16.203510 0.855480 -1.372130 -40 15.271510 1.394480 -1.372130 -41 16.203510 -0.564520 -1.372130 -42 15.271510 -1.103520 -1.372130 -43 17.433510 -1.274520 -1.372130 -44 17.433510 -2.351520 -1.372130 -45 18.663521 -0.564520 -1.372130 -46 19.595510 -1.103520 -1.372130 -47 18.299509 3.470480 -1.015130 -48 16.155510 3.614480 -1.934130 -49 16.205509 4.356480 -2.033130 -50 15.512510 2.791480 -2.228130 - -Bonds - -1 1 1 2 -2 2 1 3 -3 2 1 11 -4 7 3 4 -5 2 3 5 -6 8 13 4 -7 9 4 14 -8 9 4 18 -9 1 5 6 -10 2 5 7 -11 1 7 8 -12 2 7 9 -13 1 9 10 -14 2 9 11 -15 1 11 12 -16 10 15 14 -17 10 16 14 -18 9 38 14 -19 9 17 18 -20 10 19 18 -21 10 20 18 -22 1 21 22 -23 2 21 23 -24 2 21 31 -25 7 23 24 -26 2 23 25 -27 8 33 24 -28 9 24 34 -29 9 24 48 -30 1 25 26 -31 2 25 27 -32 1 27 28 -33 2 27 29 -34 1 29 30 -35 2 29 31 -36 1 31 32 -37 1 35 36 -38 2 35 37 -39 2 35 45 -40 7 37 38 -41 2 37 39 -42 8 47 38 -43 9 38 48 -44 1 39 40 -45 2 39 41 -46 1 41 42 -47 2 41 43 -48 1 43 44 -49 2 43 45 -50 1 45 46 -51 10 49 48 -52 10 50 48 - -Angles - -1 1 3 1 2 -2 1 11 1 2 -3 2 3 1 11 -4 9 1 3 4 -5 2 1 3 5 -6 9 5 3 4 -7 10 3 4 13 -8 11 3 4 14 -9 11 3 4 18 -10 12 13 4 14 -11 12 13 4 18 -12 13 14 4 18 -13 1 3 5 6 -14 2 3 5 7 -15 1 7 5 6 -16 1 5 7 8 -17 2 5 7 9 -18 1 9 7 8 -19 1 7 9 10 -20 2 7 9 11 -21 1 11 9 10 -22 2 1 11 9 -23 1 1 11 12 -24 1 9 11 12 -25 14 15 14 4 -26 14 16 14 4 -27 16 4 14 38 -28 15 15 14 16 -29 14 15 14 38 -30 14 16 14 38 -31 16 4 18 17 -32 14 19 18 4 -33 14 20 18 4 -34 14 19 18 17 -35 14 20 18 17 -36 15 19 18 20 -37 1 23 21 22 -38 1 31 21 22 -39 2 23 21 31 -40 9 21 23 24 -41 2 21 23 25 -42 9 25 23 24 -43 10 23 24 33 -44 11 23 24 34 -45 11 23 24 48 -46 12 33 24 34 -47 12 33 24 48 -48 13 34 24 48 -49 1 23 25 26 -50 2 23 25 27 -51 1 27 25 26 -52 1 25 27 28 -53 2 25 27 29 -54 1 29 27 28 -55 1 27 29 30 -56 2 27 29 31 -57 1 31 29 30 -58 2 21 31 29 -59 1 21 31 32 -60 1 29 31 32 -61 1 37 35 36 -62 1 45 35 36 -63 2 37 35 45 -64 9 35 37 38 -65 2 35 37 39 -66 9 39 37 38 -67 11 37 38 14 -68 12 47 38 14 -69 13 14 38 48 -70 10 37 38 47 -71 11 37 38 48 -72 12 47 38 48 -73 1 37 39 40 -74 2 37 39 41 -75 1 41 39 40 -76 1 39 41 42 -77 2 39 41 43 -78 1 43 41 42 -79 1 41 43 44 -80 2 41 43 45 -81 1 45 43 44 -82 2 35 45 43 -83 1 35 45 46 -84 1 43 45 46 -85 16 24 48 38 -86 14 49 48 24 -87 14 50 48 24 -88 14 49 48 38 -89 14 50 48 38 -90 15 49 48 50 - -Dihedrals - -1 10 2 1 3 4 -2 2 5 3 1 2 -3 11 11 1 3 4 -4 4 11 1 3 5 -5 2 9 11 1 2 -6 5 2 1 11 12 -7 4 3 1 11 9 -8 2 3 1 11 12 -9 12 1 3 4 13 -10 13 1 3 4 14 -11 13 1 3 4 18 -12 12 5 3 4 13 -13 13 5 3 4 14 -14 13 5 3 4 18 -15 2 1 3 5 6 -16 4 1 3 5 7 -17 10 6 5 3 4 -18 11 7 5 3 4 -19 14 3 4 14 15 -20 14 3 4 14 16 -21 17 3 4 14 38 -22 15 13 4 14 15 -23 15 13 4 14 16 -24 18 13 4 14 38 -25 16 18 4 14 15 -26 16 18 4 14 16 -27 19 18 4 14 38 -28 17 3 4 18 17 -29 14 3 4 18 19 -30 14 3 4 18 20 -31 18 13 4 18 17 -32 15 13 4 18 19 -33 15 13 4 18 20 -34 19 14 4 18 17 -35 16 14 4 18 19 -36 16 14 4 18 20 -37 2 3 5 7 8 -38 4 3 5 7 9 -39 5 6 5 7 8 -40 2 9 7 5 6 -41 2 5 7 9 10 -42 4 5 7 9 11 -43 5 8 7 9 10 -44 2 11 9 7 8 -45 4 7 9 11 1 -46 2 7 9 11 12 -47 2 1 11 9 10 -48 5 10 9 11 12 -49 17 37 38 14 4 -50 18 47 38 14 4 -51 19 48 38 14 4 -52 14 37 38 14 15 -53 15 47 38 14 15 -54 16 48 38 14 15 -55 14 37 38 14 16 -56 15 47 38 14 16 -57 16 48 38 14 16 -58 10 22 21 23 24 -59 2 25 23 21 22 -60 11 31 21 23 24 -61 4 31 21 23 25 -62 2 29 31 21 22 -63 5 22 21 31 32 -64 4 23 21 31 29 -65 2 23 21 31 32 -66 12 21 23 24 33 -67 13 21 23 24 34 -68 13 21 23 24 48 -69 12 25 23 24 33 -70 13 25 23 24 34 -71 13 25 23 24 48 -72 2 21 23 25 26 -73 4 21 23 25 27 -74 10 26 25 23 24 -75 11 27 25 23 24 -76 17 23 24 48 38 -77 14 23 24 48 49 -78 14 23 24 48 50 -79 18 33 24 48 38 -80 15 33 24 48 49 -81 15 33 24 48 50 -82 19 34 24 48 38 -83 16 34 24 48 49 -84 16 34 24 48 50 -85 2 23 25 27 28 -86 4 23 25 27 29 -87 5 26 25 27 28 -88 2 29 27 25 26 -89 2 25 27 29 30 -90 4 25 27 29 31 -91 5 28 27 29 30 -92 2 31 29 27 28 -93 4 27 29 31 21 -94 2 27 29 31 32 -95 2 21 31 29 30 -96 5 30 29 31 32 -97 10 36 35 37 38 -98 2 39 37 35 36 -99 11 45 35 37 38 -100 4 45 35 37 39 -101 2 43 45 35 36 -102 5 36 35 45 46 -103 4 37 35 45 43 -104 2 37 35 45 46 -105 13 35 37 38 14 -106 12 35 37 38 47 -107 13 35 37 38 48 -108 13 39 37 38 14 -109 12 39 37 38 47 -110 13 39 37 38 48 -111 2 35 37 39 40 -112 4 35 37 39 41 -113 10 40 39 37 38 -114 11 41 39 37 38 -115 19 14 38 48 24 -116 16 14 38 48 49 -117 16 14 38 48 50 -118 17 37 38 48 24 -119 14 37 38 48 49 -120 14 37 38 48 50 -121 18 47 38 48 24 -122 15 47 38 48 49 -123 15 47 38 48 50 -124 2 37 39 41 42 -125 4 37 39 41 43 -126 5 40 39 41 42 -127 2 43 41 39 40 -128 2 39 41 43 44 -129 4 39 41 43 45 -130 5 42 41 43 44 -131 2 45 43 41 42 -132 4 41 43 45 35 -133 2 41 43 45 46 -134 2 35 45 43 44 -135 5 44 43 45 46 - -Impropers - -1 1 3 1 11 2 -2 5 1 3 5 4 -3 1 3 5 7 6 -4 1 5 7 9 8 -5 1 7 9 11 10 -6 1 1 11 9 12 -7 1 23 21 31 22 -8 5 21 23 25 24 -9 1 23 25 27 26 -10 1 25 27 29 28 -11 1 27 29 31 30 -12 1 21 31 29 32 -13 1 37 35 45 36 -14 5 35 37 39 38 -15 1 37 39 41 40 -16 1 39 41 43 42 -17 1 41 43 45 44 -18 1 35 45 43 46 -19 1 3 4 13 14 -20 1 3 4 13 18 -21 1 3 4 14 18 -22 1 13 4 14 18 -23 1 15 14 16 4 -24 1 15 14 4 38 -25 1 16 14 4 38 -26 1 15 14 16 38 -27 1 19 18 17 4 -28 1 20 18 17 4 -29 1 19 18 20 4 -30 1 19 18 20 17 -31 1 23 24 33 34 -32 1 23 24 33 48 -33 1 23 24 34 48 -34 1 33 24 34 48 -35 1 37 38 47 14 -36 1 37 38 14 48 -37 1 47 38 14 48 -38 1 37 38 47 48 -39 1 49 48 38 24 -40 1 50 48 38 24 -41 1 49 48 50 24 -42 1 49 48 50 38 diff --git a/examples/PACKAGES/reaction/tiny_polystyrene/chain_chain_reacted.molecule_template b/examples/PACKAGES/reaction/tiny_polystyrene/chain_chain_reacted.molecule_template new file mode 100644 index 0000000000..3eca90c7c8 --- /dev/null +++ b/examples/PACKAGES/reaction/tiny_polystyrene/chain_chain_reacted.molecule_template @@ -0,0 +1,526 @@ +chain_chain_reacted + + 50 atoms + 52 bonds + 90 angles + 135 dihedrals + 18 impropers + +Coords + + 1 24.391510010 0.871569991 -1.658939958 + 2 25.323530197 1.410570025 -1.658939958 + 3 23.161520004 1.581570029 -1.658939958 + 4 23.161520004 3.081569910 -1.658939958 + 5 21.931529999 0.871569991 -1.658939958 + 6 20.999530792 1.410570025 -1.658939958 + 7 21.931529999 -0.548430026 -1.658939958 + 8 20.999530792 -1.087419987 -1.658939958 + 9 23.161520004 -1.258419991 -1.658939958 + 10 23.161520004 -2.335429907 -1.658939958 + 11 24.391510010 -0.548430026 -1.658939958 + 12 25.323530197 -1.087419987 -1.658939958 + 13 24.027519226 3.486569881 -1.301939964 + 14 21.883520126 3.630569935 -2.220940113 + 15 21.933509827 4.372580051 -2.319940090 + 16 21.240520477 2.807569981 -2.514940023 + 17 28.359209061 3.254519939 -1.372130036 + 18 27.081209183 3.803519964 -1.934129953 + 19 27.131210327 4.545519829 -2.033129930 + 20 26.438219070 2.980520010 -2.228130102 + 21 13.465809822 0.682529986 -1.658939958 + 22 14.397820473 1.221529961 -1.658939958 + 23 12.235819817 1.392529964 -1.658939958 + 24 12.235819817 2.892529964 -1.658939958 + 25 11.005820274 0.682529986 -1.658939958 + 26 10.073820114 1.221529961 -1.658939958 + 27 11.005820274 -0.737469971 -1.658939958 + 28 10.073820114 -1.276460052 -1.658939958 + 29 12.235819817 -1.447460055 -1.658939958 + 30 12.235819817 -2.524470091 -1.658939958 + 31 13.465809822 -0.737469971 -1.658939958 + 32 14.397820473 -1.276460052 -1.658939958 + 33 13.101819992 3.297529936 -1.301939964 + 34 10.957819939 3.441529989 -2.220940113 + 35 18.663520813 0.855480015 -1.372130036 + 36 19.595510483 1.394479990 -1.372130036 + 37 17.433509827 1.565479994 -1.372130036 + 38 17.433509827 3.065479994 -1.372130036 + 39 16.203510284 0.855480015 -1.372130036 + 40 15.271510124 1.394479990 -1.372130036 + 41 16.203510284 -0.564520001 -1.372130036 + 42 15.271510124 -1.103520036 -1.372130036 + 43 17.433509827 -1.274520040 -1.372130036 + 44 17.433509827 -2.351520061 -1.372130036 + 45 18.663520813 -0.564520001 -1.372130036 + 46 19.595510483 -1.103520036 -1.372130036 + 47 18.299509048 3.470479965 -1.015130043 + 48 16.155509949 3.614480019 -1.934129953 + 49 16.205509186 4.356480122 -2.033129930 + 50 15.512510300 2.791480064 -2.228130102 + +Types + + 1 cp + 2 hc + 3 cp + 4 c1 + 5 cp + 6 hc + 7 cp + 8 hc + 9 cp + 10 hc + 11 cp + 12 hc + 13 hc + 14 c2 + 15 hc + 16 hc + 17 c1 + 18 c2 + 19 hc + 20 hc + 21 cp + 22 hc + 23 cp + 24 c1 + 25 cp + 26 hc + 27 cp + 28 hc + 29 cp + 30 hc + 31 cp + 32 hc + 33 hc + 34 c2 + 35 cp + 36 hc + 37 cp + 38 c1 + 39 cp + 40 hc + 41 cp + 42 hc + 43 cp + 44 hc + 45 cp + 46 hc + 47 hc + 48 c2 + 49 hc + 50 hc + +Charges + + 1 -0.129000 + 2 0.123700 + 3 0.026600 + 4 -0.018200 + 5 -0.129000 + 6 0.123700 + 7 -0.173400 + 8 0.140300 + 9 -0.113400 + 10 0.128800 + 11 -0.173400 + 12 0.140300 + 13 0.051600 + 14 -0.069600 + 15 0.035400 + 16 0.035400 + 17 -0.018200 + 18 -0.069600 + 19 0.035400 + 20 0.035400 + 21 -0.129000 + 22 0.123700 + 23 0.026600 + 24 -0.018200 + 25 -0.129000 + 26 0.123700 + 27 -0.173400 + 28 0.140300 + 29 -0.113400 + 30 0.128800 + 31 -0.173400 + 32 0.140300 + 33 0.051600 + 34 -0.069600 + 35 -0.129000 + 36 0.123700 + 37 0.026600 + 38 -0.018200 + 39 -0.129000 + 40 0.123700 + 41 -0.173400 + 42 0.140300 + 43 -0.113400 + 44 0.128800 + 45 -0.173400 + 46 0.140300 + 47 0.051600 + 48 -0.069600 + 49 0.035400 + 50 0.035400 + +Molecules + + 1 1 + 2 1 + 3 1 + 4 1 + 5 1 + 6 1 + 7 1 + 8 1 + 9 1 + 10 1 + 11 1 + 12 1 + 13 1 + 14 1 + 15 1 + 16 1 + 17 1 + 18 1 + 19 1 + 20 1 + 21 1 + 22 1 + 23 1 + 24 1 + 25 1 + 26 1 + 27 1 + 28 1 + 29 1 + 30 1 + 31 1 + 32 1 + 33 1 + 34 1 + 35 1 + 36 1 + 37 1 + 38 1 + 39 1 + 40 1 + 41 1 + 42 1 + 43 1 + 44 1 + 45 1 + 46 1 + 47 1 + 48 1 + 49 1 + 50 1 + +Bonds + + 1 cp-hc 1 2 + 2 cp-cp 1 3 + 3 cp-cp 1 11 + 4 cp-c1 3 4 + 5 cp-cp 3 5 + 6 hc-c1 13 4 + 7 c1-c2 4 14 + 8 c1-c2 4 18 + 9 cp-hc 5 6 + 10 cp-cp 5 7 + 11 cp-hc 7 8 + 12 cp-cp 7 9 + 13 cp-hc 9 10 + 14 cp-cp 9 11 + 15 cp-hc 11 12 + 16 hc-c2 15 14 + 17 hc-c2 16 14 + 18 c1-c2 38 14 + 19 c1-c2 17 18 + 20 hc-c2 19 18 + 21 hc-c2 20 18 + 22 cp-hc 21 22 + 23 cp-cp 21 23 + 24 cp-cp 21 31 + 25 cp-c1 23 24 + 26 cp-cp 23 25 + 27 hc-c1 33 24 + 28 c1-c2 24 34 + 29 c1-c2 24 48 + 30 cp-hc 25 26 + 31 cp-cp 25 27 + 32 cp-hc 27 28 + 33 cp-cp 27 29 + 34 cp-hc 29 30 + 35 cp-cp 29 31 + 36 cp-hc 31 32 + 37 cp-hc 35 36 + 38 cp-cp 35 37 + 39 cp-cp 35 45 + 40 cp-c1 37 38 + 41 cp-cp 37 39 + 42 hc-c1 47 38 + 43 c1-c2 38 48 + 44 cp-hc 39 40 + 45 cp-cp 39 41 + 46 cp-hc 41 42 + 47 cp-cp 41 43 + 48 cp-hc 43 44 + 49 cp-cp 43 45 + 50 cp-hc 45 46 + 51 hc-c2 49 48 + 52 hc-c2 50 48 + +Angles + + 1 cp-cp-hc 3 1 2 + 2 cp-cp-hc 11 1 2 + 3 cp-cp-cp 3 1 11 + 4 cp-cp-c1 1 3 4 + 5 cp-cp-cp 1 3 5 + 6 cp-cp-c1 5 3 4 + 7 cp-c1-hc 3 4 13 + 8 cp-c1-c2 3 4 14 + 9 cp-c1-c2 3 4 18 + 10 hc-c1-c2 13 4 14 + 11 hc-c1-c2 13 4 18 + 12 c2-c1-c2 14 4 18 + 13 cp-cp-hc 3 5 6 + 14 cp-cp-cp 3 5 7 + 15 cp-cp-hc 7 5 6 + 16 cp-cp-hc 5 7 8 + 17 cp-cp-cp 5 7 9 + 18 cp-cp-hc 9 7 8 + 19 cp-cp-hc 7 9 10 + 20 cp-cp-cp 7 9 11 + 21 cp-cp-hc 11 9 10 + 22 cp-cp-cp 1 11 9 + 23 cp-cp-hc 1 11 12 + 24 cp-cp-hc 9 11 12 + 25 hc-c2-c1 15 14 4 + 26 hc-c2-c1 16 14 4 + 27 c1-c2-c1 4 14 38 + 28 hc-c2-hc 15 14 16 + 29 hc-c2-c1 15 14 38 + 30 hc-c2-c1 16 14 38 + 31 c1-c2-c1 4 18 17 + 32 hc-c2-c1 19 18 4 + 33 hc-c2-c1 20 18 4 + 34 hc-c2-c1 19 18 17 + 35 hc-c2-c1 20 18 17 + 36 hc-c2-hc 19 18 20 + 37 cp-cp-hc 23 21 22 + 38 cp-cp-hc 31 21 22 + 39 cp-cp-cp 23 21 31 + 40 cp-cp-c1 21 23 24 + 41 cp-cp-cp 21 23 25 + 42 cp-cp-c1 25 23 24 + 43 cp-c1-hc 23 24 33 + 44 cp-c1-c2 23 24 34 + 45 cp-c1-c2 23 24 48 + 46 hc-c1-c2 33 24 34 + 47 hc-c1-c2 33 24 48 + 48 c2-c1-c2 34 24 48 + 49 cp-cp-hc 23 25 26 + 50 cp-cp-cp 23 25 27 + 51 cp-cp-hc 27 25 26 + 52 cp-cp-hc 25 27 28 + 53 cp-cp-cp 25 27 29 + 54 cp-cp-hc 29 27 28 + 55 cp-cp-hc 27 29 30 + 56 cp-cp-cp 27 29 31 + 57 cp-cp-hc 31 29 30 + 58 cp-cp-cp 21 31 29 + 59 cp-cp-hc 21 31 32 + 60 cp-cp-hc 29 31 32 + 61 cp-cp-hc 37 35 36 + 62 cp-cp-hc 45 35 36 + 63 cp-cp-cp 37 35 45 + 64 cp-cp-c1 35 37 38 + 65 cp-cp-cp 35 37 39 + 66 cp-cp-c1 39 37 38 + 67 cp-c1-c2 37 38 14 + 68 hc-c1-c2 47 38 14 + 69 c2-c1-c2 14 38 48 + 70 cp-c1-hc 37 38 47 + 71 cp-c1-c2 37 38 48 + 72 hc-c1-c2 47 38 48 + 73 cp-cp-hc 37 39 40 + 74 cp-cp-cp 37 39 41 + 75 cp-cp-hc 41 39 40 + 76 cp-cp-hc 39 41 42 + 77 cp-cp-cp 39 41 43 + 78 cp-cp-hc 43 41 42 + 79 cp-cp-hc 41 43 44 + 80 cp-cp-cp 41 43 45 + 81 cp-cp-hc 45 43 44 + 82 cp-cp-cp 35 45 43 + 83 cp-cp-hc 35 45 46 + 84 cp-cp-hc 43 45 46 + 85 c1-c2-c1 24 48 38 + 86 hc-c2-c1 49 48 24 + 87 hc-c2-c1 50 48 24 + 88 hc-c2-c1 49 48 38 + 89 hc-c2-c1 50 48 38 + 90 hc-c2-hc 49 48 50 + +Dihedrals + + 1 hc-cp-cp-c1 2 1 3 4 + 2 cp-cp-cp-hc 5 3 1 2 + 3 cp-cp-cp-c1 11 1 3 4 + 4 cp-cp-cp-cp 11 1 3 5 + 5 cp-cp-cp-hc 9 11 1 2 + 6 hc-cp-cp-hc 2 1 11 12 + 7 cp-cp-cp-cp 3 1 11 9 + 8 cp-cp-cp-hc 3 1 11 12 + 9 cp-cp-c1-hc 1 3 4 13 + 10 cp-cp-c1-c2 1 3 4 14 + 11 cp-cp-c1-c2 1 3 4 18 + 12 cp-cp-c1-hc 5 3 4 13 + 13 cp-cp-c1-c2 5 3 4 14 + 14 cp-cp-c1-c2 5 3 4 18 + 15 cp-cp-cp-hc 1 3 5 6 + 16 cp-cp-cp-cp 1 3 5 7 + 17 hc-cp-cp-c1 6 5 3 4 + 18 cp-cp-cp-c1 7 5 3 4 + 19 cp-c1-c2-hc 3 4 14 15 + 20 cp-c1-c2-hc 3 4 14 16 + 21 cp-c1-c2-c1 3 4 14 38 + 22 hc-c1-c2-hc 13 4 14 15 + 23 hc-c1-c2-hc 13 4 14 16 + 24 hc-c1-c2-c1 13 4 14 38 + 25 c2-c1-c2-hc 18 4 14 15 + 26 c2-c1-c2-hc 18 4 14 16 + 27 c2-c1-c2-c1 18 4 14 38 + 28 cp-c1-c2-c1 3 4 18 17 + 29 cp-c1-c2-hc 3 4 18 19 + 30 cp-c1-c2-hc 3 4 18 20 + 31 hc-c1-c2-c1 13 4 18 17 + 32 hc-c1-c2-hc 13 4 18 19 + 33 hc-c1-c2-hc 13 4 18 20 + 34 c2-c1-c2-c1 14 4 18 17 + 35 c2-c1-c2-hc 14 4 18 19 + 36 c2-c1-c2-hc 14 4 18 20 + 37 cp-cp-cp-hc 3 5 7 8 + 38 cp-cp-cp-cp 3 5 7 9 + 39 hc-cp-cp-hc 6 5 7 8 + 40 cp-cp-cp-hc 9 7 5 6 + 41 cp-cp-cp-hc 5 7 9 10 + 42 cp-cp-cp-cp 5 7 9 11 + 43 hc-cp-cp-hc 8 7 9 10 + 44 cp-cp-cp-hc 11 9 7 8 + 45 cp-cp-cp-cp 7 9 11 1 + 46 cp-cp-cp-hc 7 9 11 12 + 47 cp-cp-cp-hc 1 11 9 10 + 48 hc-cp-cp-hc 10 9 11 12 + 49 cp-c1-c2-c1 37 38 14 4 + 50 hc-c1-c2-c1 47 38 14 4 + 51 c2-c1-c2-c1 48 38 14 4 + 52 cp-c1-c2-hc 37 38 14 15 + 53 hc-c1-c2-hc 47 38 14 15 + 54 c2-c1-c2-hc 48 38 14 15 + 55 cp-c1-c2-hc 37 38 14 16 + 56 hc-c1-c2-hc 47 38 14 16 + 57 c2-c1-c2-hc 48 38 14 16 + 58 hc-cp-cp-c1 22 21 23 24 + 59 cp-cp-cp-hc 25 23 21 22 + 60 cp-cp-cp-c1 31 21 23 24 + 61 cp-cp-cp-cp 31 21 23 25 + 62 cp-cp-cp-hc 29 31 21 22 + 63 hc-cp-cp-hc 22 21 31 32 + 64 cp-cp-cp-cp 23 21 31 29 + 65 cp-cp-cp-hc 23 21 31 32 + 66 cp-cp-c1-hc 21 23 24 33 + 67 cp-cp-c1-c2 21 23 24 34 + 68 cp-cp-c1-c2 21 23 24 48 + 69 cp-cp-c1-hc 25 23 24 33 + 70 cp-cp-c1-c2 25 23 24 34 + 71 cp-cp-c1-c2 25 23 24 48 + 72 cp-cp-cp-hc 21 23 25 26 + 73 cp-cp-cp-cp 21 23 25 27 + 74 hc-cp-cp-c1 26 25 23 24 + 75 cp-cp-cp-c1 27 25 23 24 + 76 cp-c1-c2-c1 23 24 48 38 + 77 cp-c1-c2-hc 23 24 48 49 + 78 cp-c1-c2-hc 23 24 48 50 + 79 hc-c1-c2-c1 33 24 48 38 + 80 hc-c1-c2-hc 33 24 48 49 + 81 hc-c1-c2-hc 33 24 48 50 + 82 c2-c1-c2-c1 34 24 48 38 + 83 c2-c1-c2-hc 34 24 48 49 + 84 c2-c1-c2-hc 34 24 48 50 + 85 cp-cp-cp-hc 23 25 27 28 + 86 cp-cp-cp-cp 23 25 27 29 + 87 hc-cp-cp-hc 26 25 27 28 + 88 cp-cp-cp-hc 29 27 25 26 + 89 cp-cp-cp-hc 25 27 29 30 + 90 cp-cp-cp-cp 25 27 29 31 + 91 hc-cp-cp-hc 28 27 29 30 + 92 cp-cp-cp-hc 31 29 27 28 + 93 cp-cp-cp-cp 27 29 31 21 + 94 cp-cp-cp-hc 27 29 31 32 + 95 cp-cp-cp-hc 21 31 29 30 + 96 hc-cp-cp-hc 30 29 31 32 + 97 hc-cp-cp-c1 36 35 37 38 + 98 cp-cp-cp-hc 39 37 35 36 + 99 cp-cp-cp-c1 45 35 37 38 + 100 cp-cp-cp-cp 45 35 37 39 + 101 cp-cp-cp-hc 43 45 35 36 + 102 hc-cp-cp-hc 36 35 45 46 + 103 cp-cp-cp-cp 37 35 45 43 + 104 cp-cp-cp-hc 37 35 45 46 + 105 cp-cp-c1-c2 35 37 38 14 + 106 cp-cp-c1-hc 35 37 38 47 + 107 cp-cp-c1-c2 35 37 38 48 + 108 cp-cp-c1-c2 39 37 38 14 + 109 cp-cp-c1-hc 39 37 38 47 + 110 cp-cp-c1-c2 39 37 38 48 + 111 cp-cp-cp-hc 35 37 39 40 + 112 cp-cp-cp-cp 35 37 39 41 + 113 hc-cp-cp-c1 40 39 37 38 + 114 cp-cp-cp-c1 41 39 37 38 + 115 c2-c1-c2-c1 14 38 48 24 + 116 c2-c1-c2-hc 14 38 48 49 + 117 c2-c1-c2-hc 14 38 48 50 + 118 cp-c1-c2-c1 37 38 48 24 + 119 cp-c1-c2-hc 37 38 48 49 + 120 cp-c1-c2-hc 37 38 48 50 + 121 hc-c1-c2-c1 47 38 48 24 + 122 hc-c1-c2-hc 47 38 48 49 + 123 hc-c1-c2-hc 47 38 48 50 + 124 cp-cp-cp-hc 37 39 41 42 + 125 cp-cp-cp-cp 37 39 41 43 + 126 hc-cp-cp-hc 40 39 41 42 + 127 cp-cp-cp-hc 43 41 39 40 + 128 cp-cp-cp-hc 39 41 43 44 + 129 cp-cp-cp-cp 39 41 43 45 + 130 hc-cp-cp-hc 42 41 43 44 + 131 cp-cp-cp-hc 45 43 41 42 + 132 cp-cp-cp-cp 41 43 45 35 + 133 cp-cp-cp-hc 41 43 45 46 + 134 cp-cp-cp-hc 35 45 43 44 + 135 hc-cp-cp-hc 44 43 45 46 + +Impropers + + 1 cp-cp-cp-hc 3 1 11 2 + 2 cp-cp-cp-c1 1 3 5 4 + 3 cp-cp-cp-hc 3 5 7 6 + 4 cp-cp-cp-hc 5 7 9 8 + 5 cp-cp-cp-hc 7 9 11 10 + 6 cp-cp-cp-hc 1 11 9 12 + 7 cp-cp-cp-hc 23 21 31 22 + 8 cp-cp-cp-c1 21 23 25 24 + 9 cp-cp-cp-hc 23 25 27 26 + 10 cp-cp-cp-hc 25 27 29 28 + 11 cp-cp-cp-hc 27 29 31 30 + 12 cp-cp-cp-hc 21 31 29 32 + 13 cp-cp-cp-hc 37 35 45 36 + 14 cp-cp-cp-c1 35 37 39 38 + 15 cp-cp-cp-hc 37 39 41 40 + 16 cp-cp-cp-hc 39 41 43 42 + 17 cp-cp-cp-hc 41 43 45 44 + 18 cp-cp-cp-hc 35 45 43 46 diff --git a/examples/PACKAGES/reaction/tiny_polystyrene/chain_chain_unreacted.data_template b/examples/PACKAGES/reaction/tiny_polystyrene/chain_chain_unreacted.data_template deleted file mode 100644 index d8e0d977df..0000000000 --- a/examples/PACKAGES/reaction/tiny_polystyrene/chain_chain_unreacted.data_template +++ /dev/null @@ -1,467 +0,0 @@ -chain_chain_unreacted - -50 atoms -51 bonds -84 angles -118 dihedrals -36 impropers - -Types - -1 1 -2 2 -3 1 -4 5 -5 1 -6 2 -7 1 -8 2 -9 1 -10 2 -11 1 -12 2 -13 2 -14 6 -15 2 -16 2 -17 5 -18 6 -19 2 -20 2 -21 1 -22 2 -23 1 -24 5 -25 1 -26 2 -27 1 -28 2 -29 1 -30 2 -31 1 -32 2 -33 2 -34 6 -35 1 -36 2 -37 1 -38 5 -39 1 -40 2 -41 1 -42 2 -43 1 -44 2 -45 1 -46 2 -47 2 -48 6 -49 2 -50 2 - -Charges - -1 -0.129000 -2 0.123700 -3 0.026600 -4 -0.018200 -5 -0.129000 -6 0.123700 -7 -0.173400 -8 0.140300 -9 -0.113400 -10 0.128800 -11 -0.173400 -12 0.140300 -13 0.051600 -14 -0.069600 -15 0.035400 -16 0.035400 -17 -0.018200 -18 -0.069600 -19 0.035400 -20 0.035400 -21 -0.129000 -22 0.123700 -23 0.026600 -24 -0.018200 -25 -0.129000 -26 0.123700 -27 -0.173400 -28 0.140300 -29 -0.113400 -30 0.128800 -31 -0.173400 -32 0.140300 -33 0.051600 -34 -0.069600 -35 -0.129000 -36 0.123700 -37 0.026600 -38 -0.018200 -39 -0.129000 -40 0.123700 -41 -0.173400 -42 0.140300 -43 -0.113400 -44 0.128800 -45 -0.173400 -46 0.140300 -47 0.051600 -48 -0.069600 -49 0.035400 -50 0.035400 - -Coords - -1 24.391510 0.871570 -1.658940 -2 25.323530 1.410570 -1.658940 -3 23.161520 1.581570 -1.658940 -4 23.161520 3.081570 -1.658940 -5 21.931530 0.871570 -1.658940 -6 20.999531 1.410570 -1.658940 -7 21.931530 -0.548430 -1.658940 -8 20.999531 -1.087420 -1.658940 -9 23.161520 -1.258420 -1.658940 -10 23.161520 -2.335430 -1.658940 -11 24.391510 -0.548430 -1.658940 -12 25.323530 -1.087420 -1.658940 -13 24.027519 3.486570 -1.301940 -14 21.883520 3.630570 -2.220940 -15 21.933510 4.372580 -2.319940 -16 21.240520 2.807570 -2.514940 -17 28.359209 3.254520 -1.372130 -18 27.081209 3.803520 -1.934130 -19 27.131210 4.545520 -2.033130 -20 26.438219 2.980520 -2.228130 -21 13.465810 0.682530 -1.658940 -22 14.397820 1.221530 -1.658940 -23 12.235820 1.392530 -1.658940 -24 12.235820 2.892530 -1.658940 -25 11.005820 0.682530 -1.658940 -26 10.073820 1.221530 -1.658940 -27 11.005820 -0.737470 -1.658940 -28 10.073820 -1.276460 -1.658940 -29 12.235820 -1.447460 -1.658940 -30 12.235820 -2.524470 -1.658940 -31 13.465810 -0.737470 -1.658940 -32 14.397820 -1.276460 -1.658940 -33 13.101820 3.297530 -1.301940 -34 10.957820 3.441530 -2.220940 -35 18.663521 0.855480 -1.372130 -36 19.595510 1.394480 -1.372130 -37 17.433510 1.565480 -1.372130 -38 17.433510 3.065480 -1.372130 -39 16.203510 0.855480 -1.372130 -40 15.271510 1.394480 -1.372130 -41 16.203510 -0.564520 -1.372130 -42 15.271510 -1.103520 -1.372130 -43 17.433510 -1.274520 -1.372130 -44 17.433510 -2.351520 -1.372130 -45 18.663521 -0.564520 -1.372130 -46 19.595510 -1.103520 -1.372130 -47 18.299509 3.470480 -1.015130 -48 16.155510 3.614480 -1.934130 -49 16.205509 4.356480 -2.033130 -50 15.512510 2.791480 -2.228130 - -Bonds - -1 1 1 2 -2 2 1 3 -3 2 1 11 -4 7 3 4 -5 2 3 5 -6 8 13 4 -7 9 4 14 -8 9 4 18 -9 1 5 6 -10 2 5 7 -11 1 7 8 -12 2 7 9 -13 1 9 10 -14 2 9 11 -15 1 11 12 -16 10 15 14 -17 10 16 14 -18 9 17 18 -19 10 19 18 -20 10 20 18 -21 1 21 22 -22 2 21 23 -23 2 21 31 -24 7 23 24 -25 2 23 25 -26 8 33 24 -27 9 24 34 -28 9 24 48 -29 1 25 26 -30 2 25 27 -31 1 27 28 -32 2 27 29 -33 1 29 30 -34 2 29 31 -35 1 31 32 -36 1 35 36 -37 2 35 37 -38 2 35 45 -39 7 37 38 -40 2 37 39 -41 8 47 38 -42 9 38 48 -43 1 39 40 -44 2 39 41 -45 1 41 42 -46 2 41 43 -47 1 43 44 -48 2 43 45 -49 1 45 46 -50 10 49 48 -51 10 50 48 - -Angles - -1 1 3 1 2 -2 1 11 1 2 -3 2 3 1 11 -4 9 1 3 4 -5 2 1 3 5 -6 9 5 3 4 -7 10 3 4 13 -8 11 3 4 14 -9 11 3 4 18 -10 12 13 4 14 -11 12 13 4 18 -12 13 14 4 18 -13 1 3 5 6 -14 2 3 5 7 -15 1 7 5 6 -16 1 5 7 8 -17 2 5 7 9 -18 1 9 7 8 -19 1 7 9 10 -20 2 7 9 11 -21 1 11 9 10 -22 2 1 11 9 -23 1 1 11 12 -24 1 9 11 12 -25 14 15 14 4 -26 14 16 14 4 -27 15 15 14 16 -28 16 4 18 17 -29 14 19 18 4 -30 14 20 18 4 -31 14 19 18 17 -32 14 20 18 17 -33 15 19 18 20 -34 1 23 21 22 -35 1 31 21 22 -36 2 23 21 31 -37 9 21 23 24 -38 2 21 23 25 -39 9 25 23 24 -40 10 23 24 33 -41 11 23 24 34 -42 11 23 24 48 -43 12 33 24 34 -44 12 33 24 48 -45 13 34 24 48 -46 1 23 25 26 -47 2 23 25 27 -48 1 27 25 26 -49 1 25 27 28 -50 2 25 27 29 -51 1 29 27 28 -52 1 27 29 30 -53 2 27 29 31 -54 1 31 29 30 -55 2 21 31 29 -56 1 21 31 32 -57 1 29 31 32 -58 1 37 35 36 -59 1 45 35 36 -60 2 37 35 45 -61 9 35 37 38 -62 2 35 37 39 -63 9 39 37 38 -64 10 37 38 47 -65 11 37 38 48 -66 12 47 38 48 -67 1 37 39 40 -68 2 37 39 41 -69 1 41 39 40 -70 1 39 41 42 -71 2 39 41 43 -72 1 43 41 42 -73 1 41 43 44 -74 2 41 43 45 -75 1 45 43 44 -76 2 35 45 43 -77 1 35 45 46 -78 1 43 45 46 -79 16 24 48 38 -80 14 49 48 24 -81 14 50 48 24 -82 14 49 48 38 -83 14 50 48 38 -84 15 49 48 50 - -Dihedrals - -1 10 2 1 3 4 -2 2 5 3 1 2 -3 11 11 1 3 4 -4 4 11 1 3 5 -5 2 9 11 1 2 -6 5 2 1 11 12 -7 4 3 1 11 9 -8 2 3 1 11 12 -9 12 1 3 4 13 -10 13 1 3 4 14 -11 13 1 3 4 18 -12 12 5 3 4 13 -13 13 5 3 4 14 -14 13 5 3 4 18 -15 2 1 3 5 6 -16 4 1 3 5 7 -17 10 6 5 3 4 -18 11 7 5 3 4 -19 14 3 4 14 15 -20 14 3 4 14 16 -21 15 13 4 14 15 -22 15 13 4 14 16 -23 16 18 4 14 15 -24 16 18 4 14 16 -25 17 3 4 18 17 -26 14 3 4 18 19 -27 14 3 4 18 20 -28 18 13 4 18 17 -29 15 13 4 18 19 -30 15 13 4 18 20 -31 19 14 4 18 17 -32 16 14 4 18 19 -33 16 14 4 18 20 -34 2 3 5 7 8 -35 4 3 5 7 9 -36 5 6 5 7 8 -37 2 9 7 5 6 -38 2 5 7 9 10 -39 4 5 7 9 11 -40 5 8 7 9 10 -41 2 11 9 7 8 -42 4 7 9 11 1 -43 2 7 9 11 12 -44 2 1 11 9 10 -45 5 10 9 11 12 -46 10 22 21 23 24 -47 2 25 23 21 22 -48 11 31 21 23 24 -49 4 31 21 23 25 -50 2 29 31 21 22 -51 5 22 21 31 32 -52 4 23 21 31 29 -53 2 23 21 31 32 -54 12 21 23 24 33 -55 13 21 23 24 34 -56 13 21 23 24 48 -57 12 25 23 24 33 -58 13 25 23 24 34 -59 13 25 23 24 48 -60 2 21 23 25 26 -61 4 21 23 25 27 -62 10 26 25 23 24 -63 11 27 25 23 24 -64 17 23 24 48 38 -65 14 23 24 48 49 -66 14 23 24 48 50 -67 18 33 24 48 38 -68 15 33 24 48 49 -69 15 33 24 48 50 -70 19 34 24 48 38 -71 16 34 24 48 49 -72 16 34 24 48 50 -73 2 23 25 27 28 -74 4 23 25 27 29 -75 5 26 25 27 28 -76 2 29 27 25 26 -77 2 25 27 29 30 -78 4 25 27 29 31 -79 5 28 27 29 30 -80 2 31 29 27 28 -81 4 27 29 31 21 -82 2 27 29 31 32 -83 2 21 31 29 30 -84 5 30 29 31 32 -85 10 36 35 37 38 -86 2 39 37 35 36 -87 11 45 35 37 38 -88 4 45 35 37 39 -89 2 43 45 35 36 -90 5 36 35 45 46 -91 4 37 35 45 43 -92 2 37 35 45 46 -93 12 35 37 38 47 -94 13 35 37 38 48 -95 12 39 37 38 47 -96 13 39 37 38 48 -97 2 35 37 39 40 -98 4 35 37 39 41 -99 10 40 39 37 38 -100 11 41 39 37 38 -101 17 37 38 48 24 -102 14 37 38 48 49 -103 14 37 38 48 50 -104 18 47 38 48 24 -105 15 47 38 48 49 -106 15 47 38 48 50 -107 2 37 39 41 42 -108 4 37 39 41 43 -109 5 40 39 41 42 -110 2 43 41 39 40 -111 2 39 41 43 44 -112 4 39 41 43 45 -113 5 42 41 43 44 -114 2 45 43 41 42 -115 4 41 43 45 35 -116 2 41 43 45 46 -117 2 35 45 43 44 -118 5 44 43 45 46 - -Impropers - -1 1 3 1 11 2 -2 5 1 3 5 4 -3 1 3 5 7 6 -4 1 5 7 9 8 -5 1 7 9 11 10 -6 1 1 11 9 12 -7 6 15 14 16 4 -8 1 23 21 31 22 -9 5 21 23 25 24 -10 1 23 25 27 26 -11 1 25 27 29 28 -12 1 27 29 31 30 -13 1 21 31 29 32 -14 1 37 35 45 36 -15 5 35 37 39 38 -16 7 37 38 47 48 -17 1 37 39 41 40 -18 1 39 41 43 42 -19 1 41 43 45 44 -20 1 35 45 43 46 -21 1 3 4 13 14 -22 1 3 4 13 18 -23 1 3 4 14 18 -24 1 13 4 14 18 -25 1 19 18 17 4 -26 1 20 18 17 4 -27 1 19 18 20 4 -28 1 19 18 20 17 -29 1 23 24 33 34 -30 1 23 24 33 48 -31 1 23 24 34 48 -32 1 33 24 34 48 -33 1 49 48 38 24 -34 1 50 48 38 24 -35 1 49 48 50 24 -36 1 49 48 50 38 diff --git a/examples/PACKAGES/reaction/tiny_polystyrene/chain_chain_unreacted.molecule_template b/examples/PACKAGES/reaction/tiny_polystyrene/chain_chain_unreacted.molecule_template new file mode 100644 index 0000000000..8b4c36d26b --- /dev/null +++ b/examples/PACKAGES/reaction/tiny_polystyrene/chain_chain_unreacted.molecule_template @@ -0,0 +1,504 @@ +chain_chain_unreacted + + 50 atoms + 51 bonds + 84 angles + 118 dihedrals + 20 impropers + +Coords + + 1 24.391510010 0.871569991 -1.658939958 + 2 25.323530197 1.410570025 -1.658939958 + 3 23.161520004 1.581570029 -1.658939958 + 4 23.161520004 3.081569910 -1.658939958 + 5 21.931529999 0.871569991 -1.658939958 + 6 20.999530792 1.410570025 -1.658939958 + 7 21.931529999 -0.548430026 -1.658939958 + 8 20.999530792 -1.087419987 -1.658939958 + 9 23.161520004 -1.258419991 -1.658939958 + 10 23.161520004 -2.335429907 -1.658939958 + 11 24.391510010 -0.548430026 -1.658939958 + 12 25.323530197 -1.087419987 -1.658939958 + 13 24.027519226 3.486569881 -1.301939964 + 14 21.883520126 3.630569935 -2.220940113 + 15 21.933509827 4.372580051 -2.319940090 + 16 21.240520477 2.807569981 -2.514940023 + 17 28.359209061 3.254519939 -1.372130036 + 18 27.081209183 3.803519964 -1.934129953 + 19 27.131210327 4.545519829 -2.033129930 + 20 26.438219070 2.980520010 -2.228130102 + 21 13.465809822 0.682529986 -1.658939958 + 22 14.397820473 1.221529961 -1.658939958 + 23 12.235819817 1.392529964 -1.658939958 + 24 12.235819817 2.892529964 -1.658939958 + 25 11.005820274 0.682529986 -1.658939958 + 26 10.073820114 1.221529961 -1.658939958 + 27 11.005820274 -0.737469971 -1.658939958 + 28 10.073820114 -1.276460052 -1.658939958 + 29 12.235819817 -1.447460055 -1.658939958 + 30 12.235819817 -2.524470091 -1.658939958 + 31 13.465809822 -0.737469971 -1.658939958 + 32 14.397820473 -1.276460052 -1.658939958 + 33 13.101819992 3.297529936 -1.301939964 + 34 10.957819939 3.441529989 -2.220940113 + 35 18.663520813 0.855480015 -1.372130036 + 36 19.595510483 1.394479990 -1.372130036 + 37 17.433509827 1.565479994 -1.372130036 + 38 17.433509827 3.065479994 -1.372130036 + 39 16.203510284 0.855480015 -1.372130036 + 40 15.271510124 1.394479990 -1.372130036 + 41 16.203510284 -0.564520001 -1.372130036 + 42 15.271510124 -1.103520036 -1.372130036 + 43 17.433509827 -1.274520040 -1.372130036 + 44 17.433509827 -2.351520061 -1.372130036 + 45 18.663520813 -0.564520001 -1.372130036 + 46 19.595510483 -1.103520036 -1.372130036 + 47 18.299509048 3.470479965 -1.015130043 + 48 16.155509949 3.614480019 -1.934129953 + 49 16.205509186 4.356480122 -2.033129930 + 50 15.512510300 2.791480064 -2.228130102 + +Types + + 1 cp + 2 hc + 3 cp + 4 c1 + 5 cp + 6 hc + 7 cp + 8 hc + 9 cp + 10 hc + 11 cp + 12 hc + 13 hc + 14 c2 + 15 hc + 16 hc + 17 c1 + 18 c2 + 19 hc + 20 hc + 21 cp + 22 hc + 23 cp + 24 c1 + 25 cp + 26 hc + 27 cp + 28 hc + 29 cp + 30 hc + 31 cp + 32 hc + 33 hc + 34 c2 + 35 cp + 36 hc + 37 cp + 38 c1 + 39 cp + 40 hc + 41 cp + 42 hc + 43 cp + 44 hc + 45 cp + 46 hc + 47 hc + 48 c2 + 49 hc + 50 hc + +Charges + + 1 -0.129000 + 2 0.123700 + 3 0.026600 + 4 -0.018200 + 5 -0.129000 + 6 0.123700 + 7 -0.173400 + 8 0.140300 + 9 -0.113400 + 10 0.128800 + 11 -0.173400 + 12 0.140300 + 13 0.051600 + 14 -0.069600 + 15 0.035400 + 16 0.035400 + 17 -0.018200 + 18 -0.069600 + 19 0.035400 + 20 0.035400 + 21 -0.129000 + 22 0.123700 + 23 0.026600 + 24 -0.018200 + 25 -0.129000 + 26 0.123700 + 27 -0.173400 + 28 0.140300 + 29 -0.113400 + 30 0.128800 + 31 -0.173400 + 32 0.140300 + 33 0.051600 + 34 -0.069600 + 35 -0.129000 + 36 0.123700 + 37 0.026600 + 38 -0.018200 + 39 -0.129000 + 40 0.123700 + 41 -0.173400 + 42 0.140300 + 43 -0.113400 + 44 0.128800 + 45 -0.173400 + 46 0.140300 + 47 0.051600 + 48 -0.069600 + 49 0.035400 + 50 0.035400 + +Molecules + + 1 1 + 2 1 + 3 1 + 4 1 + 5 1 + 6 1 + 7 1 + 8 1 + 9 1 + 10 1 + 11 1 + 12 1 + 13 1 + 14 1 + 15 1 + 16 1 + 17 1 + 18 1 + 19 1 + 20 1 + 21 1 + 22 1 + 23 1 + 24 1 + 25 1 + 26 1 + 27 1 + 28 1 + 29 1 + 30 1 + 31 1 + 32 1 + 33 1 + 34 1 + 35 1 + 36 1 + 37 1 + 38 1 + 39 1 + 40 1 + 41 1 + 42 1 + 43 1 + 44 1 + 45 1 + 46 1 + 47 1 + 48 1 + 49 1 + 50 1 + +Bonds + + 1 cp-hc 1 2 + 2 cp-cp 1 3 + 3 cp-cp 1 11 + 4 cp-c1 3 4 + 5 cp-cp 3 5 + 6 hc-c1 13 4 + 7 c1-c2 4 14 + 8 c1-c2 4 18 + 9 cp-hc 5 6 + 10 cp-cp 5 7 + 11 cp-hc 7 8 + 12 cp-cp 7 9 + 13 cp-hc 9 10 + 14 cp-cp 9 11 + 15 cp-hc 11 12 + 16 hc-c2 15 14 + 17 hc-c2 16 14 + 18 c1-c2 17 18 + 19 hc-c2 19 18 + 20 hc-c2 20 18 + 21 cp-hc 21 22 + 22 cp-cp 21 23 + 23 cp-cp 21 31 + 24 cp-c1 23 24 + 25 cp-cp 23 25 + 26 hc-c1 33 24 + 27 c1-c2 24 34 + 28 c1-c2 24 48 + 29 cp-hc 25 26 + 30 cp-cp 25 27 + 31 cp-hc 27 28 + 32 cp-cp 27 29 + 33 cp-hc 29 30 + 34 cp-cp 29 31 + 35 cp-hc 31 32 + 36 cp-hc 35 36 + 37 cp-cp 35 37 + 38 cp-cp 35 45 + 39 cp-c1 37 38 + 40 cp-cp 37 39 + 41 hc-c1 47 38 + 42 c1-c2 38 48 + 43 cp-hc 39 40 + 44 cp-cp 39 41 + 45 cp-hc 41 42 + 46 cp-cp 41 43 + 47 cp-hc 43 44 + 48 cp-cp 43 45 + 49 cp-hc 45 46 + 50 hc-c2 49 48 + 51 hc-c2 50 48 + +Angles + + 1 cp-cp-hc 3 1 2 + 2 cp-cp-hc 11 1 2 + 3 cp-cp-cp 3 1 11 + 4 cp-cp-c1 1 3 4 + 5 cp-cp-cp 1 3 5 + 6 cp-cp-c1 5 3 4 + 7 cp-c1-hc 3 4 13 + 8 cp-c1-c2 3 4 14 + 9 cp-c1-c2 3 4 18 + 10 hc-c1-c2 13 4 14 + 11 hc-c1-c2 13 4 18 + 12 c2-c1-c2 14 4 18 + 13 cp-cp-hc 3 5 6 + 14 cp-cp-cp 3 5 7 + 15 cp-cp-hc 7 5 6 + 16 cp-cp-hc 5 7 8 + 17 cp-cp-cp 5 7 9 + 18 cp-cp-hc 9 7 8 + 19 cp-cp-hc 7 9 10 + 20 cp-cp-cp 7 9 11 + 21 cp-cp-hc 11 9 10 + 22 cp-cp-cp 1 11 9 + 23 cp-cp-hc 1 11 12 + 24 cp-cp-hc 9 11 12 + 25 hc-c2-c1 15 14 4 + 26 hc-c2-c1 16 14 4 + 27 hc-c2-hc 15 14 16 + 28 c1-c2-c1 4 18 17 + 29 hc-c2-c1 19 18 4 + 30 hc-c2-c1 20 18 4 + 31 hc-c2-c1 19 18 17 + 32 hc-c2-c1 20 18 17 + 33 hc-c2-hc 19 18 20 + 34 cp-cp-hc 23 21 22 + 35 cp-cp-hc 31 21 22 + 36 cp-cp-cp 23 21 31 + 37 cp-cp-c1 21 23 24 + 38 cp-cp-cp 21 23 25 + 39 cp-cp-c1 25 23 24 + 40 cp-c1-hc 23 24 33 + 41 cp-c1-c2 23 24 34 + 42 cp-c1-c2 23 24 48 + 43 hc-c1-c2 33 24 34 + 44 hc-c1-c2 33 24 48 + 45 c2-c1-c2 34 24 48 + 46 cp-cp-hc 23 25 26 + 47 cp-cp-cp 23 25 27 + 48 cp-cp-hc 27 25 26 + 49 cp-cp-hc 25 27 28 + 50 cp-cp-cp 25 27 29 + 51 cp-cp-hc 29 27 28 + 52 cp-cp-hc 27 29 30 + 53 cp-cp-cp 27 29 31 + 54 cp-cp-hc 31 29 30 + 55 cp-cp-cp 21 31 29 + 56 cp-cp-hc 21 31 32 + 57 cp-cp-hc 29 31 32 + 58 cp-cp-hc 37 35 36 + 59 cp-cp-hc 45 35 36 + 60 cp-cp-cp 37 35 45 + 61 cp-cp-c1 35 37 38 + 62 cp-cp-cp 35 37 39 + 63 cp-cp-c1 39 37 38 + 64 cp-c1-hc 37 38 47 + 65 cp-c1-c2 37 38 48 + 66 hc-c1-c2 47 38 48 + 67 cp-cp-hc 37 39 40 + 68 cp-cp-cp 37 39 41 + 69 cp-cp-hc 41 39 40 + 70 cp-cp-hc 39 41 42 + 71 cp-cp-cp 39 41 43 + 72 cp-cp-hc 43 41 42 + 73 cp-cp-hc 41 43 44 + 74 cp-cp-cp 41 43 45 + 75 cp-cp-hc 45 43 44 + 76 cp-cp-cp 35 45 43 + 77 cp-cp-hc 35 45 46 + 78 cp-cp-hc 43 45 46 + 79 c1-c2-c1 24 48 38 + 80 hc-c2-c1 49 48 24 + 81 hc-c2-c1 50 48 24 + 82 hc-c2-c1 49 48 38 + 83 hc-c2-c1 50 48 38 + 84 hc-c2-hc 49 48 50 + +Dihedrals + + 1 hc-cp-cp-c1 2 1 3 4 + 2 cp-cp-cp-hc 5 3 1 2 + 3 cp-cp-cp-c1 11 1 3 4 + 4 cp-cp-cp-cp 11 1 3 5 + 5 cp-cp-cp-hc 9 11 1 2 + 6 hc-cp-cp-hc 2 1 11 12 + 7 cp-cp-cp-cp 3 1 11 9 + 8 cp-cp-cp-hc 3 1 11 12 + 9 cp-cp-c1-hc 1 3 4 13 + 10 cp-cp-c1-c2 1 3 4 14 + 11 cp-cp-c1-c2 1 3 4 18 + 12 cp-cp-c1-hc 5 3 4 13 + 13 cp-cp-c1-c2 5 3 4 14 + 14 cp-cp-c1-c2 5 3 4 18 + 15 cp-cp-cp-hc 1 3 5 6 + 16 cp-cp-cp-cp 1 3 5 7 + 17 hc-cp-cp-c1 6 5 3 4 + 18 cp-cp-cp-c1 7 5 3 4 + 19 cp-c1-c2-hc 3 4 14 15 + 20 cp-c1-c2-hc 3 4 14 16 + 21 hc-c1-c2-hc 13 4 14 15 + 22 hc-c1-c2-hc 13 4 14 16 + 23 c2-c1-c2-hc 18 4 14 15 + 24 c2-c1-c2-hc 18 4 14 16 + 25 cp-c1-c2-c1 3 4 18 17 + 26 cp-c1-c2-hc 3 4 18 19 + 27 cp-c1-c2-hc 3 4 18 20 + 28 hc-c1-c2-c1 13 4 18 17 + 29 hc-c1-c2-hc 13 4 18 19 + 30 hc-c1-c2-hc 13 4 18 20 + 31 c2-c1-c2-c1 14 4 18 17 + 32 c2-c1-c2-hc 14 4 18 19 + 33 c2-c1-c2-hc 14 4 18 20 + 34 cp-cp-cp-hc 3 5 7 8 + 35 cp-cp-cp-cp 3 5 7 9 + 36 hc-cp-cp-hc 6 5 7 8 + 37 cp-cp-cp-hc 9 7 5 6 + 38 cp-cp-cp-hc 5 7 9 10 + 39 cp-cp-cp-cp 5 7 9 11 + 40 hc-cp-cp-hc 8 7 9 10 + 41 cp-cp-cp-hc 11 9 7 8 + 42 cp-cp-cp-cp 7 9 11 1 + 43 cp-cp-cp-hc 7 9 11 12 + 44 cp-cp-cp-hc 1 11 9 10 + 45 hc-cp-cp-hc 10 9 11 12 + 46 hc-cp-cp-c1 22 21 23 24 + 47 cp-cp-cp-hc 25 23 21 22 + 48 cp-cp-cp-c1 31 21 23 24 + 49 cp-cp-cp-cp 31 21 23 25 + 50 cp-cp-cp-hc 29 31 21 22 + 51 hc-cp-cp-hc 22 21 31 32 + 52 cp-cp-cp-cp 23 21 31 29 + 53 cp-cp-cp-hc 23 21 31 32 + 54 cp-cp-c1-hc 21 23 24 33 + 55 cp-cp-c1-c2 21 23 24 34 + 56 cp-cp-c1-c2 21 23 24 48 + 57 cp-cp-c1-hc 25 23 24 33 + 58 cp-cp-c1-c2 25 23 24 34 + 59 cp-cp-c1-c2 25 23 24 48 + 60 cp-cp-cp-hc 21 23 25 26 + 61 cp-cp-cp-cp 21 23 25 27 + 62 hc-cp-cp-c1 26 25 23 24 + 63 cp-cp-cp-c1 27 25 23 24 + 64 cp-c1-c2-c1 23 24 48 38 + 65 cp-c1-c2-hc 23 24 48 49 + 66 cp-c1-c2-hc 23 24 48 50 + 67 hc-c1-c2-c1 33 24 48 38 + 68 hc-c1-c2-hc 33 24 48 49 + 69 hc-c1-c2-hc 33 24 48 50 + 70 c2-c1-c2-c1 34 24 48 38 + 71 c2-c1-c2-hc 34 24 48 49 + 72 c2-c1-c2-hc 34 24 48 50 + 73 cp-cp-cp-hc 23 25 27 28 + 74 cp-cp-cp-cp 23 25 27 29 + 75 hc-cp-cp-hc 26 25 27 28 + 76 cp-cp-cp-hc 29 27 25 26 + 77 cp-cp-cp-hc 25 27 29 30 + 78 cp-cp-cp-cp 25 27 29 31 + 79 hc-cp-cp-hc 28 27 29 30 + 80 cp-cp-cp-hc 31 29 27 28 + 81 cp-cp-cp-cp 27 29 31 21 + 82 cp-cp-cp-hc 27 29 31 32 + 83 cp-cp-cp-hc 21 31 29 30 + 84 hc-cp-cp-hc 30 29 31 32 + 85 hc-cp-cp-c1 36 35 37 38 + 86 cp-cp-cp-hc 39 37 35 36 + 87 cp-cp-cp-c1 45 35 37 38 + 88 cp-cp-cp-cp 45 35 37 39 + 89 cp-cp-cp-hc 43 45 35 36 + 90 hc-cp-cp-hc 36 35 45 46 + 91 cp-cp-cp-cp 37 35 45 43 + 92 cp-cp-cp-hc 37 35 45 46 + 93 cp-cp-c1-hc 35 37 38 47 + 94 cp-cp-c1-c2 35 37 38 48 + 95 cp-cp-c1-hc 39 37 38 47 + 96 cp-cp-c1-c2 39 37 38 48 + 97 cp-cp-cp-hc 35 37 39 40 + 98 cp-cp-cp-cp 35 37 39 41 + 99 hc-cp-cp-c1 40 39 37 38 + 100 cp-cp-cp-c1 41 39 37 38 + 101 cp-c1-c2-c1 37 38 48 24 + 102 cp-c1-c2-hc 37 38 48 49 + 103 cp-c1-c2-hc 37 38 48 50 + 104 hc-c1-c2-c1 47 38 48 24 + 105 hc-c1-c2-hc 47 38 48 49 + 106 hc-c1-c2-hc 47 38 48 50 + 107 cp-cp-cp-hc 37 39 41 42 + 108 cp-cp-cp-cp 37 39 41 43 + 109 hc-cp-cp-hc 40 39 41 42 + 110 cp-cp-cp-hc 43 41 39 40 + 111 cp-cp-cp-hc 39 41 43 44 + 112 cp-cp-cp-cp 39 41 43 45 + 113 hc-cp-cp-hc 42 41 43 44 + 114 cp-cp-cp-hc 45 43 41 42 + 115 cp-cp-cp-cp 41 43 45 35 + 116 cp-cp-cp-hc 41 43 45 46 + 117 cp-cp-cp-hc 35 45 43 44 + 118 hc-cp-cp-hc 44 43 45 46 + +Impropers + + 1 cp-cp-cp-hc 3 1 11 2 + 2 cp-cp-cp-c1 1 3 5 4 + 3 cp-cp-cp-hc 3 5 7 6 + 4 cp-cp-cp-hc 5 7 9 8 + 5 cp-cp-cp-hc 7 9 11 10 + 6 cp-cp-cp-hc 1 11 9 12 + 7 hc-c2-hc-c1 15 14 16 4 + 8 cp-cp-cp-hc 23 21 31 22 + 9 cp-cp-cp-c1 21 23 25 24 + 10 cp-cp-cp-hc 23 25 27 26 + 11 cp-cp-cp-hc 25 27 29 28 + 12 cp-cp-cp-hc 27 29 31 30 + 13 cp-cp-cp-hc 21 31 29 32 + 14 cp-cp-cp-hc 37 35 45 36 + 15 cp-cp-cp-c1 35 37 39 38 + 16 cp-c1-hc-c2 37 38 47 48 + 17 cp-cp-cp-hc 37 39 41 40 + 18 cp-cp-cp-hc 39 41 43 42 + 19 cp-cp-cp-hc 41 43 45 44 + 20 cp-cp-cp-hc 35 45 43 46 diff --git a/examples/PACKAGES/reaction/tiny_polystyrene/chain_plus_styrene_reacted.data_template b/examples/PACKAGES/reaction/tiny_polystyrene/chain_plus_styrene_reacted.data_template deleted file mode 100644 index 352d88737d..0000000000 --- a/examples/PACKAGES/reaction/tiny_polystyrene/chain_plus_styrene_reacted.data_template +++ /dev/null @@ -1,451 +0,0 @@ -chain_plus_styrene_reacted - -46 atoms -48 bonds -81 angles -121 dihedrals -35 impropers - -Types - -1 1 -2 2 -3 1 -4 5 -5 1 -6 2 -7 1 -8 2 -9 1 -10 2 -11 1 -12 2 -13 2 -14 6 -15 2 -16 2 -17 1 -18 2 -19 1 -20 5 -21 1 -22 2 -23 1 -24 2 -25 1 -26 2 -27 1 -28 2 -29 2 -30 6 -31 1 -32 2 -33 1 -34 5 -35 1 -36 2 -37 1 -38 2 -39 1 -40 2 -41 1 -42 2 -43 2 -44 6 -45 2 -46 2 - -Charges - -1 -0.129000 -2 0.123700 -3 0.026600 -4 -0.018200 -5 -0.129000 -6 0.123700 -7 -0.173400 -8 0.140300 -9 -0.113400 -10 0.128800 -11 -0.173400 -12 0.140300 -13 0.051600 -14 -0.069600 -15 0.035400 -16 0.035400 -17 -0.129000 -18 0.123700 -19 0.026600 -20 -0.018200 -21 -0.129000 -22 0.123700 -23 -0.173400 -24 0.140300 -25 -0.113400 -26 0.128800 -27 -0.173400 -28 0.140300 -29 0.051600 -30 -0.069600 -31 -0.129000 -32 0.123700 -33 0.026600 -34 -0.018200 -35 -0.129000 -36 0.123700 -37 -0.173400 -38 0.140300 -39 -0.113400 -40 0.128800 -41 -0.173400 -42 0.140300 -43 0.051600 -44 -0.069600 -45 0.035400 -46 0.035400 - -Coords - -1 24.130699 1.043900 -1.309300 -2 25.062700 1.582900 -1.309300 -3 22.900700 1.753900 -1.309300 -4 22.900700 3.253900 -1.309300 -5 21.670700 1.043900 -1.309300 -6 20.738701 1.582900 -1.309300 -7 21.670700 -0.376100 -1.309300 -8 20.738701 -0.915100 -1.309300 -9 22.900700 -1.086100 -1.309300 -10 22.900700 -2.163100 -1.309300 -11 24.130699 -0.376100 -1.309300 -12 25.062700 -0.915100 -1.309300 -13 23.766701 3.658900 -0.952300 -14 21.622700 3.802900 -1.871300 -15 21.672701 4.544900 -1.970300 -16 20.979700 2.979900 -2.165300 -17 13.465800 0.682500 -1.658900 -18 14.397800 1.221500 -1.658900 -19 12.235800 1.392500 -1.658900 -20 12.235800 2.892500 -1.658900 -21 11.005800 0.682500 -1.658900 -22 10.073800 1.221500 -1.658900 -23 11.005800 -0.737500 -1.658900 -24 10.073800 -1.276500 -1.658900 -25 12.235800 -1.447500 -1.658900 -26 12.235800 -2.524500 -1.658900 -27 13.465800 -0.737500 -1.658900 -28 14.397800 -1.276500 -1.658900 -29 13.101800 3.297500 -1.301900 -30 10.957800 3.441500 -2.220900 -31 18.663500 0.855500 -1.372100 -32 19.595501 1.394500 -1.372100 -33 17.433500 1.565500 -1.372100 -34 17.433500 3.065500 -1.372100 -35 16.203501 0.855500 -1.372100 -36 15.271500 1.394500 -1.372100 -37 16.203501 -0.564500 -1.372100 -38 15.271500 -1.103500 -1.372100 -39 17.433500 -1.274500 -1.372100 -40 17.433500 -2.351500 -1.372100 -41 18.663500 -0.564500 -1.372100 -42 19.595501 -1.103500 -1.372100 -43 18.299500 3.470500 -1.015100 -44 16.155500 3.614500 -1.934100 -45 16.205500 4.356500 -2.033100 -46 15.512500 2.791500 -2.228100 - -Bonds - -1 1 1 2 -2 2 1 3 -3 2 1 11 -4 11 3 4 -5 2 3 5 -6 12 13 4 -7 13 4 14 -8 1 5 6 -9 2 5 7 -10 1 7 8 -11 2 7 9 -12 1 9 10 -13 2 9 11 -14 1 11 12 -15 10 15 14 -16 10 16 14 -17 9 14 34 -18 1 17 18 -19 2 17 19 -20 2 17 27 -21 7 19 20 -22 2 19 21 -23 8 29 20 -24 9 30 20 -25 9 44 20 -26 1 21 22 -27 2 21 23 -28 1 23 24 -29 2 23 25 -30 1 25 26 -31 2 25 27 -32 1 27 28 -33 1 31 32 -34 2 31 33 -35 2 31 41 -36 7 33 34 -37 2 33 35 -38 8 43 34 -39 9 44 34 -40 1 35 36 -41 2 35 37 -42 1 37 38 -43 2 37 39 -44 1 39 40 -45 2 39 41 -46 1 41 42 -47 10 45 44 -48 10 46 44 - -Angles - -1 1 3 1 2 -2 1 11 1 2 -3 2 3 1 11 -4 17 1 3 4 -5 2 1 3 5 -6 17 5 3 4 -7 18 3 4 13 -8 19 3 4 14 -9 20 13 4 14 -10 1 3 5 6 -11 2 3 5 7 -12 1 7 5 6 -13 1 5 7 8 -14 2 5 7 9 -15 1 9 7 8 -16 1 7 9 10 -17 2 7 9 11 -18 1 11 9 10 -19 2 1 11 9 -20 1 1 11 12 -21 1 9 11 12 -22 21 15 14 4 -23 21 16 14 4 -24 22 4 14 34 -25 15 15 14 16 -26 14 15 14 34 -27 14 16 14 34 -28 1 19 17 18 -29 1 27 17 18 -30 2 19 17 27 -31 9 17 19 20 -32 2 17 19 21 -33 9 21 19 20 -34 10 19 20 29 -35 11 19 20 30 -36 11 19 20 44 -37 12 29 20 30 -38 12 29 20 44 -39 13 30 20 44 -40 1 19 21 22 -41 2 19 21 23 -42 1 23 21 22 -43 1 21 23 24 -44 2 21 23 25 -45 1 25 23 24 -46 1 23 25 26 -47 2 23 25 27 -48 1 27 25 26 -49 2 17 27 25 -50 1 17 27 28 -51 1 25 27 28 -52 1 33 31 32 -53 1 41 31 32 -54 2 33 31 41 -55 9 31 33 34 -56 2 31 33 35 -57 9 35 33 34 -58 11 33 34 14 -59 12 43 34 14 -60 13 14 34 44 -61 10 33 34 43 -62 11 33 34 44 -63 12 43 34 44 -64 1 33 35 36 -65 2 33 35 37 -66 1 37 35 36 -67 1 35 37 38 -68 2 35 37 39 -69 1 39 37 38 -70 1 37 39 40 -71 2 37 39 41 -72 1 41 39 40 -73 2 31 41 39 -74 1 31 41 42 -75 1 39 41 42 -76 16 20 44 34 -77 14 45 44 20 -78 14 46 44 20 -79 14 45 44 34 -80 14 46 44 34 -81 15 45 44 46 - -Dihedrals - -1 20 2 1 3 4 -2 2 5 3 1 2 -3 21 11 1 3 4 -4 4 11 1 3 5 -5 2 9 11 1 2 -6 5 2 1 11 12 -7 4 3 1 11 9 -8 2 3 1 11 12 -9 22 1 3 4 13 -10 23 1 3 4 14 -11 22 5 3 4 13 -12 23 5 3 4 14 -13 2 1 3 5 6 -14 4 1 3 5 7 -15 20 6 5 3 4 -16 21 7 5 3 4 -17 24 3 4 14 15 -18 24 3 4 14 16 -19 25 3 4 14 34 -20 26 13 4 14 15 -21 26 13 4 14 16 -22 27 13 4 14 34 -23 2 3 5 7 8 -24 4 3 5 7 9 -25 5 6 5 7 8 -26 2 9 7 5 6 -27 2 5 7 9 10 -28 4 5 7 9 11 -29 5 8 7 9 10 -30 2 11 9 7 8 -31 4 7 9 11 1 -32 2 7 9 11 12 -33 2 1 11 9 10 -34 5 10 9 11 12 -35 28 4 14 34 33 -36 29 4 14 34 43 -37 30 4 14 34 44 -38 31 15 14 34 33 -39 32 15 14 34 43 -40 33 15 14 34 44 -41 31 16 14 34 33 -42 32 16 14 34 43 -43 33 16 14 34 44 -44 10 18 17 19 20 -45 2 21 19 17 18 -46 11 27 17 19 20 -47 4 27 17 19 21 -48 2 25 27 17 18 -49 5 18 17 27 28 -50 4 19 17 27 25 -51 2 19 17 27 28 -52 12 17 19 20 29 -53 13 17 19 20 30 -54 13 17 19 20 44 -55 12 21 19 20 29 -56 13 21 19 20 30 -57 13 21 19 20 44 -58 2 17 19 21 22 -59 4 17 19 21 23 -60 10 22 21 19 20 -61 11 23 21 19 20 -62 34 34 44 20 19 -63 31 45 44 20 19 -64 31 46 44 20 19 -65 35 34 44 20 29 -66 32 45 44 20 29 -67 32 46 44 20 29 -68 36 34 44 20 30 -69 33 45 44 20 30 -70 33 46 44 20 30 -71 2 19 21 23 24 -72 4 19 21 23 25 -73 5 22 21 23 24 -74 2 25 23 21 22 -75 2 21 23 25 26 -76 4 21 23 25 27 -77 5 24 23 25 26 -78 2 27 25 23 24 -79 4 23 25 27 17 -80 2 23 25 27 28 -81 2 17 27 25 26 -82 5 26 25 27 28 -83 10 32 31 33 34 -84 2 35 33 31 32 -85 11 41 31 33 34 -86 4 41 31 33 35 -87 2 39 41 31 32 -88 5 32 31 41 42 -89 4 33 31 41 39 -90 2 33 31 41 42 -91 13 31 33 34 14 -92 12 31 33 34 43 -93 13 31 33 34 44 -94 13 35 33 34 14 -95 12 35 33 34 43 -96 13 35 33 34 44 -97 2 31 33 35 36 -98 4 31 33 35 37 -99 10 36 35 33 34 -100 11 37 35 33 34 -101 36 20 44 34 14 -102 33 45 44 34 14 -103 33 46 44 34 14 -104 34 20 44 34 33 -105 31 45 44 34 33 -106 31 46 44 34 33 -107 35 20 44 34 43 -108 32 45 44 34 43 -109 32 46 44 34 43 -110 2 33 35 37 38 -111 4 33 35 37 39 -112 5 36 35 37 38 -113 2 39 37 35 36 -114 2 35 37 39 40 -115 4 35 37 39 41 -116 5 38 37 39 40 -117 2 41 39 37 38 -118 4 37 39 41 31 -119 2 37 39 41 42 -120 2 31 41 39 40 -121 5 40 39 41 42 - -Impropers - -1 1 3 1 11 2 -2 8 1 3 5 4 -3 9 3 4 13 14 -4 1 3 5 7 6 -5 1 5 7 9 8 -6 1 7 9 11 10 -7 1 1 11 9 12 -8 1 19 17 27 18 -9 5 17 19 21 20 -10 1 19 21 23 22 -11 1 21 23 25 24 -12 1 23 25 27 26 -13 1 17 27 25 28 -14 1 33 31 41 32 -15 5 31 33 35 34 -16 1 33 35 37 36 -17 1 35 37 39 38 -18 1 37 39 41 40 -19 1 31 41 39 42 -20 1 15 14 16 4 -21 1 15 14 4 34 -22 1 16 14 4 34 -23 1 15 14 16 34 -24 1 19 20 29 30 -25 1 19 20 29 44 -26 1 19 20 30 44 -27 1 29 20 30 44 -28 1 33 34 43 14 -29 1 33 34 14 44 -30 1 43 34 14 44 -31 1 33 34 43 44 -32 1 45 44 34 20 -33 1 46 44 34 20 -34 1 45 44 46 20 -35 1 45 44 46 34 diff --git a/examples/PACKAGES/reaction/tiny_polystyrene/chain_plus_styrene_reacted.molecule_template b/examples/PACKAGES/reaction/tiny_polystyrene/chain_plus_styrene_reacted.molecule_template new file mode 100644 index 0000000000..1755111d59 --- /dev/null +++ b/examples/PACKAGES/reaction/tiny_polystyrene/chain_plus_styrene_reacted.molecule_template @@ -0,0 +1,484 @@ +chain_plus_styrene_reacted + + 46 atoms + 48 bonds + 81 angles + 121 dihedrals + 19 impropers + +Coords + + 1 24.130699158 1.043900013 -1.309299946 + 2 25.062700272 1.582900047 -1.309299946 + 3 22.900699615 1.753900051 -1.309299946 + 4 22.900699615 3.253900051 -1.309299946 + 5 21.670700073 1.043900013 -1.309299946 + 6 20.738700867 1.582900047 -1.309299946 + 7 21.670700073 -0.376100004 -1.309299946 + 8 20.738700867 -0.915099978 -1.309299946 + 9 22.900699615 -1.086099982 -1.309299946 + 10 22.900699615 -2.163100004 -1.309299946 + 11 24.130699158 -0.376100004 -1.309299946 + 12 25.062700272 -0.915099978 -1.309299946 + 13 23.766700745 3.658900023 -0.952300012 + 14 21.622699738 3.802900076 -1.871299982 + 15 21.672700882 4.544899940 -1.970299959 + 16 20.979700088 2.979899883 -2.165299892 + 17 13.465800285 0.682500005 -1.658900022 + 18 14.397800446 1.221500039 -1.658900022 + 19 12.235799789 1.392500043 -1.658900022 + 20 12.235799789 2.892499924 -1.658900022 + 21 11.005800247 0.682500005 -1.658900022 + 22 10.073800087 1.221500039 -1.658900022 + 23 11.005800247 -0.737500012 -1.658900022 + 24 10.073800087 -1.276499987 -1.658900022 + 25 12.235799789 -1.447499990 -1.658900022 + 26 12.235799789 -2.524499893 -1.658900022 + 27 13.465800285 -0.737500012 -1.658900022 + 28 14.397800446 -1.276499987 -1.658900022 + 29 13.101799965 3.297499895 -1.301900029 + 30 10.957799911 3.441499949 -2.220900059 + 31 18.663499832 0.855499983 -1.372099996 + 32 19.595500946 1.394500017 -1.372099996 + 33 17.433500290 1.565500021 -1.372099996 + 34 17.433500290 3.065500021 -1.372099996 + 35 16.203500748 0.855499983 -1.372099996 + 36 15.271499634 1.394500017 -1.372099996 + 37 16.203500748 -0.564499974 -1.372099996 + 38 15.271499634 -1.103500009 -1.372099996 + 39 17.433500290 -1.274500012 -1.372099996 + 40 17.433500290 -2.351500034 -1.372099996 + 41 18.663499832 -0.564499974 -1.372099996 + 42 19.595500946 -1.103500009 -1.372099996 + 43 18.299499512 3.470499992 -1.015100002 + 44 16.155500412 3.614500046 -1.934100032 + 45 16.205499649 4.356500149 -2.033099890 + 46 15.512499809 2.791500092 -2.228100061 + +Types + + 1 cp + 2 hc + 3 cp + 4 c1 + 5 cp + 6 hc + 7 cp + 8 hc + 9 cp + 10 hc + 11 cp + 12 hc + 13 hc + 14 c2 + 15 hc + 16 hc + 17 cp + 18 hc + 19 cp + 20 c1 + 21 cp + 22 hc + 23 cp + 24 hc + 25 cp + 26 hc + 27 cp + 28 hc + 29 hc + 30 c2 + 31 cp + 32 hc + 33 cp + 34 c1 + 35 cp + 36 hc + 37 cp + 38 hc + 39 cp + 40 hc + 41 cp + 42 hc + 43 hc + 44 c2 + 45 hc + 46 hc + +Charges + + 1 -0.129000 + 2 0.123700 + 3 0.026600 + 4 -0.018200 + 5 -0.129000 + 6 0.123700 + 7 -0.173400 + 8 0.140300 + 9 -0.113400 + 10 0.128800 + 11 -0.173400 + 12 0.140300 + 13 0.051600 + 14 -0.069600 + 15 0.035400 + 16 0.035400 + 17 -0.129000 + 18 0.123700 + 19 0.026600 + 20 -0.018200 + 21 -0.129000 + 22 0.123700 + 23 -0.173400 + 24 0.140300 + 25 -0.113400 + 26 0.128800 + 27 -0.173400 + 28 0.140300 + 29 0.051600 + 30 -0.069600 + 31 -0.129000 + 32 0.123700 + 33 0.026600 + 34 -0.018200 + 35 -0.129000 + 36 0.123700 + 37 -0.173400 + 38 0.140300 + 39 -0.113400 + 40 0.128800 + 41 -0.173400 + 42 0.140300 + 43 0.051600 + 44 -0.069600 + 45 0.035400 + 46 0.035400 + +Molecules + + 1 1 + 2 1 + 3 1 + 4 1 + 5 1 + 6 1 + 7 1 + 8 1 + 9 1 + 10 1 + 11 1 + 12 1 + 13 1 + 14 1 + 15 1 + 16 1 + 17 1 + 18 1 + 19 1 + 20 1 + 21 1 + 22 1 + 23 1 + 24 1 + 25 1 + 26 1 + 27 1 + 28 1 + 29 1 + 30 1 + 31 1 + 32 1 + 33 1 + 34 1 + 35 1 + 36 1 + 37 1 + 38 1 + 39 1 + 40 1 + 41 1 + 42 1 + 43 1 + 44 1 + 45 1 + 46 1 + +Bonds + + 1 cp-hc 1 2 + 2 cp-cp 1 3 + 3 cp-cp 1 11 + 4 cp-c1 3 4 + 5 cp-cp 3 5 + 6 hc-c1 13 4 + 7 c1-c2 4 14 + 8 cp-hc 5 6 + 9 cp-cp 5 7 + 10 cp-hc 7 8 + 11 cp-cp 7 9 + 12 cp-hc 9 10 + 13 cp-cp 9 11 + 14 cp-hc 11 12 + 15 hc-c2 15 14 + 16 hc-c2 16 14 + 17 c1-c2 34 14 + 18 cp-hc 17 18 + 19 cp-cp 17 19 + 20 cp-cp 17 27 + 21 cp-c1 19 20 + 22 cp-cp 19 21 + 23 hc-c1 29 20 + 24 c1-c2 20 30 + 25 c1-c2 20 44 + 26 cp-hc 21 22 + 27 cp-cp 21 23 + 28 cp-hc 23 24 + 29 cp-cp 23 25 + 30 cp-hc 25 26 + 31 cp-cp 25 27 + 32 cp-hc 27 28 + 33 cp-hc 31 32 + 34 cp-cp 31 33 + 35 cp-cp 31 41 + 36 cp-c1 33 34 + 37 cp-cp 33 35 + 38 hc-c1 43 34 + 39 c1-c2 34 44 + 40 cp-hc 35 36 + 41 cp-cp 35 37 + 42 cp-hc 37 38 + 43 cp-cp 37 39 + 44 cp-hc 39 40 + 45 cp-cp 39 41 + 46 cp-hc 41 42 + 47 hc-c2 45 44 + 48 hc-c2 46 44 + +Angles + + 1 cp-cp-hc 3 1 2 + 2 cp-cp-hc 11 1 2 + 3 cp-cp-cp 3 1 11 + 4 cp-cp-c1 1 3 4 + 5 cp-cp-cp 1 3 5 + 6 cp-cp-c1 5 3 4 + 7 cp-c1-hc 3 4 13 + 8 cp-c1-c2 3 4 14 + 9 hc-c1-c2 13 4 14 + 10 cp-cp-hc 3 5 6 + 11 cp-cp-cp 3 5 7 + 12 cp-cp-hc 7 5 6 + 13 cp-cp-hc 5 7 8 + 14 cp-cp-cp 5 7 9 + 15 cp-cp-hc 9 7 8 + 16 cp-cp-hc 7 9 10 + 17 cp-cp-cp 7 9 11 + 18 cp-cp-hc 11 9 10 + 19 cp-cp-cp 1 11 9 + 20 cp-cp-hc 1 11 12 + 21 cp-cp-hc 9 11 12 + 22 hc-c2-c1 15 14 4 + 23 hc-c2-c1 16 14 4 + 24 c1-c2-c1 4 14 34 + 25 hc-c2-hc 15 14 16 + 26 hc-c2-c1 15 14 34 + 27 hc-c2-c1 16 14 34 + 28 cp-cp-hc 19 17 18 + 29 cp-cp-hc 27 17 18 + 30 cp-cp-cp 19 17 27 + 31 cp-cp-c1 17 19 20 + 32 cp-cp-cp 17 19 21 + 33 cp-cp-c1 21 19 20 + 34 cp-c1-hc 19 20 29 + 35 cp-c1-c2 19 20 30 + 36 cp-c1-c2 19 20 44 + 37 hc-c1-c2 29 20 30 + 38 hc-c1-c2 29 20 44 + 39 c2-c1-c2 30 20 44 + 40 cp-cp-hc 19 21 22 + 41 cp-cp-cp 19 21 23 + 42 cp-cp-hc 23 21 22 + 43 cp-cp-hc 21 23 24 + 44 cp-cp-cp 21 23 25 + 45 cp-cp-hc 25 23 24 + 46 cp-cp-hc 23 25 26 + 47 cp-cp-cp 23 25 27 + 48 cp-cp-hc 27 25 26 + 49 cp-cp-cp 17 27 25 + 50 cp-cp-hc 17 27 28 + 51 cp-cp-hc 25 27 28 + 52 cp-cp-hc 33 31 32 + 53 cp-cp-hc 41 31 32 + 54 cp-cp-cp 33 31 41 + 55 cp-cp-c1 31 33 34 + 56 cp-cp-cp 31 33 35 + 57 cp-cp-c1 35 33 34 + 58 cp-c1-c2 33 34 14 + 59 hc-c1-c2 43 34 14 + 60 c2-c1-c2 14 34 44 + 61 cp-c1-hc 33 34 43 + 62 cp-c1-c2 33 34 44 + 63 hc-c1-c2 43 34 44 + 64 cp-cp-hc 33 35 36 + 65 cp-cp-cp 33 35 37 + 66 cp-cp-hc 37 35 36 + 67 cp-cp-hc 35 37 38 + 68 cp-cp-cp 35 37 39 + 69 cp-cp-hc 39 37 38 + 70 cp-cp-hc 37 39 40 + 71 cp-cp-cp 37 39 41 + 72 cp-cp-hc 41 39 40 + 73 cp-cp-cp 31 41 39 + 74 cp-cp-hc 31 41 42 + 75 cp-cp-hc 39 41 42 + 76 c1-c2-c1 20 44 34 + 77 hc-c2-c1 45 44 20 + 78 hc-c2-c1 46 44 20 + 79 hc-c2-c1 45 44 34 + 80 hc-c2-c1 46 44 34 + 81 hc-c2-hc 45 44 46 + +Dihedrals + + 1 hc-cp-cp-c1 2 1 3 4 + 2 cp-cp-cp-hc 5 3 1 2 + 3 cp-cp-cp-c1 11 1 3 4 + 4 cp-cp-cp-cp 11 1 3 5 + 5 cp-cp-cp-hc 9 11 1 2 + 6 hc-cp-cp-hc 2 1 11 12 + 7 cp-cp-cp-cp 3 1 11 9 + 8 cp-cp-cp-hc 3 1 11 12 + 9 cp-cp-c1-hc 1 3 4 13 + 10 cp-cp-c1-c2 1 3 4 14 + 11 cp-cp-c1-hc 5 3 4 13 + 12 cp-cp-c1-c2 5 3 4 14 + 13 cp-cp-cp-hc 1 3 5 6 + 14 cp-cp-cp-cp 1 3 5 7 + 15 hc-cp-cp-c1 6 5 3 4 + 16 cp-cp-cp-c1 7 5 3 4 + 17 cp-c1-c2-hc 3 4 14 15 + 18 cp-c1-c2-hc 3 4 14 16 + 19 cp-c1-c2-c1 3 4 14 34 + 20 hc-c1-c2-hc 13 4 14 15 + 21 hc-c1-c2-hc 13 4 14 16 + 22 hc-c1-c2-c1 13 4 14 34 + 23 cp-cp-cp-hc 3 5 7 8 + 24 cp-cp-cp-cp 3 5 7 9 + 25 hc-cp-cp-hc 6 5 7 8 + 26 cp-cp-cp-hc 9 7 5 6 + 27 cp-cp-cp-hc 5 7 9 10 + 28 cp-cp-cp-cp 5 7 9 11 + 29 hc-cp-cp-hc 8 7 9 10 + 30 cp-cp-cp-hc 11 9 7 8 + 31 cp-cp-cp-cp 7 9 11 1 + 32 cp-cp-cp-hc 7 9 11 12 + 33 cp-cp-cp-hc 1 11 9 10 + 34 hc-cp-cp-hc 10 9 11 12 + 35 cp-c1-c2-c1 33 34 14 4 + 36 hc-c1-c2-c1 43 34 14 4 + 37 c2-c1-c2-c1 44 34 14 4 + 38 cp-c1-c2-hc 33 34 14 15 + 39 hc-c1-c2-hc 43 34 14 15 + 40 c2-c1-c2-hc 44 34 14 15 + 41 cp-c1-c2-hc 33 34 14 16 + 42 hc-c1-c2-hc 43 34 14 16 + 43 c2-c1-c2-hc 44 34 14 16 + 44 hc-cp-cp-c1 18 17 19 20 + 45 cp-cp-cp-hc 21 19 17 18 + 46 cp-cp-cp-c1 27 17 19 20 + 47 cp-cp-cp-cp 27 17 19 21 + 48 cp-cp-cp-hc 25 27 17 18 + 49 hc-cp-cp-hc 18 17 27 28 + 50 cp-cp-cp-cp 19 17 27 25 + 51 cp-cp-cp-hc 19 17 27 28 + 52 cp-cp-c1-hc 17 19 20 29 + 53 cp-cp-c1-c2 17 19 20 30 + 54 cp-cp-c1-c2 17 19 20 44 + 55 cp-cp-c1-hc 21 19 20 29 + 56 cp-cp-c1-c2 21 19 20 30 + 57 cp-cp-c1-c2 21 19 20 44 + 58 cp-cp-cp-hc 17 19 21 22 + 59 cp-cp-cp-cp 17 19 21 23 + 60 hc-cp-cp-c1 22 21 19 20 + 61 cp-cp-cp-c1 23 21 19 20 + 62 cp-c1-c2-c1 19 20 44 34 + 63 cp-c1-c2-hc 19 20 44 45 + 64 cp-c1-c2-hc 19 20 44 46 + 65 hc-c1-c2-c1 29 20 44 34 + 66 hc-c1-c2-hc 29 20 44 45 + 67 hc-c1-c2-hc 29 20 44 46 + 68 c2-c1-c2-c1 30 20 44 34 + 69 c2-c1-c2-hc 30 20 44 45 + 70 c2-c1-c2-hc 30 20 44 46 + 71 cp-cp-cp-hc 19 21 23 24 + 72 cp-cp-cp-cp 19 21 23 25 + 73 hc-cp-cp-hc 22 21 23 24 + 74 cp-cp-cp-hc 25 23 21 22 + 75 cp-cp-cp-hc 21 23 25 26 + 76 cp-cp-cp-cp 21 23 25 27 + 77 hc-cp-cp-hc 24 23 25 26 + 78 cp-cp-cp-hc 27 25 23 24 + 79 cp-cp-cp-cp 23 25 27 17 + 80 cp-cp-cp-hc 23 25 27 28 + 81 cp-cp-cp-hc 17 27 25 26 + 82 hc-cp-cp-hc 26 25 27 28 + 83 hc-cp-cp-c1 32 31 33 34 + 84 cp-cp-cp-hc 35 33 31 32 + 85 cp-cp-cp-c1 41 31 33 34 + 86 cp-cp-cp-cp 41 31 33 35 + 87 cp-cp-cp-hc 39 41 31 32 + 88 hc-cp-cp-hc 32 31 41 42 + 89 cp-cp-cp-cp 33 31 41 39 + 90 cp-cp-cp-hc 33 31 41 42 + 91 cp-cp-c1-c2 31 33 34 14 + 92 cp-cp-c1-hc 31 33 34 43 + 93 cp-cp-c1-c2 31 33 34 44 + 94 cp-cp-c1-c2 35 33 34 14 + 95 cp-cp-c1-hc 35 33 34 43 + 96 cp-cp-c1-c2 35 33 34 44 + 97 cp-cp-cp-hc 31 33 35 36 + 98 cp-cp-cp-cp 31 33 35 37 + 99 hc-cp-cp-c1 36 35 33 34 + 100 cp-cp-cp-c1 37 35 33 34 + 101 c2-c1-c2-c1 14 34 44 20 + 102 c2-c1-c2-hc 14 34 44 45 + 103 c2-c1-c2-hc 14 34 44 46 + 104 cp-c1-c2-c1 33 34 44 20 + 105 cp-c1-c2-hc 33 34 44 45 + 106 cp-c1-c2-hc 33 34 44 46 + 107 hc-c1-c2-c1 43 34 44 20 + 108 hc-c1-c2-hc 43 34 44 45 + 109 hc-c1-c2-hc 43 34 44 46 + 110 cp-cp-cp-hc 33 35 37 38 + 111 cp-cp-cp-cp 33 35 37 39 + 112 hc-cp-cp-hc 36 35 37 38 + 113 cp-cp-cp-hc 39 37 35 36 + 114 cp-cp-cp-hc 35 37 39 40 + 115 cp-cp-cp-cp 35 37 39 41 + 116 hc-cp-cp-hc 38 37 39 40 + 117 cp-cp-cp-hc 41 39 37 38 + 118 cp-cp-cp-cp 37 39 41 31 + 119 cp-cp-cp-hc 37 39 41 42 + 120 cp-cp-cp-hc 31 41 39 40 + 121 hc-cp-cp-hc 40 39 41 42 + +Impropers + + 1 cp-cp-cp-hc 3 1 11 2 + 2 cp-cp-cp-c1 1 3 5 4 + 3 cp-c1-hc-c2 3 4 13 14 + 4 cp-cp-cp-hc 3 5 7 6 + 5 cp-cp-cp-hc 5 7 9 8 + 6 cp-cp-cp-hc 7 9 11 10 + 7 cp-cp-cp-hc 1 11 9 12 + 8 cp-cp-cp-hc 19 17 27 18 + 9 cp-cp-cp-c1 17 19 21 20 + 10 cp-cp-cp-hc 19 21 23 22 + 11 cp-cp-cp-hc 21 23 25 24 + 12 cp-cp-cp-hc 23 25 27 26 + 13 cp-cp-cp-hc 17 27 25 28 + 14 cp-cp-cp-hc 33 31 41 32 + 15 cp-cp-cp-c1 31 33 35 34 + 16 cp-cp-cp-hc 33 35 37 36 + 17 cp-cp-cp-hc 35 37 39 38 + 18 cp-cp-cp-hc 37 39 41 40 + 19 cp-cp-cp-hc 31 41 39 42 diff --git a/examples/PACKAGES/reaction/tiny_polystyrene/chain_plus_styrene_unreacted.data_template b/examples/PACKAGES/reaction/tiny_polystyrene/chain_plus_styrene_unreacted.data_template deleted file mode 100644 index f76aad50e6..0000000000 --- a/examples/PACKAGES/reaction/tiny_polystyrene/chain_plus_styrene_unreacted.data_template +++ /dev/null @@ -1,422 +0,0 @@ -chain_plus_styrene_unreacted - -46 atoms -47 bonds -75 angles -105 dihedrals -29 impropers - -Types - -1 1 -2 2 -3 1 -4 3 -5 1 -6 2 -7 1 -8 2 -9 1 -10 2 -11 1 -12 2 -13 2 -14 4 -15 2 -16 2 -17 1 -18 2 -19 1 -20 5 -21 1 -22 2 -23 1 -24 2 -25 1 -26 2 -27 1 -28 2 -29 2 -30 6 -31 1 -32 2 -33 1 -34 5 -35 1 -36 2 -37 1 -38 2 -39 1 -40 2 -41 1 -42 2 -43 2 -44 6 -45 2 -46 2 - -Charges - -1 -0.129000 -2 0.123700 -3 0.026600 -4 -0.018200 -5 -0.129000 -6 0.123700 -7 -0.173400 -8 0.140300 -9 -0.113400 -10 0.128800 -11 -0.173400 -12 0.140300 -13 0.051600 -14 -0.069600 -15 0.035400 -16 0.035400 -17 -0.129000 -18 0.123700 -19 0.026600 -20 -0.018200 -21 -0.129000 -22 0.123700 -23 -0.173400 -24 0.140300 -25 -0.113400 -26 0.128800 -27 -0.173400 -28 0.140300 -29 0.051600 -30 -0.069600 -31 -0.129000 -32 0.123700 -33 0.026600 -34 -0.018200 -35 -0.129000 -36 0.123700 -37 -0.173400 -38 0.140300 -39 -0.113400 -40 0.128800 -41 -0.173400 -42 0.140300 -43 0.051600 -44 -0.069600 -45 0.035400 -46 0.035400 - -Coords - -1 24.130699 1.043900 -1.309300 -2 25.062700 1.582900 -1.309300 -3 22.900700 1.753900 -1.309300 -4 22.900700 3.253900 -1.309300 -5 21.670700 1.043900 -1.309300 -6 20.738701 1.582900 -1.309300 -7 21.670700 -0.376100 -1.309300 -8 20.738701 -0.915100 -1.309300 -9 22.900700 -1.086100 -1.309300 -10 22.900700 -2.163100 -1.309300 -11 24.130699 -0.376100 -1.309300 -12 25.062700 -0.915100 -1.309300 -13 23.766701 3.658900 -0.952300 -14 21.622700 3.802900 -1.871300 -15 21.672701 4.544900 -1.970300 -16 20.979700 2.979900 -2.165300 -17 13.465800 0.682500 -1.658900 -18 14.397800 1.221500 -1.658900 -19 12.235800 1.392500 -1.658900 -20 12.235800 2.892500 -1.658900 -21 11.005800 0.682500 -1.658900 -22 10.073800 1.221500 -1.658900 -23 11.005800 -0.737500 -1.658900 -24 10.073800 -1.276500 -1.658900 -25 12.235800 -1.447500 -1.658900 -26 12.235800 -2.524500 -1.658900 -27 13.465800 -0.737500 -1.658900 -28 14.397800 -1.276500 -1.658900 -29 13.101800 3.297500 -1.301900 -30 10.957800 3.441500 -2.220900 -31 18.663500 0.855500 -1.372100 -32 19.595501 1.394500 -1.372100 -33 17.433500 1.565500 -1.372100 -34 17.433500 3.065500 -1.372100 -35 16.203501 0.855500 -1.372100 -36 15.271500 1.394500 -1.372100 -37 16.203501 -0.564500 -1.372100 -38 15.271500 -1.103500 -1.372100 -39 17.433500 -1.274500 -1.372100 -40 17.433500 -2.351500 -1.372100 -41 18.663500 -0.564500 -1.372100 -42 19.595501 -1.103500 -1.372100 -43 18.299500 3.470500 -1.015100 -44 16.155500 3.614500 -1.934100 -45 16.205500 4.356500 -2.033100 -46 15.512500 2.791500 -2.228100 - -Bonds - -1 1 1 2 -2 2 1 3 -3 2 1 11 -4 3 3 4 -5 2 3 5 -6 4 13 4 -7 5 4 14 -8 1 5 6 -9 2 5 7 -10 1 7 8 -11 2 7 9 -12 1 9 10 -13 2 9 11 -14 1 11 12 -15 6 15 14 -16 6 16 14 -17 1 17 18 -18 2 17 19 -19 2 17 27 -20 7 19 20 -21 2 19 21 -22 8 29 20 -23 9 20 30 -24 9 20 44 -25 1 21 22 -26 2 21 23 -27 1 23 24 -28 2 23 25 -29 1 25 26 -30 2 25 27 -31 1 27 28 -32 1 31 32 -33 2 31 33 -34 2 31 41 -35 7 33 34 -36 2 33 35 -37 8 43 34 -38 9 34 44 -39 1 35 36 -40 2 35 37 -41 1 37 38 -42 2 37 39 -43 1 39 40 -44 2 39 41 -45 1 41 42 -46 10 45 44 -47 10 46 44 - -Angles - -1 1 3 1 2 -2 1 11 1 2 -3 2 3 1 11 -4 3 1 3 4 -5 2 1 3 5 -6 3 5 3 4 -7 4 3 4 13 -8 5 3 4 14 -9 6 13 4 14 -10 1 3 5 6 -11 2 3 5 7 -12 1 7 5 6 -13 1 5 7 8 -14 2 5 7 9 -15 1 9 7 8 -16 1 7 9 10 -17 2 7 9 11 -18 1 11 9 10 -19 2 1 11 9 -20 1 1 11 12 -21 1 9 11 12 -22 7 15 14 4 -23 7 16 14 4 -24 8 15 14 16 -25 1 19 17 18 -26 1 27 17 18 -27 2 19 17 27 -28 9 17 19 20 -29 2 17 19 21 -30 9 21 19 20 -31 10 19 20 29 -32 11 19 20 30 -33 11 19 20 44 -34 12 29 20 30 -35 12 29 20 44 -36 13 30 20 44 -37 1 19 21 22 -38 2 19 21 23 -39 1 23 21 22 -40 1 21 23 24 -41 2 21 23 25 -42 1 25 23 24 -43 1 23 25 26 -44 2 23 25 27 -45 1 27 25 26 -46 2 17 27 25 -47 1 17 27 28 -48 1 25 27 28 -49 1 33 31 32 -50 1 41 31 32 -51 2 33 31 41 -52 9 31 33 34 -53 2 31 33 35 -54 9 35 33 34 -55 10 33 34 43 -56 11 33 34 44 -57 12 43 34 44 -58 1 33 35 36 -59 2 33 35 37 -60 1 37 35 36 -61 1 35 37 38 -62 2 35 37 39 -63 1 39 37 38 -64 1 37 39 40 -65 2 37 39 41 -66 1 41 39 40 -67 2 31 41 39 -68 1 31 41 42 -69 1 39 41 42 -70 16 20 44 34 -71 14 45 44 20 -72 14 46 44 20 -73 14 45 44 34 -74 14 46 44 34 -75 15 45 44 46 - -Dihedrals - -1 1 2 1 3 4 -2 2 5 3 1 2 -3 3 11 1 3 4 -4 4 11 1 3 5 -5 2 9 11 1 2 -6 5 2 1 11 12 -7 4 3 1 11 9 -8 2 3 1 11 12 -9 6 1 3 4 13 -10 7 1 3 4 14 -11 6 5 3 4 13 -12 7 5 3 4 14 -13 2 1 3 5 6 -14 4 1 3 5 7 -15 1 6 5 3 4 -16 3 7 5 3 4 -17 8 3 4 14 15 -18 8 3 4 14 16 -19 9 13 4 14 15 -20 9 13 4 14 16 -21 2 3 5 7 8 -22 4 3 5 7 9 -23 5 6 5 7 8 -24 2 9 7 5 6 -25 2 5 7 9 10 -26 4 5 7 9 11 -27 5 8 7 9 10 -28 2 11 9 7 8 -29 4 7 9 11 1 -30 2 7 9 11 12 -31 2 1 11 9 10 -32 5 10 9 11 12 -33 10 18 17 19 20 -34 2 21 19 17 18 -35 11 27 17 19 20 -36 4 27 17 19 21 -37 2 25 27 17 18 -38 5 18 17 27 28 -39 4 19 17 27 25 -40 2 19 17 27 28 -41 12 17 19 20 29 -42 13 17 19 20 30 -43 13 17 19 20 44 -44 12 21 19 20 29 -45 13 21 19 20 30 -46 13 21 19 20 44 -47 2 17 19 21 22 -48 4 17 19 21 23 -49 10 22 21 19 20 -50 11 23 21 19 20 -51 17 19 20 44 34 -52 14 19 20 44 45 -53 14 19 20 44 46 -54 18 29 20 44 34 -55 15 29 20 44 45 -56 15 29 20 44 46 -57 19 30 20 44 34 -58 16 30 20 44 45 -59 16 30 20 44 46 -60 2 19 21 23 24 -61 4 19 21 23 25 -62 5 22 21 23 24 -63 2 25 23 21 22 -64 2 21 23 25 26 -65 4 21 23 25 27 -66 5 24 23 25 26 -67 2 27 25 23 24 -68 4 23 25 27 17 -69 2 23 25 27 28 -70 2 17 27 25 26 -71 5 26 25 27 28 -72 10 32 31 33 34 -73 2 35 33 31 32 -74 11 41 31 33 34 -75 4 41 31 33 35 -76 2 39 41 31 32 -77 5 32 31 41 42 -78 4 33 31 41 39 -79 2 33 31 41 42 -80 12 31 33 34 43 -81 13 31 33 34 44 -82 12 35 33 34 43 -83 13 35 33 34 44 -84 2 31 33 35 36 -85 4 31 33 35 37 -86 10 36 35 33 34 -87 11 37 35 33 34 -88 17 33 34 44 20 -89 14 33 34 44 45 -90 14 33 34 44 46 -91 18 43 34 44 20 -92 15 43 34 44 45 -93 15 43 34 44 46 -94 2 33 35 37 38 -95 4 33 35 37 39 -96 5 36 35 37 38 -97 2 39 37 35 36 -98 2 35 37 39 40 -99 4 35 37 39 41 -100 5 38 37 39 40 -101 2 41 39 37 38 -102 4 37 39 41 31 -103 2 37 39 41 42 -104 2 31 41 39 40 -105 5 40 39 41 42 - -Impropers - -1 1 3 1 11 2 -2 2 1 3 5 4 -3 3 3 4 13 14 -4 1 3 5 7 6 -5 1 5 7 9 8 -6 1 7 9 11 10 -7 1 1 11 9 12 -8 4 15 14 16 4 -9 1 19 17 27 18 -10 5 17 19 21 20 -11 1 19 21 23 22 -12 1 21 23 25 24 -13 1 23 25 27 26 -14 1 17 27 25 28 -15 1 33 31 41 32 -16 5 31 33 35 34 -17 7 33 34 43 44 -18 1 33 35 37 36 -19 1 35 37 39 38 -20 1 37 39 41 40 -21 1 31 41 39 42 -22 1 19 20 29 30 -23 1 19 20 29 44 -24 1 19 20 30 44 -25 1 29 20 30 44 -26 1 45 44 34 20 -27 1 46 44 34 20 -28 1 45 44 46 20 -29 1 45 44 46 34 diff --git a/examples/PACKAGES/reaction/tiny_polystyrene/chain_plus_styrene_unreacted.molecule_template b/examples/PACKAGES/reaction/tiny_polystyrene/chain_plus_styrene_unreacted.molecule_template new file mode 100644 index 0000000000..f43993e2d6 --- /dev/null +++ b/examples/PACKAGES/reaction/tiny_polystyrene/chain_plus_styrene_unreacted.molecule_template @@ -0,0 +1,463 @@ +chain_plus_styrene_unreacted + + 46 atoms + 47 bonds + 75 angles + 105 dihedrals + 21 impropers + +Coords + + 1 24.130699158 1.043900013 -1.309299946 + 2 25.062700272 1.582900047 -1.309299946 + 3 22.900699615 1.753900051 -1.309299946 + 4 22.900699615 3.253900051 -1.309299946 + 5 21.670700073 1.043900013 -1.309299946 + 6 20.738700867 1.582900047 -1.309299946 + 7 21.670700073 -0.376100004 -1.309299946 + 8 20.738700867 -0.915099978 -1.309299946 + 9 22.900699615 -1.086099982 -1.309299946 + 10 22.900699615 -2.163100004 -1.309299946 + 11 24.130699158 -0.376100004 -1.309299946 + 12 25.062700272 -0.915099978 -1.309299946 + 13 23.766700745 3.658900023 -0.952300012 + 14 21.622699738 3.802900076 -1.871299982 + 15 21.672700882 4.544899940 -1.970299959 + 16 20.979700088 2.979899883 -2.165299892 + 17 13.465800285 0.682500005 -1.658900022 + 18 14.397800446 1.221500039 -1.658900022 + 19 12.235799789 1.392500043 -1.658900022 + 20 12.235799789 2.892499924 -1.658900022 + 21 11.005800247 0.682500005 -1.658900022 + 22 10.073800087 1.221500039 -1.658900022 + 23 11.005800247 -0.737500012 -1.658900022 + 24 10.073800087 -1.276499987 -1.658900022 + 25 12.235799789 -1.447499990 -1.658900022 + 26 12.235799789 -2.524499893 -1.658900022 + 27 13.465800285 -0.737500012 -1.658900022 + 28 14.397800446 -1.276499987 -1.658900022 + 29 13.101799965 3.297499895 -1.301900029 + 30 10.957799911 3.441499949 -2.220900059 + 31 18.663499832 0.855499983 -1.372099996 + 32 19.595500946 1.394500017 -1.372099996 + 33 17.433500290 1.565500021 -1.372099996 + 34 17.433500290 3.065500021 -1.372099996 + 35 16.203500748 0.855499983 -1.372099996 + 36 15.271499634 1.394500017 -1.372099996 + 37 16.203500748 -0.564499974 -1.372099996 + 38 15.271499634 -1.103500009 -1.372099996 + 39 17.433500290 -1.274500012 -1.372099996 + 40 17.433500290 -2.351500034 -1.372099996 + 41 18.663499832 -0.564499974 -1.372099996 + 42 19.595500946 -1.103500009 -1.372099996 + 43 18.299499512 3.470499992 -1.015100002 + 44 16.155500412 3.614500046 -1.934100032 + 45 16.205499649 4.356500149 -2.033099890 + 46 15.512499809 2.791500092 -2.228100061 + +Types + + 1 cp + 2 hc + 3 cp + 4 c=1 + 5 cp + 6 hc + 7 cp + 8 hc + 9 cp + 10 hc + 11 cp + 12 hc + 13 hc + 14 c= + 15 hc + 16 hc + 17 cp + 18 hc + 19 cp + 20 c1 + 21 cp + 22 hc + 23 cp + 24 hc + 25 cp + 26 hc + 27 cp + 28 hc + 29 hc + 30 c2 + 31 cp + 32 hc + 33 cp + 34 c1 + 35 cp + 36 hc + 37 cp + 38 hc + 39 cp + 40 hc + 41 cp + 42 hc + 43 hc + 44 c2 + 45 hc + 46 hc + +Charges + + 1 -0.129000 + 2 0.123700 + 3 0.026600 + 4 -0.018200 + 5 -0.129000 + 6 0.123700 + 7 -0.173400 + 8 0.140300 + 9 -0.113400 + 10 0.128800 + 11 -0.173400 + 12 0.140300 + 13 0.051600 + 14 -0.069600 + 15 0.035400 + 16 0.035400 + 17 -0.129000 + 18 0.123700 + 19 0.026600 + 20 -0.018200 + 21 -0.129000 + 22 0.123700 + 23 -0.173400 + 24 0.140300 + 25 -0.113400 + 26 0.128800 + 27 -0.173400 + 28 0.140300 + 29 0.051600 + 30 -0.069600 + 31 -0.129000 + 32 0.123700 + 33 0.026600 + 34 -0.018200 + 35 -0.129000 + 36 0.123700 + 37 -0.173400 + 38 0.140300 + 39 -0.113400 + 40 0.128800 + 41 -0.173400 + 42 0.140300 + 43 0.051600 + 44 -0.069600 + 45 0.035400 + 46 0.035400 + +Molecules + + 1 1 + 2 1 + 3 1 + 4 1 + 5 1 + 6 1 + 7 1 + 8 1 + 9 1 + 10 1 + 11 1 + 12 1 + 13 1 + 14 1 + 15 1 + 16 1 + 17 1 + 18 1 + 19 1 + 20 1 + 21 1 + 22 1 + 23 1 + 24 1 + 25 1 + 26 1 + 27 1 + 28 1 + 29 1 + 30 1 + 31 1 + 32 1 + 33 1 + 34 1 + 35 1 + 36 1 + 37 1 + 38 1 + 39 1 + 40 1 + 41 1 + 42 1 + 43 1 + 44 1 + 45 1 + 46 1 + +Bonds + + 1 cp-hc 1 2 + 2 cp-cp 1 3 + 3 cp-cp 1 11 + 4 cp-c=1 3 4 + 5 cp-cp 3 5 + 6 hc-c=1 13 4 + 7 c=1-c= 4 14 + 8 cp-hc 5 6 + 9 cp-cp 5 7 + 10 cp-hc 7 8 + 11 cp-cp 7 9 + 12 cp-hc 9 10 + 13 cp-cp 9 11 + 14 cp-hc 11 12 + 15 hc-c= 15 14 + 16 hc-c= 16 14 + 17 cp-hc 17 18 + 18 cp-cp 17 19 + 19 cp-cp 17 27 + 20 cp-c1 19 20 + 21 cp-cp 19 21 + 22 hc-c1 29 20 + 23 c1-c2 20 30 + 24 c1-c2 20 44 + 25 cp-hc 21 22 + 26 cp-cp 21 23 + 27 cp-hc 23 24 + 28 cp-cp 23 25 + 29 cp-hc 25 26 + 30 cp-cp 25 27 + 31 cp-hc 27 28 + 32 cp-hc 31 32 + 33 cp-cp 31 33 + 34 cp-cp 31 41 + 35 cp-c1 33 34 + 36 cp-cp 33 35 + 37 hc-c1 43 34 + 38 c1-c2 34 44 + 39 cp-hc 35 36 + 40 cp-cp 35 37 + 41 cp-hc 37 38 + 42 cp-cp 37 39 + 43 cp-hc 39 40 + 44 cp-cp 39 41 + 45 cp-hc 41 42 + 46 hc-c2 45 44 + 47 hc-c2 46 44 + +Angles + + 1 cp-cp-hc 3 1 2 + 2 cp-cp-hc 11 1 2 + 3 cp-cp-cp 3 1 11 + 4 cp-cp-c=1 1 3 4 + 5 cp-cp-cp 1 3 5 + 6 cp-cp-c=1 5 3 4 + 7 cp-c=1-hc 3 4 13 + 8 cp-c=1-c= 3 4 14 + 9 hc-c=1-c= 13 4 14 + 10 cp-cp-hc 3 5 6 + 11 cp-cp-cp 3 5 7 + 12 cp-cp-hc 7 5 6 + 13 cp-cp-hc 5 7 8 + 14 cp-cp-cp 5 7 9 + 15 cp-cp-hc 9 7 8 + 16 cp-cp-hc 7 9 10 + 17 cp-cp-cp 7 9 11 + 18 cp-cp-hc 11 9 10 + 19 cp-cp-cp 1 11 9 + 20 cp-cp-hc 1 11 12 + 21 cp-cp-hc 9 11 12 + 22 hc-c=-c=1 15 14 4 + 23 hc-c=-c=1 16 14 4 + 24 hc-c=-hc 15 14 16 + 25 cp-cp-hc 19 17 18 + 26 cp-cp-hc 27 17 18 + 27 cp-cp-cp 19 17 27 + 28 cp-cp-c1 17 19 20 + 29 cp-cp-cp 17 19 21 + 30 cp-cp-c1 21 19 20 + 31 cp-c1-hc 19 20 29 + 32 cp-c1-c2 19 20 30 + 33 cp-c1-c2 19 20 44 + 34 hc-c1-c2 29 20 30 + 35 hc-c1-c2 29 20 44 + 36 c2-c1-c2 30 20 44 + 37 cp-cp-hc 19 21 22 + 38 cp-cp-cp 19 21 23 + 39 cp-cp-hc 23 21 22 + 40 cp-cp-hc 21 23 24 + 41 cp-cp-cp 21 23 25 + 42 cp-cp-hc 25 23 24 + 43 cp-cp-hc 23 25 26 + 44 cp-cp-cp 23 25 27 + 45 cp-cp-hc 27 25 26 + 46 cp-cp-cp 17 27 25 + 47 cp-cp-hc 17 27 28 + 48 cp-cp-hc 25 27 28 + 49 cp-cp-hc 33 31 32 + 50 cp-cp-hc 41 31 32 + 51 cp-cp-cp 33 31 41 + 52 cp-cp-c1 31 33 34 + 53 cp-cp-cp 31 33 35 + 54 cp-cp-c1 35 33 34 + 55 cp-c1-hc 33 34 43 + 56 cp-c1-c2 33 34 44 + 57 hc-c1-c2 43 34 44 + 58 cp-cp-hc 33 35 36 + 59 cp-cp-cp 33 35 37 + 60 cp-cp-hc 37 35 36 + 61 cp-cp-hc 35 37 38 + 62 cp-cp-cp 35 37 39 + 63 cp-cp-hc 39 37 38 + 64 cp-cp-hc 37 39 40 + 65 cp-cp-cp 37 39 41 + 66 cp-cp-hc 41 39 40 + 67 cp-cp-cp 31 41 39 + 68 cp-cp-hc 31 41 42 + 69 cp-cp-hc 39 41 42 + 70 c1-c2-c1 20 44 34 + 71 hc-c2-c1 45 44 20 + 72 hc-c2-c1 46 44 20 + 73 hc-c2-c1 45 44 34 + 74 hc-c2-c1 46 44 34 + 75 hc-c2-hc 45 44 46 + +Dihedrals + + 1 hc-cp-cp-c=1 2 1 3 4 + 2 cp-cp-cp-hc 5 3 1 2 + 3 cp-cp-cp-c=1 11 1 3 4 + 4 cp-cp-cp-cp 11 1 3 5 + 5 cp-cp-cp-hc 9 11 1 2 + 6 hc-cp-cp-hc 2 1 11 12 + 7 cp-cp-cp-cp 3 1 11 9 + 8 cp-cp-cp-hc 3 1 11 12 + 9 cp-cp-c=1-hc 1 3 4 13 + 10 cp-cp-c=1-c= 1 3 4 14 + 11 cp-cp-c=1-hc 5 3 4 13 + 12 cp-cp-c=1-c= 5 3 4 14 + 13 cp-cp-cp-hc 1 3 5 6 + 14 cp-cp-cp-cp 1 3 5 7 + 15 hc-cp-cp-c=1 6 5 3 4 + 16 cp-cp-cp-c=1 7 5 3 4 + 17 cp-c=1-c=-hc 3 4 14 15 + 18 cp-c=1-c=-hc 3 4 14 16 + 19 hc-c=1-c=-hc 13 4 14 15 + 20 hc-c=1-c=-hc 13 4 14 16 + 21 cp-cp-cp-hc 3 5 7 8 + 22 cp-cp-cp-cp 3 5 7 9 + 23 hc-cp-cp-hc 6 5 7 8 + 24 cp-cp-cp-hc 9 7 5 6 + 25 cp-cp-cp-hc 5 7 9 10 + 26 cp-cp-cp-cp 5 7 9 11 + 27 hc-cp-cp-hc 8 7 9 10 + 28 cp-cp-cp-hc 11 9 7 8 + 29 cp-cp-cp-cp 7 9 11 1 + 30 cp-cp-cp-hc 7 9 11 12 + 31 cp-cp-cp-hc 1 11 9 10 + 32 hc-cp-cp-hc 10 9 11 12 + 33 hc-cp-cp-c1 18 17 19 20 + 34 cp-cp-cp-hc 21 19 17 18 + 35 cp-cp-cp-c1 27 17 19 20 + 36 cp-cp-cp-cp 27 17 19 21 + 37 cp-cp-cp-hc 25 27 17 18 + 38 hc-cp-cp-hc 18 17 27 28 + 39 cp-cp-cp-cp 19 17 27 25 + 40 cp-cp-cp-hc 19 17 27 28 + 41 cp-cp-c1-hc 17 19 20 29 + 42 cp-cp-c1-c2 17 19 20 30 + 43 cp-cp-c1-c2 17 19 20 44 + 44 cp-cp-c1-hc 21 19 20 29 + 45 cp-cp-c1-c2 21 19 20 30 + 46 cp-cp-c1-c2 21 19 20 44 + 47 cp-cp-cp-hc 17 19 21 22 + 48 cp-cp-cp-cp 17 19 21 23 + 49 hc-cp-cp-c1 22 21 19 20 + 50 cp-cp-cp-c1 23 21 19 20 + 51 cp-c1-c2-c1 19 20 44 34 + 52 cp-c1-c2-hc 19 20 44 45 + 53 cp-c1-c2-hc 19 20 44 46 + 54 hc-c1-c2-c1 29 20 44 34 + 55 hc-c1-c2-hc 29 20 44 45 + 56 hc-c1-c2-hc 29 20 44 46 + 57 c2-c1-c2-c1 30 20 44 34 + 58 c2-c1-c2-hc 30 20 44 45 + 59 c2-c1-c2-hc 30 20 44 46 + 60 cp-cp-cp-hc 19 21 23 24 + 61 cp-cp-cp-cp 19 21 23 25 + 62 hc-cp-cp-hc 22 21 23 24 + 63 cp-cp-cp-hc 25 23 21 22 + 64 cp-cp-cp-hc 21 23 25 26 + 65 cp-cp-cp-cp 21 23 25 27 + 66 hc-cp-cp-hc 24 23 25 26 + 67 cp-cp-cp-hc 27 25 23 24 + 68 cp-cp-cp-cp 23 25 27 17 + 69 cp-cp-cp-hc 23 25 27 28 + 70 cp-cp-cp-hc 17 27 25 26 + 71 hc-cp-cp-hc 26 25 27 28 + 72 hc-cp-cp-c1 32 31 33 34 + 73 cp-cp-cp-hc 35 33 31 32 + 74 cp-cp-cp-c1 41 31 33 34 + 75 cp-cp-cp-cp 41 31 33 35 + 76 cp-cp-cp-hc 39 41 31 32 + 77 hc-cp-cp-hc 32 31 41 42 + 78 cp-cp-cp-cp 33 31 41 39 + 79 cp-cp-cp-hc 33 31 41 42 + 80 cp-cp-c1-hc 31 33 34 43 + 81 cp-cp-c1-c2 31 33 34 44 + 82 cp-cp-c1-hc 35 33 34 43 + 83 cp-cp-c1-c2 35 33 34 44 + 84 cp-cp-cp-hc 31 33 35 36 + 85 cp-cp-cp-cp 31 33 35 37 + 86 hc-cp-cp-c1 36 35 33 34 + 87 cp-cp-cp-c1 37 35 33 34 + 88 cp-c1-c2-c1 33 34 44 20 + 89 cp-c1-c2-hc 33 34 44 45 + 90 cp-c1-c2-hc 33 34 44 46 + 91 hc-c1-c2-c1 43 34 44 20 + 92 hc-c1-c2-hc 43 34 44 45 + 93 hc-c1-c2-hc 43 34 44 46 + 94 cp-cp-cp-hc 33 35 37 38 + 95 cp-cp-cp-cp 33 35 37 39 + 96 hc-cp-cp-hc 36 35 37 38 + 97 cp-cp-cp-hc 39 37 35 36 + 98 cp-cp-cp-hc 35 37 39 40 + 99 cp-cp-cp-cp 35 37 39 41 + 100 hc-cp-cp-hc 38 37 39 40 + 101 cp-cp-cp-hc 41 39 37 38 + 102 cp-cp-cp-cp 37 39 41 31 + 103 cp-cp-cp-hc 37 39 41 42 + 104 cp-cp-cp-hc 31 41 39 40 + 105 hc-cp-cp-hc 40 39 41 42 + +Impropers + + 1 cp-cp-cp-hc 3 1 11 2 + 2 cp-cp-cp-c=1 1 3 5 4 + 3 cp-c=1-hc-c= 3 4 13 14 + 4 cp-cp-cp-hc 3 5 7 6 + 5 cp-cp-cp-hc 5 7 9 8 + 6 cp-cp-cp-hc 7 9 11 10 + 7 cp-cp-cp-hc 1 11 9 12 + 8 hc-c=-hc-c=1 15 14 16 4 + 9 cp-cp-cp-hc 19 17 27 18 + 10 cp-cp-cp-c1 17 19 21 20 + 11 cp-cp-cp-hc 19 21 23 22 + 12 cp-cp-cp-hc 21 23 25 24 + 13 cp-cp-cp-hc 23 25 27 26 + 14 cp-cp-cp-hc 17 27 25 28 + 15 cp-cp-cp-hc 33 31 41 32 + 16 cp-cp-cp-c1 31 33 35 34 + 17 cp-c1-hc-c2 33 34 43 44 + 18 cp-cp-cp-hc 33 35 37 36 + 19 cp-cp-cp-hc 35 37 39 38 + 20 cp-cp-cp-hc 37 39 41 40 + 21 cp-cp-cp-hc 31 41 39 42 diff --git a/examples/PACKAGES/reaction/tiny_polystyrene/in.tiny_polystyrene.stabilized b/examples/PACKAGES/reaction/tiny_polystyrene/in.tiny_polystyrene.stabilized index a711f3eaa9..ab9c012905 100644 --- a/examples/PACKAGES/reaction/tiny_polystyrene/in.tiny_polystyrene.stabilized +++ b/examples/PACKAGES/reaction/tiny_polystyrene/in.tiny_polystyrene.stabilized @@ -1,5 +1,5 @@ # 20 styrene molecules -# three reactions defined +# three reactions defined units real @@ -11,9 +11,9 @@ kspace_style pppm 1.0e-4 pair_style lj/class2/coul/long 8.5 -angle_style class2 +angle_style class2 -bond_style class2 +bond_style class2 dihedral_style class2 @@ -28,12 +28,12 @@ read_data tiny_polystyrene.data & extra/improper/per/atom 25 & extra/special/per/atom 25 -molecule mol1 2styrene_unreacted.data_template -molecule mol2 2styrene_reacted.data_template -molecule mol3 chain_plus_styrene_unreacted.data_template -molecule mol4 chain_plus_styrene_reacted.data_template -molecule mol5 chain_chain_unreacted.data_template -molecule mol6 chain_chain_reacted.data_template +molecule mol1 2styrene_unreacted.molecule_template +molecule mol2 2styrene_reacted.molecule_template +molecule mol3 chain_plus_styrene_unreacted.molecule_template +molecule mol4 chain_plus_styrene_reacted.molecule_template +molecule mol5 chain_chain_unreacted.molecule_template +molecule mol6 chain_chain_reacted.molecule_template thermo 100 @@ -53,4 +53,4 @@ thermo_style custom step temp press density f_rxn1[1] f_rxn1[2] f_rxn1[3] run 10000 # write_restart restart_longrun nofix -# write_data restart_longrun.data +# write_data restart_longrun.data diff --git a/examples/PACKAGES/reaction/tiny_polystyrene/log.20Nov19.tiny_polystyrene.stabilized.g++.1 b/examples/PACKAGES/reaction/tiny_polystyrene/log.20Nov19.tiny_polystyrene.stabilized.g++.1 deleted file mode 100644 index 274c72ece9..0000000000 --- a/examples/PACKAGES/reaction/tiny_polystyrene/log.20Nov19.tiny_polystyrene.stabilized.g++.1 +++ /dev/null @@ -1,245 +0,0 @@ -LAMMPS (20 Nov 2019) - -WARNING-WARNING-WARNING-WARNING-WARNING -This LAMMPS executable was compiled using C++98 compatibility. -Please report the compiler info below at https://github.com/lammps/lammps/issues/1659 -GNU C++ 4.8.5 -WARNING-WARNING-WARNING-WARNING-WARNING - -Reading data file ... - orthogonal box = (1.74267 1.74267 1.74267) to (18.2573 18.2573 18.2573) - 1 by 1 by 1 MPI processor grid - reading atoms ... - 320 atoms - reading velocities ... - 320 velocities - scanning bonds ... - 8 = max bonds/atom - scanning angles ... - 18 = max angles/atom - scanning dihedrals ... - 22 = max dihedrals/atom - scanning impropers ... - 26 = max impropers/atom - reading bonds ... - 320 bonds - reading angles ... - 480 angles - reading dihedrals ... - 640 dihedrals - reading impropers ... - 160 impropers -Finding 1-2 1-3 1-4 neighbors ... - special bond factors lj: 0 0 0 - special bond factors coul: 0 0 0 - 3 = max # of 1-2 neighbors - 6 = max # of 1-3 neighbors - 12 = max # of 1-4 neighbors - 39 = max # of special neighbors - special bonds CPU = 0.000929056 secs - read_data CPU = 0.00930568 secs -Read molecule mol1: - 32 atoms with max type 4 - 32 bonds with max type 6 - 48 angles with max type 8 - 64 dihedrals with max type 9 - 16 impropers with max type 4 -Read molecule mol2: - 32 atoms with max type 6 - 33 bonds with max type 10 - 54 angles with max type 16 - 79 dihedrals with max type 19 - 22 impropers with max type 7 -Read molecule mol3: - 46 atoms with max type 6 - 47 bonds with max type 10 - 75 angles with max type 16 - 105 dihedrals with max type 19 - 29 impropers with max type 7 -Read molecule mol4: - 46 atoms with max type 6 - 48 bonds with max type 13 - 81 angles with max type 22 - 121 dihedrals with max type 36 - 35 impropers with max type 9 -Read molecule mol5: - 50 atoms with max type 6 - 51 bonds with max type 10 - 84 angles with max type 16 - 118 dihedrals with max type 19 - 36 impropers with max type 7 -Read molecule mol6: - 50 atoms with max type 6 - 52 bonds with max type 10 - 90 angles with max type 16 - 135 dihedrals with max type 19 - 42 impropers with max type 5 -dynamic group bond_react_MASTER_group defined -dynamic group statted_grp_REACT defined -PPPM initialization ... -WARNING: System is not charge neutral, net charge = -0.004 (../kspace.cpp:304) - using 12-bit tables for long-range coulomb (../kspace.cpp:323) - G vector (1/distance) = 0.255611 - grid = 6 6 6 - stencil order = 5 - estimated absolute RMS force accuracy = 0.00974692 - estimated relative force accuracy = 2.93525e-05 - using double precision FFTs - 3d grid and FFT values/proc = 1331 216 -Neighbor list info ... - update every 1 steps, delay 10 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 = 4 4 4 - 2 neighbor lists, perpetual/occasional/extra = 1 1 0 - (1) pair lj/class2/coul/long, perpetual - attributes: half, newton on - pair build: half/bin/newton - stencil: half/bin/3d/newton - bin: standard - (2) fix bond/react, occasional, copy from (1) - attributes: half, newton on - pair build: copy - stencil: none - bin: none -Setting up Verlet run ... - Unit style : real - Current step : 0 - Time step : 1 -Per MPI rank memory allocation (min/avg/max) = 31.14 | 31.14 | 31.14 Mbytes -Step Temp Press Density f_rxn1[1] f_rxn1[2] f_rxn1[3] - 0 320.13638 -376.0844 0.76796752 0 0 0 - 100 520.00782 3952.7008 0.76796752 8 0 0 - 200 499.9174 2360.8219 0.76796752 8 3 1 - 300 583.93895 2453.7374 0.76796752 8 3 2 - 400 560.65536 -2243.3464 0.76796752 8 3 3 - 500 556.27995 3598.7044 0.76796752 8 3 3 - 600 570.8397 -3340.1826 0.76796752 8 4 4 - 700 456.89894 -1087.8081 0.76796752 8 4 4 - 800 572.91817 -776.19188 0.76796752 8 4 4 - 900 530.13621 -246734.46 0.76796752 8 4 5 - 1000 542.34698 1044.0793 0.76796752 8 4 5 - 1100 562.86339 1207.1715 0.76796752 8 4 5 - 1200 520.1559 2725.6523 0.76796752 8 4 5 - 1300 534.01667 951.0972 0.76796752 8 4 5 - 1400 478.68681 1184.9224 0.76796752 8 4 5 - 1500 509.05445 2020.5224 0.76796752 8 4 5 - 1600 549.5382 810.17577 0.76796752 8 4 5 - 1700 549.46882 -6349.7751 0.76796752 8 4 5 - 1800 496.77334 3953.1043 0.76796752 8 4 5 - 1900 522.28719 -2271.7599 0.76796752 8 4 6 - 2000 569.95975 5633.4352 0.76796752 8 4 6 - 2100 590.8418 2355.8447 0.76796752 8 4 6 - 2200 537.64787 6459.6743 0.76796752 8 4 6 - 2300 548.38487 -1566.3528 0.76796752 8 4 6 - 2400 533.50353 6755.664 0.76796752 8 4 6 - 2500 512.57053 325.30968 0.76796752 8 4 6 - 2600 498.4597 -2468.1165 0.76796752 8 4 6 - 2700 559.03937 2428.3446 0.76796752 8 4 6 - 2800 585.85721 -2896.3607 0.76796752 8 4 6 - 2900 523.18635 1391.254 0.76796752 8 4 6 - 3000 524.62076 375.02973 0.76796752 8 4 6 - 3100 534.65688 -1522.7879 0.76796752 8 4 6 - 3200 499.42665 3725.5476 0.76796752 8 4 6 - 3300 514.36972 1725.8329 0.76796752 8 4 6 - 3400 482.52662 4648.5013 0.76796752 8 4 6 - 3500 495.36836 967.3482 0.76796752 8 4 6 - 3600 583.28736 745.21794 0.76796752 8 4 6 - 3700 531.99717 -804.39572 0.76796752 8 4 6 - 3800 555.08359 -2381.363 0.76796752 8 4 6 - 3900 520.1818 -547.34169 0.76796752 8 4 6 - 4000 444.38804 -2488.7881 0.76796752 8 4 6 - 4100 518.65622 -3135.9573 0.76796752 8 4 6 - 4200 484.15227 -1040.2447 0.76796752 8 4 6 - 4300 514.58006 550.14626 0.76796752 8 4 6 - 4400 579.81405 -849.81454 0.76796752 8 4 6 - 4500 522.8698 5222.654 0.76796752 8 4 6 - 4600 490.78275 3251.2892 0.76796752 8 4 6 - 4700 492.64299 3785.3482 0.76796752 8 4 6 - 4800 500.11059 4441.8978 0.76796752 8 4 6 - 4900 536.80009 965.33724 0.76796752 8 4 6 - 5000 516.98575 -3794.4213 0.76796752 8 4 6 - 5100 516.76648 -3593.9106 0.76796752 8 4 6 - 5200 521.6379 -6532.7773 0.76796752 8 4 6 - 5300 535.64798 2931.412 0.76796752 8 4 6 - 5400 559.83266 7628.1659 0.76796752 8 4 6 - 5500 538.91756 2841.6746 0.76796752 8 4 6 - 5600 539.13999 10445.173 0.76796752 8 4 6 - 5700 501.56603 -2106.3309 0.76796752 8 4 6 - 5800 496.72952 -4831.0565 0.76796752 8 4 6 - 5900 536.12979 -3916.8197 0.76796752 8 4 6 - 6000 553.10092 3142.6871 0.76796752 8 4 6 - 6100 558.09546 3154.584 0.76796752 8 4 6 - 6200 523.48472 9807.0034 0.76796752 8 4 6 - 6300 551.80343 -3608.2078 0.76796752 8 4 6 - 6400 484.28359 2255.4675 0.76796752 8 4 6 - 6500 560.68443 -4826.4868 0.76796752 8 4 6 - 6600 604.50797 402.32183 0.76796752 8 4 6 - 6700 538.84714 -7670.3312 0.76796752 8 4 6 - 6800 528.82853 -380.32058 0.76796752 8 4 6 - 6900 579.30919 4438.4574 0.76796752 8 4 6 - 7000 540.3406 3738.0524 0.76796752 8 4 6 - 7100 519.53645 -1825.5563 0.76796752 8 4 6 - 7200 474.136 1657.3863 0.76796752 8 4 6 - 7300 485.55159 -221.84939 0.76796752 8 4 6 - 7400 527.38494 1037.1777 0.76796752 8 4 6 - 7500 517.14767 -2313.5823 0.76796752 8 4 6 - 7600 517.95967 -4763.4709 0.76796752 8 4 6 - 7700 513.63507 4819.0253 0.76796752 8 4 6 - 7800 503.56828 1295.1212 0.76796752 8 4 6 - 7900 520.87804 1506.9417 0.76796752 8 4 6 - 8000 509.46453 -5800.0971 0.76796752 8 4 6 - 8100 566.67059 6065.4607 0.76796752 8 4 6 - 8200 592.53068 1097.2277 0.76796752 8 4 6 - 8300 529.55235 -580.81757 0.76796752 8 4 6 - 8400 518.22587 560.45589 0.76796752 8 4 6 - 8500 521.94561 5325.9459 0.76796752 8 4 6 - 8600 510.54416 -1929.1967 0.76796752 8 4 6 - 8700 562.71252 -629.90392 0.76796752 8 4 6 - 8800 540.23123 -3484.3893 0.76796752 8 4 6 - 8900 513.82411 -5227.152 0.76796752 8 4 6 - 9000 534.3307 -3299.088 0.76796752 8 4 6 - 9100 509.24467 -5676.2775 0.76796752 8 4 6 - 9200 506.3216 -7043.8493 0.76796752 8 4 7 - 9300 480.37682 2380.4696 0.76796752 8 4 7 - 9400 546.15532 1831.0103 0.76796752 8 4 7 - 9500 567.18341 3839.9843 0.76796752 8 4 7 - 9600 536.14883 4258.5304 0.76796752 8 4 7 - 9700 496.04153 3321.3561 0.76796752 8 4 7 - 9800 531.78927 3124.9156 0.76796752 8 4 7 - 9900 530.91395 38.987859 0.76796752 8 4 7 - 10000 551.22761 1027.5706 0.76796752 8 4 7 -Loop time of 57.7096 on 1 procs for 10000 steps with 320 atoms - -Performance: 14.972 ns/day, 1.603 hours/ns, 173.281 timesteps/s -99.9% CPU use with 1 MPI tasks x no OpenMP threads - -MPI task timing breakdown: -Section | min time | avg time | max time |%varavg| %total ---------------------------------------------------------------- -Pair | 11.621 | 11.621 | 11.621 | 0.0 | 20.14 -Bond | 11.151 | 11.151 | 11.151 | 0.0 | 19.32 -Kspace | 2.2403 | 2.2403 | 2.2403 | 0.0 | 3.88 -Neigh | 25.467 | 25.467 | 25.467 | 0.0 | 44.13 -Comm | 0.90467 | 0.90467 | 0.90467 | 0.0 | 1.57 -Output | 0.0017984 | 0.0017984 | 0.0017984 | 0.0 | 0.00 -Modify | 6.2622 | 6.2622 | 6.2622 | 0.0 | 10.85 -Other | | 0.06192 | | | 0.11 - -Nlocal: 320 ave 320 max 320 min -Histogram: 1 0 0 0 0 0 0 0 0 0 -Nghost: 3240 ave 3240 max 3240 min -Histogram: 1 0 0 0 0 0 0 0 0 0 -Neighs: 54336 ave 54336 max 54336 min -Histogram: 1 0 0 0 0 0 0 0 0 0 - -Total # of neighbors = 54336 -Ave neighs/atom = 169.8 -Ave special neighs/atom = 11.3063 -Neighbor list builds = 10000 -Dangerous builds = 0 - -Please see the log.cite file for references relevant to this simulation - -Total wall time: 0:00:58 diff --git a/examples/PACKAGES/reaction/tiny_polystyrene/log.20Nov19.tiny_polystyrene.stabilized.g++.4 b/examples/PACKAGES/reaction/tiny_polystyrene/log.20Nov19.tiny_polystyrene.stabilized.g++.4 deleted file mode 100644 index 29aae1cd0b..0000000000 --- a/examples/PACKAGES/reaction/tiny_polystyrene/log.20Nov19.tiny_polystyrene.stabilized.g++.4 +++ /dev/null @@ -1,255 +0,0 @@ -LAMMPS (20 Nov 2019) - -WARNING-WARNING-WARNING-WARNING-WARNING -This LAMMPS executable was compiled using C++98 compatibility. -Please report the compiler info below at https://github.com/lammps/lammps/issues/1659 -GNU C++ 4.8.5 -WARNING-WARNING-WARNING-WARNING-WARNING - -Reading data file ... - orthogonal box = (1.74267 1.74267 1.74267) to (18.2573 18.2573 18.2573) - 1 by 2 by 2 MPI processor grid - reading atoms ... - 320 atoms - reading velocities ... - 320 velocities - scanning bonds ... - 8 = max bonds/atom - scanning angles ... - 18 = max angles/atom - scanning dihedrals ... - 22 = max dihedrals/atom - scanning impropers ... - 26 = max impropers/atom - reading bonds ... - 320 bonds - reading angles ... - 480 angles - reading dihedrals ... - 640 dihedrals - reading impropers ... - 160 impropers -Finding 1-2 1-3 1-4 neighbors ... - special bond factors lj: 0 0 0 - special bond factors coul: 0 0 0 - 3 = max # of 1-2 neighbors - 6 = max # of 1-3 neighbors - 12 = max # of 1-4 neighbors - 39 = max # of special neighbors - special bonds CPU = 0.000751222 secs - read_data CPU = 0.0268223 secs -Read molecule mol1: - 32 atoms with max type 4 - 32 bonds with max type 6 - 48 angles with max type 8 - 64 dihedrals with max type 9 - 16 impropers with max type 4 -Read molecule mol2: - 32 atoms with max type 6 - 33 bonds with max type 10 - 54 angles with max type 16 - 79 dihedrals with max type 19 - 22 impropers with max type 7 -Read molecule mol3: - 46 atoms with max type 6 - 47 bonds with max type 10 - 75 angles with max type 16 - 105 dihedrals with max type 19 - 29 impropers with max type 7 -Read molecule mol4: - 46 atoms with max type 6 - 48 bonds with max type 13 - 81 angles with max type 22 - 121 dihedrals with max type 36 - 35 impropers with max type 9 -Read molecule mol5: - 50 atoms with max type 6 - 51 bonds with max type 10 - 84 angles with max type 16 - 118 dihedrals with max type 19 - 36 impropers with max type 7 -Read molecule mol6: - 50 atoms with max type 6 - 52 bonds with max type 10 - 90 angles with max type 16 - 135 dihedrals with max type 19 - 42 impropers with max type 5 -dynamic group bond_react_MASTER_group defined -dynamic group statted_grp_REACT defined -PPPM initialization ... -WARNING: System is not charge neutral, net charge = -0.004 (../kspace.cpp:304) - using 12-bit tables for long-range coulomb (../kspace.cpp:323) - G vector (1/distance) = 0.255611 - grid = 6 6 6 - stencil order = 5 - estimated absolute RMS force accuracy = 0.00974692 - estimated relative force accuracy = 2.93525e-05 - using double precision FFTs - 3d grid and FFT values/proc = 704 72 -Neighbor list info ... - update every 1 steps, delay 10 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 = 4 4 4 - 2 neighbor lists, perpetual/occasional/extra = 1 1 0 - (1) pair lj/class2/coul/long, perpetual - attributes: half, newton on - pair build: half/bin/newton - stencil: half/bin/3d/newton - bin: standard - (2) fix bond/react, occasional, copy from (1) - attributes: half, newton on - pair build: copy - stencil: none - bin: none -Setting up Verlet run ... - Unit style : real - Current step : 0 - Time step : 1 -Per MPI rank memory allocation (min/avg/max) = 30.66 | 30.68 | 30.69 Mbytes -Step Temp Press Density f_rxn1[1] f_rxn1[2] f_rxn1[3] - 0 320.13638 -376.0844 0.76796752 0 0 0 - 100 522.71544 6623.0579 0.76796752 8 0 0 - 200 500.86716 -9439.5519 0.76796752 8 3 2 - 300 594.60588 6714.1323 0.76796752 8 3 3 - 400 598.68768 683.70457 0.76796752 8 3 3 - 500 563.1011 3576.6857 0.76796752 8 3 4 - 600 510.29713 -196148.37 0.76796752 8 3 5 - 700 494.14346 -118517.45 0.76796752 8 3 6 - 800 565.62849 7678.1235 0.76796752 8 3 6 - 900 515.74468 554.84571 0.76796752 8 3 6 - 1000 500.64636 450.15932 0.76796752 8 3 6 - 1100 463.34973 6023.8346 0.76796752 8 3 6 - 1200 529.88483 2748.185 0.76796752 8 3 6 - 1300 546.84049 1353.4891 0.76796752 8 3 6 - 1400 552.27356 1446.5807 0.76796752 8 3 6 - 1500 557.70874 -2745.1523 0.76796752 8 3 6 - 1600 572.0005 629.36722 0.76796752 8 3 6 - 1700 503.96569 5937.0231 0.76796752 8 3 6 - 1800 491.34262 -1175.8104 0.76796752 8 3 6 - 1900 538.24798 -81.197397 0.76796752 8 3 6 - 2000 523.89324 2857.2466 0.76796752 8 3 6 - 2100 515.1424 2288.2405 0.76796752 8 3 6 - 2200 546.80854 3807.1038 0.76796752 8 3 6 - 2300 500.31231 -135.33933 0.76796752 8 4 6 - 2400 497.16354 5516.857 0.76796752 8 4 6 - 2500 545.34187 3485.5645 0.76796752 8 4 6 - 2600 522.70122 3114.1284 0.76796752 8 4 6 - 2700 531.76604 6633.5518 0.76796752 8 4 6 - 2800 521.97643 -279.83682 0.76796752 8 4 6 - 2900 497.29575 7052.9409 0.76796752 8 4 6 - 3000 524.5942 2284.8918 0.76796752 8 4 6 - 3100 567.61329 -3667.4557 0.76796752 8 4 6 - 3200 506.82452 -2934.4936 0.76796752 8 4 6 - 3300 510.8521 313.36263 0.76796752 8 4 6 - 3400 516.70206 3671.1899 0.76796752 8 4 6 - 3500 535.12788 2645.2564 0.76796752 8 4 6 - 3600 580.14214 2604.3079 0.76796752 8 4 6 - 3700 529.77869 2684.0812 0.76796752 8 4 6 - 3800 502.93191 2838.6698 0.76796752 8 4 6 - 3900 585.91492 5308.0828 0.76796752 8 4 6 - 4000 548.89917 5262.5775 0.76796752 8 4 6 - 4100 550.7662 -1066.6807 0.76796752 8 4 6 - 4200 519.19198 2777.5276 0.76796752 8 4 6 - 4300 521.46332 -3429.7171 0.76796752 8 4 6 - 4400 532.64173 2301.3135 0.76796752 8 4 6 - 4500 528.96107 1369.0991 0.76796752 8 4 6 - 4600 564.66443 9687.2531 0.76796752 8 4 6 - 4700 558.49446 2322.6085 0.76796752 8 4 6 - 4800 497.78614 -442.45053 0.76796752 8 4 6 - 4900 511.09435 -10251.159 0.76796752 8 4 6 - 5000 525.6642 -1202.0584 0.76796752 8 4 6 - 5100 521.76974 1821.7811 0.76796752 8 4 6 - 5200 555.9859 7256.9632 0.76796752 8 4 6 - 5300 551.51971 -122893.16 0.76796752 8 4 7 - 5400 524.34705 2905.1033 0.76796752 8 4 7 - 5500 567.09396 2896.4824 0.76796752 8 4 7 - 5600 487.57746 1417.1715 0.76796752 8 4 7 - 5700 547.37304 3900.8734 0.76796752 8 4 7 - 5800 536.17647 -4048.7522 0.76796752 8 4 7 - 5900 536.85051 4497.9847 0.76796752 8 4 7 - 6000 548.58212 -4880.4979 0.76796752 8 4 7 - 6100 500.94692 6004.2105 0.76796752 8 4 7 - 6200 486.82494 402.5875 0.76796752 8 4 7 - 6300 478.09381 6600.767 0.76796752 8 4 7 - 6400 559.90398 2868.0805 0.76796752 8 4 7 - 6500 526.01866 -3398.4788 0.76796752 8 4 7 - 6600 539.68471 -1202.0012 0.76796752 8 4 7 - 6700 507.51217 -378.71164 0.76796752 8 4 7 - 6800 526.15958 -4536.9888 0.76796752 8 4 7 - 6900 511.37134 -2522.3553 0.76796752 8 4 7 - 7000 538.86918 -2028.0323 0.76796752 8 4 7 - 7100 523.25566 2911.9962 0.76796752 8 4 7 - 7200 513.28464 -1000.4758 0.76796752 8 4 7 - 7300 510.19826 5181.7976 0.76796752 8 4 7 - 7400 493.46528 -1166.3996 0.76796752 8 4 7 - 7500 491.51305 5669.2213 0.76796752 8 4 7 - 7600 506.72032 -2840.301 0.76796752 8 4 7 - 7700 513.4319 2802.1719 0.76796752 8 4 7 - 7800 543.7658 -7477.3623 0.76796752 8 4 7 - 7900 527.35619 -3182.3155 0.76796752 8 4 7 - 8000 533.50993 613.16561 0.76796752 8 4 7 - 8100 512.44958 -5037.3414 0.76796752 8 4 7 - 8200 494.88981 1799.3513 0.76796752 8 4 7 - 8300 554.81474 -2436.0507 0.76796752 8 4 7 - 8400 523.22917 364.30593 0.76796752 8 4 7 - 8500 515.12395 525.24581 0.76796752 8 4 7 - 8600 511.6321 -1679.8669 0.76796752 8 4 7 - 8700 531.6327 -1168.1215 0.76796752 8 4 7 - 8800 548.14438 -5222.7573 0.76796752 8 4 7 - 8900 517.72579 2073.9695 0.76796752 8 4 7 - 9000 543.11894 -5307.0759 0.76796752 8 4 7 - 9100 521.13747 -5546.8552 0.76796752 8 4 7 - 9200 509.66142 -1584.019 0.76796752 8 4 7 - 9300 488.73821 -277.85847 0.76796752 8 4 7 - 9400 513.67282 989.60653 0.76796752 8 4 7 - 9500 509.98833 -1754.8786 0.76796752 8 4 7 - 9600 558.72497 5616.6969 0.76796752 8 4 7 - 9700 533.74988 811.48871 0.76796752 8 4 7 - 9800 510.94641 -3136.5876 0.76796752 8 4 7 - 9900 517.80127 -1962.0837 0.76796752 8 4 7 - 10000 477.50428 -3768.1653 0.76796752 8 4 7 -Loop time of 20.9963 on 4 procs for 10000 steps with 320 atoms - -Performance: 41.150 ns/day, 0.583 hours/ns, 476.276 timesteps/s -100.0% CPU use with 4 MPI tasks x no OpenMP threads - -MPI task timing breakdown: -Section | min time | avg time | max time |%varavg| %total ---------------------------------------------------------------- -Pair | 2.4968 | 3.0329 | 3.3607 | 18.6 | 14.45 -Bond | 2.3164 | 2.8835 | 3.456 | 26.0 | 13.73 -Kspace | 1.3332 | 2.2082 | 3.285 | 48.0 | 10.52 -Neigh | 7.4831 | 7.4922 | 7.5012 | 0.3 | 35.68 -Comm | 1.2809 | 1.3121 | 1.3297 | 1.6 | 6.25 -Output | 0.0012138 | 0.0013506 | 0.0017552 | 0.6 | 0.01 -Modify | 4.0269 | 4.0301 | 4.0335 | 0.1 | 19.19 -Other | | 0.03583 | | | 0.17 - -Nlocal: 80 ave 94 max 66 min -Histogram: 2 0 0 0 0 0 0 0 0 2 -Nghost: 2243.75 ave 2260 max 2221 min -Histogram: 1 0 0 1 0 0 0 0 0 2 -Neighs: 13658.5 ave 17096 max 9421 min -Histogram: 1 0 0 0 0 1 1 0 0 1 - -Total # of neighbors = 54634 -Ave neighs/atom = 170.731 -Ave special neighs/atom = 11.3063 -Neighbor list builds = 10000 -Dangerous builds = 0 -System init for write_data ... -PPPM initialization ... - using 12-bit tables for long-range coulomb (../kspace.cpp:323) - G vector (1/distance) = 0.255611 - grid = 6 6 6 - stencil order = 5 - estimated absolute RMS force accuracy = 0.00974692 - estimated relative force accuracy = 2.93525e-05 - using double precision FFTs - 3d grid and FFT values/proc = 704 72 - -Please see the log.cite file for references relevant to this simulation - -Total wall time: 0:00:21 diff --git a/examples/PACKAGES/reaction/tiny_polystyrene/log.4Nov19.tiny_polystyrene.stabilized.g++.4 b/examples/PACKAGES/reaction/tiny_polystyrene/log.4Nov19.tiny_polystyrene.stabilized.g++.4 new file mode 100644 index 0000000000..aaa8b2f190 --- /dev/null +++ b/examples/PACKAGES/reaction/tiny_polystyrene/log.4Nov19.tiny_polystyrene.stabilized.g++.4 @@ -0,0 +1,329 @@ +LAMMPS (4 Nov 2022) +# 20 styrene molecules +# three reactions defined + +units real + +boundary p p p + +atom_style full + +kspace_style pppm 1.0e-4 + +pair_style lj/class2/coul/long 8.5 + +angle_style class2 + +bond_style class2 + +dihedral_style class2 + +improper_style class2 + +variable T equal 530 + +read_data tiny_polystyrene.data extra/bond/per/atom 5 extra/angle/per/atom 15 extra/dihedral/per/atom 15 extra/improper/per/atom 25 extra/special/per/atom 25 +Reading data file ... + orthogonal box = (1.7426663 1.7426663 1.7426663) to (18.257334 18.257334 18.257334) + 1 by 2 by 2 MPI processor grid + reading atom labelmap ... + reading bond labelmap ... + reading angle labelmap ... + reading dihedral labelmap ... + reading improper labelmap ... + reading atoms ... + 320 atoms + reading velocities ... + 320 velocities + scanning bonds ... + 8 = max bonds/atom + scanning angles ... + 18 = max angles/atom + scanning dihedrals ... + 22 = max dihedrals/atom + scanning impropers ... + 26 = max impropers/atom + reading bonds ... + 320 bonds + reading angles ... + 480 angles + reading dihedrals ... + 640 dihedrals + reading impropers ... + 160 impropers +Finding 1-2 1-3 1-4 neighbors ... + special bond factors lj: 0 0 0 + special bond factors coul: 0 0 0 + 3 = max # of 1-2 neighbors + 6 = max # of 1-3 neighbors + 12 = max # of 1-4 neighbors + 39 = max # of special neighbors + special bonds CPU = 0.001 seconds + read_data CPU = 0.018 seconds + +molecule mol1 2styrene_unreacted.molecule_template +Read molecule template mol1: + 1 molecules + 0 fragments + 32 atoms with max type 4 + 32 bonds with max type 11 + 48 angles with max type 19 + 64 dihedrals with max type 21 + 16 impropers with max type 8 +molecule mol2 2styrene_reacted.molecule_template +Read molecule template mol2: + 1 molecules + 0 fragments + 32 atoms with max type 6 + 33 bonds with max type 13 + 54 angles with max type 22 + 79 dihedrals with max type 19 + 14 impropers with max type 7 +molecule mol3 chain_plus_styrene_unreacted.molecule_template +Read molecule template mol3: + 1 molecules + 0 fragments + 46 atoms with max type 6 + 47 bonds with max type 13 + 75 angles with max type 22 + 105 dihedrals with max type 21 + 21 impropers with max type 8 +molecule mol4 chain_plus_styrene_reacted.molecule_template +Read molecule template mol4: + 1 molecules + 0 fragments + 46 atoms with max type 6 + 48 bonds with max type 13 + 81 angles with max type 22 + 121 dihedrals with max type 19 + 19 impropers with max type 7 +molecule mol5 chain_chain_unreacted.molecule_template +Read molecule template mol5: + 1 molecules + 0 fragments + 50 atoms with max type 6 + 51 bonds with max type 13 + 84 angles with max type 22 + 118 dihedrals with max type 19 + 20 impropers with max type 7 +molecule mol6 chain_chain_reacted.molecule_template +Read molecule template mol6: + 1 molecules + 0 fragments + 50 atoms with max type 6 + 52 bonds with max type 13 + 90 angles with max type 22 + 135 dihedrals with max type 19 + 18 impropers with max type 2 + +thermo 100 + +# dump 1 all xyz 5 test_vis.xyz + +fix rxn1 all bond/react stabilization yes statted_grp .03 react rxn1 all 1 0 3.0 mol1 mol2 2styrene_map stabilize_steps 100 react rxn2 all 1 0 3.0 mol3 mol4 chain_plus_styrene_map stabilize_steps 100 react rxn3 all 1 0 5.0 mol5 mol6 chain_chain_map stabilize_steps 100 +dynamic group bond_react_MASTER_group defined +dynamic group statted_grp_REACT defined + +fix 1 statted_grp_REACT nvt temp $T $T 100 +fix 1 statted_grp_REACT nvt temp 530 $T 100 +fix 1 statted_grp_REACT nvt temp 530 530 100 + +fix 4 bond_react_MASTER_group temp/rescale 1 $T $T 1 1 +fix 4 bond_react_MASTER_group temp/rescale 1 530 $T 1 1 +fix 4 bond_react_MASTER_group temp/rescale 1 530 530 1 1 + +thermo_style custom step temp press density f_rxn1[1] f_rxn1[2] f_rxn1[3] + +run 10000 + +CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE + +Your simulation uses code contributions which should be cited: + +- fix bond/react: reacter.org doi:10.1016/j.polymer.2017.09.038, doi:10.1021/acs.macromol.0c02012 + +@Article{Gissinger17, + author = {J. R. Gissinger and B. D. Jensen and K. E. Wise}, + title = {Modeling Chemical Reactions in Classical Molecular Dynamics Simulations}, + journal = {Polymer}, + year = 2017, + volume = 128, + pages = {211--217} +} + +@Article{Gissinger20, + author = {J. R. Gissinger, B. D. Jensen, K. E. Wise}, + title = {{REACTER}: A Heuristic Method for Reactive Molecular Dynamics}, + journal = {Macromolecules}, + year = 2020, + volume = 53, + number = 22, + pages = {9953--9961} +} + +CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE + +PPPM initialization ... +WARNING: System is not charge neutral, net charge = -0.004 (../kspace.cpp:327) + using 12-bit tables for long-range coulomb (../kspace.cpp:342) + G vector (1/distance) = 0.25561147 + grid = 6 6 6 + stencil order = 5 + estimated absolute RMS force accuracy = 0.0097469157 + estimated relative force accuracy = 2.9352547e-05 + using double precision KISS FFT + 3d grid and FFT values/proc = 704 72 +Generated 21 of 21 mixed pair_coeff terms from sixthpower/geometric mixing rule +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 = 4 4 4 + 2 neighbor lists, perpetual/occasional/extra = 1 1 0 + (1) pair lj/class2/coul/long, perpetual + attributes: half, newton on + pair build: half/bin/newton + stencil: half/bin/3d + bin: standard + (2) fix bond/react, occasional, copy from (1) + attributes: half, newton on + pair build: copy + stencil: none + bin: none +Per MPI rank memory allocation (min/avg/max) = 31.03 | 31.05 | 31.06 Mbytes + Step Temp Press Density f_rxn1[1] f_rxn1[2] f_rxn1[3] + 0 320.13638 -376.0844 0.76796752 0 0 0 + 100 342.22237 -3489.4495 0.76796752 0 0 0 + 200 412.23828 -1367.104 0.76796752 0 0 0 + 300 467.98145 4841.002 0.76796752 0 0 0 + 400 505.39864 2213.0509 0.76796752 1 0 0 + 500 519.63371 -28223.513 0.76796752 2 0 0 + 600 526.40655 8701.2728 0.76796752 2 0 0 + 700 579.91953 2507.5868 0.76796752 2 0 0 + 800 517.29593 5558.2895 0.76796752 2 0 0 + 900 503.38392 -5027.1154 0.76796752 2 0 0 + 1000 509.30767 3979.0529 0.76796752 2 0 0 + 1100 551.34763 5119.0848 0.76796752 2 0 0 + 1200 562.5176 -2867.8688 0.76796752 2 0 0 + 1300 552.90918 2090.7508 0.76796752 2 0 0 + 1400 516.10716 3374.2169 0.76796752 2 0 0 + 1500 518.70418 471.99711 0.76796752 2 0 0 + 1600 559.49915 5450.8774 0.76796752 2 0 0 + 1700 531.50638 4525.5892 0.76796752 2 0 0 + 1800 529.18331 -3566.9245 0.76796752 2 0 0 + 1900 517.79846 -2364.8287 0.76796752 2 0 0 + 2000 495.0983 -488.99696 0.76796752 2 0 0 + 2100 567.80521 2050.9596 0.76796752 3 0 0 + 2200 553.24434 5665.0753 0.76796752 3 0 0 + 2300 561.08278 2879.1572 0.76796752 3 0 0 + 2400 461.3712 3185.6091 0.76796752 3 0 0 + 2500 500.95595 565.81792 0.76796752 4 0 0 + 2600 538.3865 463.58228 0.76796752 4 0 0 + 2700 525.95739 2011.1914 0.76796752 4 0 0 + 2800 533.4197 157.38106 0.76796752 4 0 0 + 2900 526.27036 1331.5115 0.76796752 5 1 0 + 3000 502.65015 -93.915921 0.76796752 5 1 0 + 3100 505.4224 -1314.224 0.76796752 5 1 0 + 3200 538.52692 10420.644 0.76796752 5 1 0 + 3300 518.32801 5933.553 0.76796752 5 2 0 + 3400 540.04815 741.54438 0.76796752 6 2 1 + 3500 554.07567 5778.8913 0.76796752 6 2 1 + 3600 546.90828 4751.5437 0.76796752 6 2 1 + 3700 529.75739 432.20829 0.76796752 6 2 1 + 3800 542.806 -380.00399 0.76796752 6 2 1 + 3900 521.55789 -1224.1912 0.76796752 6 2 2 + 4000 519.73935 2792.996 0.76796752 6 2 2 + 4100 535.06314 -1926.8692 0.76796752 6 2 2 + 4200 549.75482 2852.5521 0.76796752 6 2 2 + 4300 510.71949 6581.1729 0.76796752 7 2 2 + 4400 485.93403 -695.24007 0.76796752 7 2 2 + 4500 535.3677 2519.2711 0.76796752 7 2 2 + 4600 504.87216 533.16619 0.76796752 7 2 2 + 4700 495.68939 5502.1672 0.76796752 7 2 2 + 4800 534.13893 -1187.1228 0.76796752 7 2 2 + 4900 512.56394 1731.3856 0.76796752 7 2 2 + 5000 508.63054 2467.0387 0.76796752 7 2 2 + 5100 501.65027 3403.8111 0.76796752 7 2 2 + 5200 556.68281 4310.0492 0.76796752 7 2 2 + 5300 506.86652 -773630.77 0.76796752 7 2 3 + 5400 570.01783 11663.867 0.76796752 7 2 3 + 5500 538.08785 6391.6546 0.76796752 7 2 3 + 5600 502.48456 44.409604 0.76796752 7 2 3 + 5700 545.75445 1558.6373 0.76796752 7 2 3 + 5800 517.5076 -166.52488 0.76796752 7 2 3 + 5900 558.64383 1528.1198 0.76796752 7 2 3 + 6000 557.8358 442.21273 0.76796752 7 2 3 + 6100 483.13771 5201.4489 0.76796752 8 2 3 + 6200 533.42675 5112.0828 0.76796752 8 2 3 + 6300 576.32772 269.77058 0.76796752 8 2 3 + 6400 492.79331 565.35222 0.76796752 8 2 4 + 6500 514.5727 6233.7568 0.76796752 8 2 4 + 6600 509.86906 -943.58621 0.76796752 8 2 4 + 6700 546.62752 -323284.04 0.76796752 8 2 5 + 6800 541.19749 1306.3182 0.76796752 8 2 5 + 6900 497.72333 -1792.483 0.76796752 8 2 5 + 7000 516.02636 2028.3813 0.76796752 8 2 5 + 7100 486.54013 6153.9142 0.76796752 8 2 5 + 7200 553.33698 4352.3987 0.76796752 8 2 5 + 7300 519.23896 6536.766 0.76796752 8 2 5 + 7400 486.74787 -1744.8351 0.76796752 8 2 5 + 7500 516.71935 -315.43649 0.76796752 8 2 5 + 7600 513.62572 -1100.1363 0.76796752 8 2 5 + 7700 531.11296 1727.7113 0.76796752 8 2 5 + 7800 530.82809 9566.2386 0.76796752 8 2 5 + 7900 513.09884 8545.6728 0.76796752 8 2 5 + 8000 511.38714 2995.8438 0.76796752 8 2 5 + 8100 527.76731 709.63649 0.76796752 8 2 5 + 8200 514.09092 2103.8591 0.76796752 8 2 5 + 8300 534.90612 7707.3378 0.76796752 8 2 5 + 8400 547.40716 660.54641 0.76796752 8 2 5 + 8500 518.75522 -872.69754 0.76796752 8 2 5 + 8600 511.70922 6645.6264 0.76796752 8 2 5 + 8700 480.70739 -640.57939 0.76796752 8 2 5 + 8800 527.35475 6944.8472 0.76796752 8 2 5 + 8900 554.26477 -2311.6153 0.76796752 8 2 5 + 9000 520.48502 1469.4805 0.76796752 8 2 5 + 9100 522.0619 -4159.697 0.76796752 8 2 5 + 9200 501.34664 7486.8266 0.76796752 8 2 5 + 9300 524.96422 6158.2524 0.76796752 8 2 5 + 9400 564.30456 -2964.7187 0.76796752 8 2 6 + 9500 569.02736 5765.8856 0.76796752 8 2 6 + 9600 554.31532 2805.5671 0.76796752 8 2 6 + 9700 521.3957 -924.74562 0.76796752 8 2 6 + 9800 518.45356 -2440.5266 0.76796752 8 2 6 + 9900 512.03787 -834.07647 0.76796752 8 2 6 + 10000 573.10576 4372.5769 0.76796752 8 2 6 +Loop time of 11.2088 on 4 procs for 10000 steps with 320 atoms + +Performance: 77.082 ns/day, 0.311 hours/ns, 892.155 timesteps/s, 285.490 katom-step/s +100.0% CPU use with 4 MPI tasks x no OpenMP threads + +MPI task timing breakdown: +Section | min time | avg time | max time |%varavg| %total +--------------------------------------------------------------- +Pair | 2.6217 | 2.8126 | 3.0128 | 9.5 | 25.09 +Bond | 2.0439 | 2.1734 | 2.3326 | 7.0 | 19.39 +Kspace | 1.4277 | 1.7772 | 2.0148 | 17.9 | 15.86 +Neigh | 0.32002 | 0.3201 | 0.3202 | 0.0 | 2.86 +Comm | 0.42382 | 0.43347 | 0.4412 | 1.1 | 3.87 +Output | 0.0013461 | 0.0015202 | 0.0020328 | 0.8 | 0.01 +Modify | 3.6386 | 3.6396 | 3.6408 | 0.0 | 32.47 +Other | | 0.05092 | | | 0.45 + +Nlocal: 80 ave 93 max 71 min +Histogram: 1 1 0 0 1 0 0 0 0 1 +Nghost: 2184.75 ave 2276 max 2092 min +Histogram: 1 0 1 0 0 0 0 1 0 1 +Neighs: 13678.5 ave 15576 max 11682 min +Histogram: 1 0 0 1 0 0 0 1 0 1 + +Total # of neighbors = 54714 +Ave neighs/atom = 170.98125 +Ave special neighs/atom = 10.9125 +Neighbor list builds = 471 +Dangerous builds = 0 + +# write_restart restart_longrun nofix +# write_data restart_longrun.data +Total wall time: 0:00:11 diff --git a/examples/PACKAGES/reaction/tiny_polystyrene/log.4Nov2020.tiny_polystyrene.stabilized.g++.1 b/examples/PACKAGES/reaction/tiny_polystyrene/log.4Nov2020.tiny_polystyrene.stabilized.g++.1 new file mode 100644 index 0000000000..be40e6b0de --- /dev/null +++ b/examples/PACKAGES/reaction/tiny_polystyrene/log.4Nov2020.tiny_polystyrene.stabilized.g++.1 @@ -0,0 +1,329 @@ +LAMMPS (4 Nov 2022) +# 20 styrene molecules +# three reactions defined + +units real + +boundary p p p + +atom_style full + +kspace_style pppm 1.0e-4 + +pair_style lj/class2/coul/long 8.5 + +angle_style class2 + +bond_style class2 + +dihedral_style class2 + +improper_style class2 + +variable T equal 530 + +read_data tiny_polystyrene.data extra/bond/per/atom 5 extra/angle/per/atom 15 extra/dihedral/per/atom 15 extra/improper/per/atom 25 extra/special/per/atom 25 +Reading data file ... + orthogonal box = (1.7426663 1.7426663 1.7426663) to (18.257334 18.257334 18.257334) + 1 by 1 by 1 MPI processor grid + reading atom labelmap ... + reading bond labelmap ... + reading angle labelmap ... + reading dihedral labelmap ... + reading improper labelmap ... + reading atoms ... + 320 atoms + reading velocities ... + 320 velocities + scanning bonds ... + 8 = max bonds/atom + scanning angles ... + 18 = max angles/atom + scanning dihedrals ... + 22 = max dihedrals/atom + scanning impropers ... + 26 = max impropers/atom + reading bonds ... + 320 bonds + reading angles ... + 480 angles + reading dihedrals ... + 640 dihedrals + reading impropers ... + 160 impropers +Finding 1-2 1-3 1-4 neighbors ... + special bond factors lj: 0 0 0 + special bond factors coul: 0 0 0 + 3 = max # of 1-2 neighbors + 6 = max # of 1-3 neighbors + 12 = max # of 1-4 neighbors + 39 = max # of special neighbors + special bonds CPU = 0.001 seconds + read_data CPU = 0.015 seconds + +molecule mol1 2styrene_unreacted.molecule_template +Read molecule template mol1: + 1 molecules + 0 fragments + 32 atoms with max type 4 + 32 bonds with max type 11 + 48 angles with max type 19 + 64 dihedrals with max type 21 + 16 impropers with max type 8 +molecule mol2 2styrene_reacted.molecule_template +Read molecule template mol2: + 1 molecules + 0 fragments + 32 atoms with max type 6 + 33 bonds with max type 13 + 54 angles with max type 22 + 79 dihedrals with max type 19 + 14 impropers with max type 7 +molecule mol3 chain_plus_styrene_unreacted.molecule_template +Read molecule template mol3: + 1 molecules + 0 fragments + 46 atoms with max type 6 + 47 bonds with max type 13 + 75 angles with max type 22 + 105 dihedrals with max type 21 + 21 impropers with max type 8 +molecule mol4 chain_plus_styrene_reacted.molecule_template +Read molecule template mol4: + 1 molecules + 0 fragments + 46 atoms with max type 6 + 48 bonds with max type 13 + 81 angles with max type 22 + 121 dihedrals with max type 19 + 19 impropers with max type 7 +molecule mol5 chain_chain_unreacted.molecule_template +Read molecule template mol5: + 1 molecules + 0 fragments + 50 atoms with max type 6 + 51 bonds with max type 13 + 84 angles with max type 22 + 118 dihedrals with max type 19 + 20 impropers with max type 7 +molecule mol6 chain_chain_reacted.molecule_template +Read molecule template mol6: + 1 molecules + 0 fragments + 50 atoms with max type 6 + 52 bonds with max type 13 + 90 angles with max type 22 + 135 dihedrals with max type 19 + 18 impropers with max type 2 + +thermo 100 + +# dump 1 all xyz 5 test_vis.xyz + +fix rxn1 all bond/react stabilization yes statted_grp .03 react rxn1 all 1 0 3.0 mol1 mol2 2styrene_map stabilize_steps 100 react rxn2 all 1 0 3.0 mol3 mol4 chain_plus_styrene_map stabilize_steps 100 react rxn3 all 1 0 5.0 mol5 mol6 chain_chain_map stabilize_steps 100 +dynamic group bond_react_MASTER_group defined +dynamic group statted_grp_REACT defined + +fix 1 statted_grp_REACT nvt temp $T $T 100 +fix 1 statted_grp_REACT nvt temp 530 $T 100 +fix 1 statted_grp_REACT nvt temp 530 530 100 + +fix 4 bond_react_MASTER_group temp/rescale 1 $T $T 1 1 +fix 4 bond_react_MASTER_group temp/rescale 1 530 $T 1 1 +fix 4 bond_react_MASTER_group temp/rescale 1 530 530 1 1 + +thermo_style custom step temp press density f_rxn1[1] f_rxn1[2] f_rxn1[3] + +run 10000 + +CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE + +Your simulation uses code contributions which should be cited: + +- fix bond/react: reacter.org doi:10.1016/j.polymer.2017.09.038, doi:10.1021/acs.macromol.0c02012 + +@Article{Gissinger17, + author = {J. R. Gissinger and B. D. Jensen and K. E. Wise}, + title = {Modeling Chemical Reactions in Classical Molecular Dynamics Simulations}, + journal = {Polymer}, + year = 2017, + volume = 128, + pages = {211--217} +} + +@Article{Gissinger20, + author = {J. R. Gissinger, B. D. Jensen, K. E. Wise}, + title = {{REACTER}: A Heuristic Method for Reactive Molecular Dynamics}, + journal = {Macromolecules}, + year = 2020, + volume = 53, + number = 22, + pages = {9953--9961} +} + +CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE-CITE + +PPPM initialization ... +WARNING: System is not charge neutral, net charge = -0.004 (../kspace.cpp:327) + using 12-bit tables for long-range coulomb (../kspace.cpp:342) + G vector (1/distance) = 0.25561147 + grid = 6 6 6 + stencil order = 5 + estimated absolute RMS force accuracy = 0.0097469157 + estimated relative force accuracy = 2.9352547e-05 + using double precision KISS FFT + 3d grid and FFT values/proc = 1331 216 +Generated 21 of 21 mixed pair_coeff terms from sixthpower/geometric mixing rule +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 = 4 4 4 + 2 neighbor lists, perpetual/occasional/extra = 1 1 0 + (1) pair lj/class2/coul/long, perpetual + attributes: half, newton on + pair build: half/bin/newton + stencil: half/bin/3d + bin: standard + (2) fix bond/react, occasional, copy from (1) + attributes: half, newton on + pair build: copy + stencil: none + bin: none +Per MPI rank memory allocation (min/avg/max) = 31.51 | 31.51 | 31.51 Mbytes + Step Temp Press Density f_rxn1[1] f_rxn1[2] f_rxn1[3] + 0 320.13638 -376.0844 0.76796752 0 0 0 + 100 342.22237 -3489.4495 0.76796752 0 0 0 + 200 412.23828 -1367.104 0.76796752 0 0 0 + 300 467.98145 4841.002 0.76796752 0 0 0 + 400 505.39864 2213.0509 0.76796752 1 0 0 + 500 519.63371 -28223.513 0.76796752 2 0 0 + 600 526.40655 8701.2728 0.76796752 2 0 0 + 700 579.91953 2507.5868 0.76796752 2 0 0 + 800 517.29593 5558.2894 0.76796752 2 0 0 + 900 503.38392 -5027.1155 0.76796752 2 0 0 + 1000 509.30766 3979.0526 0.76796752 2 0 0 + 1100 551.34763 5119.0854 0.76796752 2 0 0 + 1200 562.51766 -2867.8721 0.76796752 2 0 0 + 1300 552.90947 2090.7196 0.76796752 2 0 0 + 1400 516.10667 3374.3471 0.76796752 2 0 0 + 1500 518.70363 472.0237 0.76796752 2 0 0 + 1600 559.50145 5451.1908 0.76796752 2 0 0 + 1700 531.49515 4526.9547 0.76796752 2 0 0 + 1800 529.18545 -3566.8838 0.76796752 2 0 0 + 1900 517.52577 -2390.6662 0.76796752 2 0 0 + 2000 495.24246 -485.62368 0.76796752 2 0 0 + 2100 567.90338 2009.3507 0.76796752 3 0 0 + 2200 553.05006 5694.0307 0.76796752 3 0 0 + 2300 561.22521 2944.2766 0.76796752 3 0 0 + 2400 460.05535 3058.3944 0.76796752 3 0 0 + 2500 501.01426 365.04418 0.76796752 4 0 0 + 2600 543.94728 267.33298 0.76796752 4 0 0 + 2700 539.40536 4258.9345 0.76796752 4 0 0 + 2800 557.67853 -2732.3135 0.76796752 4 0 0 + 2900 539.85456 3987.7331 0.76796752 4 1 0 + 3000 501.3125 3280.3821 0.76796752 4 1 0 + 3100 537.77092 -5290.371 0.76796752 4 1 0 + 3200 528.20744 11690.902 0.76796752 4 1 0 + 3300 548.56721 2464.6039 0.76796752 4 1 0 + 3400 542.73725 -27951.173 0.76796752 4 1 1 + 3500 547.63988 7925.1202 0.76796752 4 1 1 + 3600 502.69726 7875.8308 0.76796752 4 1 1 + 3700 495.26614 -1907.7215 0.76796752 4 1 1 + 3800 526.91826 -4267.1784 0.76796752 4 1 1 + 3900 538.8248 6811.7446 0.76796752 4 1 1 + 4000 531.42158 5031.2992 0.76796752 4 1 1 + 4100 539.69772 6278.9861 0.76796752 4 1 1 + 4200 519.11497 9206.6513 0.76796752 4 1 1 + 4300 518.08237 -63.769046 0.76796752 4 1 1 + 4400 582.43352 4189.0234 0.76796752 4 1 1 + 4500 541.87979 -2072.4133 0.76796752 4 1 1 + 4600 514.7508 7502.1057 0.76796752 4 1 1 + 4700 530.22173 51.50674 0.76796752 4 1 1 + 4800 507.14885 5148.7797 0.76796752 4 1 1 + 4900 516.05055 9110.3072 0.76796752 4 1 1 + 5000 552.55865 7310.0399 0.76796752 4 1 1 + 5100 581.79588 3282.8939 0.76796752 4 1 1 + 5200 523.07607 -1312.6111 0.76796752 4 1 1 + 5300 528.44235 -2242.0268 0.76796752 4 1 1 + 5400 537.63408 4599.5474 0.76796752 4 1 1 + 5500 526.75093 5551.7841 0.76796752 4 1 1 + 5600 562.74766 2764.4556 0.76796752 4 1 1 + 5700 545.12259 -3139.3468 0.76796752 4 1 1 + 5800 563.77404 4261.7786 0.76796752 4 1 1 + 5900 514.07804 4057.43 0.76796752 4 1 1 + 6000 548.42605 -2814.3308 0.76796752 4 1 1 + 6100 525.16391 -2902.5409 0.76796752 4 1 1 + 6200 504.92542 -706.19923 0.76796752 4 1 2 + 6300 531.55271 1217.7795 0.76796752 4 1 2 + 6400 537.29797 264.24006 0.76796752 4 1 2 + 6500 581.8752 2228.1037 0.76796752 4 1 2 + 6600 536.95487 -10318.365 0.76796752 4 2 2 + 6700 498.26961 5005.4587 0.76796752 5 2 2 + 6800 526.00873 -2678.0327 0.76796752 5 2 2 + 6900 542.74619 -1567.8558 0.76796752 5 2 2 + 7000 549.02037 8321.4935 0.76796752 5 2 2 + 7100 542.28295 -1513.6114 0.76796752 5 2 2 + 7200 474.70347 2120.9699 0.76796752 5 2 2 + 7300 506.58637 2588.8837 0.76796752 5 2 2 + 7400 512.45393 -2101371.7 0.76796752 5 2 3 + 7500 546.20285 -2458.3002 0.76796752 5 2 3 + 7600 551.57132 3148.9131 0.76796752 5 2 3 + 7700 544.3684 -775.59686 0.76796752 5 2 3 + 7800 511.32529 2353.0343 0.76796752 5 2 3 + 7900 520.30502 10726.007 0.76796752 5 2 3 + 8000 561.81009 12476.296 0.76796752 5 2 3 + 8100 588.85859 5905.4979 0.76796752 5 2 3 + 8200 490.1071 1132.5027 0.76796752 5 2 3 + 8300 537.65085 -1445.0979 0.76796752 5 2 3 + 8400 523.60343 -589.18012 0.76796752 5 2 3 + 8500 538.90848 -300.32152 0.76796752 5 2 3 + 8600 573.63835 5912.9027 0.76796752 5 2 3 + 8700 557.82593 2585.6634 0.76796752 5 2 3 + 8800 562.5277 -1843272.8 0.76796752 5 2 4 + 8900 564.26894 -1396.8521 0.76796752 5 2 4 + 9000 576.4382 5029.6995 0.76796752 5 2 4 + 9100 514.83258 -935.9015 0.76796752 5 2 4 + 9200 536.33755 -1671.9254 0.76796752 5 2 4 + 9300 494.49553 582.08687 0.76796752 5 2 4 + 9400 532.12156 -6991.3223 0.76796752 6 2 4 + 9500 528.87489 4587.7048 0.76796752 6 2 4 + 9600 555.92299 -3688.5966 0.76796752 6 2 4 + 9700 510.09341 1545.1276 0.76796752 6 2 4 + 9800 505.94984 -4677.2879 0.76796752 6 2 4 + 9900 531.38104 4891.0352 0.76796752 6 2 4 + 10000 517.59995 4299.0553 0.76796752 6 2 4 +Loop time of 29.4182 on 1 procs for 10000 steps with 320 atoms + +Performance: 29.370 ns/day, 0.817 hours/ns, 339.926 timesteps/s, 108.776 katom-step/s +100.0% CPU use with 1 MPI tasks x no OpenMP threads + +MPI task timing breakdown: +Section | min time | avg time | max time |%varavg| %total +--------------------------------------------------------------- +Pair | 10.883 | 10.883 | 10.883 | 0.0 | 36.99 +Bond | 8.0953 | 8.0953 | 8.0953 | 0.0 | 27.52 +Kspace | 2.6136 | 2.6136 | 2.6136 | 0.0 | 8.88 +Neigh | 1.0863 | 1.0863 | 1.0863 | 0.0 | 3.69 +Comm | 0.2095 | 0.2095 | 0.2095 | 0.0 | 0.71 +Output | 0.0019263 | 0.0019263 | 0.0019263 | 0.0 | 0.01 +Modify | 6.4695 | 6.4695 | 6.4695 | 0.0 | 21.99 +Other | | 0.05924 | | | 0.20 + +Nlocal: 320 ave 320 max 320 min +Histogram: 1 0 0 0 0 0 0 0 0 0 +Nghost: 3425 ave 3425 max 3425 min +Histogram: 1 0 0 0 0 0 0 0 0 0 +Neighs: 54783 ave 54783 max 54783 min +Histogram: 1 0 0 0 0 0 0 0 0 0 + +Total # of neighbors = 54783 +Ave neighs/atom = 171.19688 +Ave special neighs/atom = 10.3375 +Neighbor list builds = 460 +Dangerous builds = 0 + +# write_restart restart_longrun nofix +# write_data restart_longrun.data +Total wall time: 0:00:29 diff --git a/examples/PACKAGES/reaction/tiny_polystyrene/tiny_polystyrene.data b/examples/PACKAGES/reaction/tiny_polystyrene/tiny_polystyrene.data index 5f0ed4cfa6..ab12e8d4b1 100644 --- a/examples/PACKAGES/reaction/tiny_polystyrene/tiny_polystyrene.data +++ b/examples/PACKAGES/reaction/tiny_polystyrene/tiny_polystyrene.data @@ -15,6 +15,108 @@ LAMMPS data file via write_data, version 20 Nov 2019, timestep = 25000 1.7426663385337786e+00 1.8257333661465619e+01 ylo yhi 1.7426663385337786e+00 1.8257333661465619e+01 zlo zhi +Atom Type Labels + +1 cp +2 hc +3 c=1 +4 c= +5 c1 +6 c2 +7 c3 + +Bond Type Labels + +1 cp-hc +2 cp-cp +3 cp-c1 +4 hc-c=1 +5 c=1-c= +6 hc-c= +7 cp-c3 +8 hc-c3 +9 c3-c2 +10 hc-c2 +11 cp-c=1 +12 hc-c1 +13 c1-c2 + +Angle Type Labels + +1 cp-cp-hc +2 cp-cp-cp +3 cp-cp-c1 +4 cp-c1-hc +5 cp-c1-c2 +6 hc-c=1-c= +7 hc-c=-c=1 +8 hc-c=-hc +9 cp-cp-c3 +10 cp-c3-hc +11 cp-c3-c2 +12 hc-c3-c2 +13 c3-c2-c1 +14 hc-c2-c3 +15 hc-c2-hc +16 c1-c2-c1 +17 cp-cp-c=1 +18 cp-c=1-hc +19 cp-c=1-c= +20 hc-c2-c1 +21 hc-c1-c2 +22 c2-c1-c2 + +Dihedral Type Labels + +1 hc-cp-cp-c1 +2 cp-cp-cp-hc +3 cp-cp-cp-c1 +4 cp-cp-cp-cp +5 hc-cp-cp-hc +6 cp-cp-c=1-hc +7 cp-cp-c=1-c= +8 cp-c=1-c=-hc +9 hc-c=1-c=-hc +10 hc-cp-cp-c3 +11 cp-cp-cp-c3 +12 cp-cp-c1-hc +13 cp-cp-c1-c2 +14 cp-c1-c2-hc +15 hc-c1-c2-hc +16 c2-c1-c2-hc +17 cp-c1-c2-c1 +18 hc-c1-c2-c1 +19 c2-c1-c2-c1 +20 hc-cp-cp-c=1 +21 cp-cp-cp-c=1 +22 cp-cp-c3-hc +23 cp-cp-c3-c2 +24 cp-c3-c2-hc +25 cp-c3-c2-c1 +26 hc-c3-c2-hc +27 hc-c3-c2-c1 +28 c3-c2-c1-cp +29 c3-c2-c1-hc +30 c3-c2-c1-c2 +31 hc-c2-c1-cp +32 hc-c2-c1-hc +33 hc-c2-c1-c2 +34 c1-c2-c1-cp +35 c1-c2-c1-hc +36 c1-c2-c1-c2 + +Improper Type Labels + +1 cp-cp-cp-hc +2 cp-cp-cp-c1 +3 cp-c=1-hc-c= +4 hc-c=-hc-c=1 +5 cp-cp-cp-c3 +6 hc-c2-hc-c1 +7 cp-c1-hc-c2 +8 cp-cp-cp-c=1 +9 cp-c3-hc-c2 + Masses 1 12.0112 diff --git a/lib/atc/Makefile.lammps.linalg b/lib/atc/Makefile.lammps.linalg index 930ee6357b..ddbab36648 100644 --- a/lib/atc/Makefile.lammps.linalg +++ b/lib/atc/Makefile.lammps.linalg @@ -1,6 +1,6 @@ # Settings that the LAMMPS build will import when this package library is used atc_SYSINC = -atc_SYSLIB = -llinalg -lgfortran +atc_SYSLIB = -llinalg atc_SYSPATH = -L../../lib/linalg$(LIBOBJDIR) diff --git a/lib/awpmd/Makefile.lammps.linalg b/lib/awpmd/Makefile.lammps.linalg index 1d986da5d7..ce10c3ffa0 100644 --- a/lib/awpmd/Makefile.lammps.linalg +++ b/lib/awpmd/Makefile.lammps.linalg @@ -1,5 +1,5 @@ # Settings that the LAMMPS build will import when this package library is used awpmd_SYSINC = -awpmd_SYSLIB = -llinalg -lgfortran +awpmd_SYSLIB = -llinalg awpmd_SYSPATH = -L../../lib/linalg$(LIBOBJDIR) diff --git a/lib/awpmd/ivutils/include/erf.h b/lib/awpmd/ivutils/include/erf.h deleted file mode 100644 index b1cdbcb9dc..0000000000 --- a/lib/awpmd/ivutils/include/erf.h +++ /dev/null @@ -1,19 +0,0 @@ -# ifndef ERF_H -# define ERF_H - -# ifdef _WIN32 - -# ifdef __cplusplus -extern "C" { -# endif - -double erf(double x); -double erfc(double x); - -# ifdef __cplusplus -} -# endif - -# endif - -# endif diff --git a/lib/awpmd/ivutils/include/lapack_inter.h b/lib/awpmd/ivutils/include/lapack_inter.h index ac3e062b5b..a48ea5d821 100644 --- a/lib/awpmd/ivutils/include/lapack_inter.h +++ b/lib/awpmd/ivutils/include/lapack_inter.h @@ -1,53 +1,36 @@ // Interface for LAPACK function -# ifndef LAPACK_INTER_H -# define LAPACK_INTER_H +#ifndef LAPACK_INTER_H +#define LAPACK_INTER_H #include typedef int lapack_int; typedef complex lapack_complex_float; typedef complex lapack_complex_double; -#if defined(_WIN32) && !defined(__MINGW32__) +#define DGETRF dgetrf_ +#define DGETRS dgetrs_ +#define DGETRI dgetri_ +#define ZPPTRF zpptrf_ +#define ZPPTRI zpptri_ - //#define MKL_Complex8 lapack_complex_float - //#define MKL_Complex16 lapack_complex_double - #include "mkl.h" - - inline void ZPPTRF( char* uplo, const lapack_int* n, lapack_complex_double* ap, lapack_int* info ) { - ZPPTRF(uplo, (int*)n, (MKL_Complex16*)ap, (int*)info); - } - inline void ZPPTRI( char* uplo, const lapack_int* n, lapack_complex_double* ap, lapack_int* info ){ - ZPPTRI(uplo, (int*)n, (MKL_Complex16*)ap, (int*)info); - } - -#else - - #define DGETRF dgetrf_ - #define DGETRS dgetrs_ - #define DGETRI dgetri_ - #define ZPPTRF zpptrf_ - #define ZPPTRI zpptri_ - - #ifdef __cplusplus - extern "C" { - #endif /* __cplusplus */ - void dgetrf_( const lapack_int* m, const lapack_int* n, double* a, const lapack_int* lda, - lapack_int* ipiv, lapack_int* info ); - void dgetrs_( const char* trans, const lapack_int* n, const lapack_int* nrhs, - const double* a, const lapack_int* lda, const lapack_int* ipiv, - double* b, const lapack_int* ldb, lapack_int* info ); - void dgetri_( const lapack_int* n, double* a, const lapack_int* lda, - const lapack_int* ipiv, double* work, const lapack_int* lwork, - lapack_int* info ); - void zpptrf_( const char* uplo, const lapack_int* n, lapack_complex_double* ap, - lapack_int* info ); - void zpptri_( const char* uplo, const lapack_int* n, lapack_complex_double* ap, - lapack_int* info ); - #ifdef __cplusplus - } - #endif /* __cplusplus */ - -#endif +#ifdef __cplusplus +extern "C" { +#endif /* __cplusplus */ +void dgetrf_(const lapack_int *m, const lapack_int *n, double *a, + const lapack_int *lda, lapack_int *ipiv, lapack_int *info); +void dgetrs_(const char *trans, const lapack_int *n, const lapack_int *nrhs, + const double *a, const lapack_int *lda, const lapack_int *ipiv, + double *b, const lapack_int *ldb, lapack_int *info); +void dgetri_(const lapack_int *n, double *a, const lapack_int *lda, + const lapack_int *ipiv, double *work, const lapack_int *lwork, + lapack_int *info); +void zpptrf_(const char *uplo, const lapack_int *n, lapack_complex_double *ap, + lapack_int *info); +void zpptri_(const char *uplo, const lapack_int *n, lapack_complex_double *ap, + lapack_int *info); +#ifdef __cplusplus +} +#endif /* __cplusplus */ #endif /* lapack_intER_H */ diff --git a/lib/awpmd/systems/interact/TCP/wpmd.h b/lib/awpmd/systems/interact/TCP/wpmd.h index 4c65440014..06ac5886c3 100644 --- a/lib/awpmd/systems/interact/TCP/wpmd.h +++ b/lib/awpmd/systems/interact/TCP/wpmd.h @@ -149,10 +149,8 @@ # include "pairhash.h" # include "TCP/tcpdefs.h" # include "wavepacket.h" -# include "erf.h" # include "cerf.h" - using namespace std; # include "lapack_inter.h" diff --git a/lib/awpmd/systems/interact/TCP/wpmd_split.cpp b/lib/awpmd/systems/interact/TCP/wpmd_split.cpp index f85b1ebf59..46a5776fef 100644 --- a/lib/awpmd/systems/interact/TCP/wpmd_split.cpp +++ b/lib/awpmd/systems/interact/TCP/wpmd_split.cpp @@ -1,6 +1,4 @@ # include "wpmd_split.h" -//# include "erf.h" - void AWPMD_split::resize(int flag){ for(int s=0;s<2;s++){ diff --git a/lib/colvars/colvarbias_meta.cpp b/lib/colvars/colvarbias_meta.cpp index 911a1d89c1..0b31479276 100644 --- a/lib/colvars/colvarbias_meta.cpp +++ b/lib/colvars/colvarbias_meta.cpp @@ -14,7 +14,7 @@ #include // used to set the absolute path of a replica file -#if defined(WIN32) && !defined(__CYGWIN__) +#if defined(_WIN32) && !defined(__CYGWIN__) #include #define CHDIR ::_chdir #define GETCWD ::_getcwd diff --git a/lib/colvars/colvarproxy.cpp b/lib/colvars/colvarproxy.cpp index c091df828c..3d4c9c439b 100644 --- a/lib/colvars/colvarproxy.cpp +++ b/lib/colvars/colvarproxy.cpp @@ -8,10 +8,10 @@ // Colvars repository at GitHub. // Using access() to check if a file exists (until we can assume C++14/17) -#if !defined(WIN32) || defined(__CYGWIN__) +#if !defined(_WIN32) || defined(__CYGWIN__) #include #endif -#if defined(WIN32) +#if defined(_WIN32) #include #endif @@ -678,7 +678,7 @@ int colvarproxy_io::backup_file(char const *filename) // Simplified version of NAMD_file_exists() int exit_code; do { -#if defined(WIN32) && !defined(__CYGWIN__) +#if defined(_WIN32) && !defined(__CYGWIN__) // We could use _access_s here, but it is probably too new exit_code = _access(filename, 00); #else @@ -708,7 +708,7 @@ int colvarproxy_io::backup_file(char const *filename) int colvarproxy_io::remove_file(char const *filename) { int error_code = COLVARS_OK; -#if defined(WIN32) && !defined(__CYGWIN__) +#if defined(_WIN32) && !defined(__CYGWIN__) // Because the file may be open by other processes, rename it to filename.old std::string const renamed_file(std::string(filename)+".old"); // It may still be there from an interrupted run, so remove it to be safe @@ -741,7 +741,7 @@ int colvarproxy_io::remove_file(char const *filename) int colvarproxy_io::rename_file(char const *filename, char const *newfilename) { int error_code = COLVARS_OK; -#if defined(WIN32) && !defined(__CYGWIN__) +#if defined(_WIN32) && !defined(__CYGWIN__) // On straight Windows, must remove the destination before renaming it error_code |= remove_file(newfilename); #endif diff --git a/lib/electrode/Makefile.lammps.linalg b/lib/electrode/Makefile.lammps.linalg index e82066110e..0e03dd9bd7 100644 --- a/lib/electrode/Makefile.lammps.linalg +++ b/lib/electrode/Makefile.lammps.linalg @@ -1,5 +1,5 @@ # Settings that the LAMMPS build will import when this package library is used electrode_SYSINC = -electrode_SYSLIB = -llinalg -lgfortran +electrode_SYSLIB = -llinalg electrode_SYSPATH = -L../../lib/linalg$(LIBOBJDIR) diff --git a/lib/linalg/Makefile.gfortran b/lib/linalg/Makefile.g++ similarity index 56% rename from lib/linalg/Makefile.gfortran rename to lib/linalg/Makefile.g++ index 89ac3bbe6d..eb482b11b8 100644 --- a/lib/linalg/Makefile.gfortran +++ b/lib/linalg/Makefile.g++ @@ -6,20 +6,17 @@ SHELL = /bin/sh # ------ FILES ------ -SRC = $(wildcard *.f) - -FILES = $(SRC) Makefile.* README +SRC = $(wildcard *.cpp) # ------ DEFINITIONS ------ LIB = liblinalg.a -OBJ = $(SRC:.f=.o) +OBJ = $(SRC:.cpp=.o) # ------ SETTINGS ------ -FC = gfortran -FFLAGS = -O3 -fPIC -ffast-math -fstrict-aliasing -fno-second-underscore -FFLAGS0 = -O0 -fPIC -fno-second-underscore +CXX = g++ -std=c++11 +CCFLAGS = -O3 -fPIC -ffast-math -fstrict-aliasing ARCHIVE = ar AR = ar ARCHFLAG = -rcs @@ -33,17 +30,11 @@ lib: $(OBJ) # ------ COMPILE RULES ------ -%.o:%.f - $(FC) $(FFLAGS) -c $< - -dlamch.o: dlamch.f - $(FC) $(FFLAGS0) -c $< +%.o:%.cpp + $(CC) $(CCFLAGS) -c $< # ------ CLEAN ------ clean: - -rm -f *.o *.mod *~ $(LIB) - -tar: - -tar -czvf ../linalg.tar.gz $(FILES) + -rm -f *.o *~ $(LIB) diff --git a/lib/linalg/Makefile.mpi b/lib/linalg/Makefile.mpi index 74de6cdf3d..d0542d73fb 100644 --- a/lib/linalg/Makefile.mpi +++ b/lib/linalg/Makefile.mpi @@ -6,20 +6,17 @@ SHELL = /bin/sh # ------ FILES ------ -SRC = $(wildcard *.f) - -FILES = $(SRC) Makefile.* README +SRC = $(wildcard *.cpp) # ------ DEFINITIONS ------ LIB = liblinalg.a -OBJ = $(SRC:.f=.o) +OBJ = $(SRC:.cpp=.o) # ------ SETTINGS ------ -FC = mpifort -FFLAGS = -O3 -fPIC -FFLAGS0 = -O0 -fPIC +CC = mpicxx +CCFLAGS = -O3 -fPIC ARCHIVE = ar AR = ar ARCHFLAG = -rcs @@ -33,17 +30,11 @@ lib: $(OBJ) # ------ COMPILE RULES ------ -%.o:%.f - $(FC) $(FFLAGS) -c $< - -dlamch.o: dlamch.f - $(FC) $(FFLAGS0) -c $< +%.o:%.cpp + $(CC) $(CCFLAGS) -c $< # ------ CLEAN ------ clean: - -rm -f *.o *.mod *~ $(LIB) - -tar: - -tar -czvf ../linalg.tar.gz $(FILES) + -rm -f *.o *~ $(LIB) diff --git a/lib/linalg/Makefile.serial b/lib/linalg/Makefile.serial index c52fbcb986..9d7bb000f9 120000 --- a/lib/linalg/Makefile.serial +++ b/lib/linalg/Makefile.serial @@ -1 +1 @@ -Makefile.gfortran \ No newline at end of file +Makefile.g++ \ No newline at end of file diff --git a/lib/linalg/README b/lib/linalg/README index e3b817cacc..6c04225d17 100644 --- a/lib/linalg/README +++ b/lib/linalg/README @@ -1,7 +1,13 @@ This directory has generic BLAS and LAPACK source files needed by the ATC, AWPMD, ELECTRODE, LATTE, and ML-POD packages (and possibly by other packages) in the future that can be used instead of platform or vendor -optimized BLAS/LAPACK library. +optimized BLAS/LAPACK library. To simplify installation, these files +have been translated from the Fortran versions of the BLAS and LAPACK +references source files at https://netlib.org/lapack/ to C++ with f2c. +The package with the tools to do the translation and the matching +original Fortran sources are at https://github.com/lammps/linalg. +Please note that even through the files are C++ source code the +resulting library will follow the Fortran binary conventions. Note that this is an *incomplete* subset of full BLAS/LAPACK. @@ -20,7 +26,7 @@ can do it manually by following the instructions below. Build the library using one of the provided Makefile.* files or create your own, specific to your compiler and system. For example: -make -f Makefile.gfortran +make -f Makefile.g++ When you are done building this library, one file should exist in this directory: diff --git a/lib/linalg/d_lmp_cnjg.cpp b/lib/linalg/d_lmp_cnjg.cpp new file mode 100644 index 0000000000..03ca8f98fd --- /dev/null +++ b/lib/linalg/d_lmp_cnjg.cpp @@ -0,0 +1,13 @@ + +#include "lmp_f2c.h" + +extern "C" { + +void d_lmp_cnjg(doublecomplex *r, doublecomplex *z) +{ + doublereal zi = z->i; + + r->r = z->r; + r->i = -zi; +} +} diff --git a/lib/linalg/d_lmp_imag.cpp b/lib/linalg/d_lmp_imag.cpp new file mode 100644 index 0000000000..f0443f7828 --- /dev/null +++ b/lib/linalg/d_lmp_imag.cpp @@ -0,0 +1,10 @@ + +#include "lmp_f2c.h" + +extern "C" { + +double d_lmp_imag(doublecomplex *z) +{ + return (z->i); +} +} diff --git a/lib/linalg/d_lmp_lg10.cpp b/lib/linalg/d_lmp_lg10.cpp new file mode 100644 index 0000000000..ec48c99839 --- /dev/null +++ b/lib/linalg/d_lmp_lg10.cpp @@ -0,0 +1,14 @@ + +#include "lmp_f2c.h" +#undef abs + +static constexpr double log10e = 0.43429448190325182765; + +#include + +extern "C" { +double d_lmp_lg10(doublereal *x) +{ + return (log10e * log(*x)); +} +} diff --git a/lib/linalg/d_lmp_sign.cpp b/lib/linalg/d_lmp_sign.cpp new file mode 100644 index 0000000000..fb0a1e79ff --- /dev/null +++ b/lib/linalg/d_lmp_sign.cpp @@ -0,0 +1,12 @@ + +#include "lmp_f2c.h" + +extern "C" { + +double d_lmp_sign(doublereal *a, doublereal *b) +{ + double x; + x = (*a >= 0 ? *a : -*a); + return (*b >= 0 ? x : -x); +} +} diff --git a/lib/linalg/dasum.cpp b/lib/linalg/dasum.cpp new file mode 100644 index 0000000000..faf6f38081 --- /dev/null +++ b/lib/linalg/dasum.cpp @@ -0,0 +1,50 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +doublereal dasum_(integer *n, doublereal *dx, integer *incx) +{ + integer i__1, i__2; + doublereal ret_val, d__1, d__2, d__3, d__4, d__5, d__6; + integer i__, m, mp1; + doublereal dtemp; + integer nincx; + --dx; + ret_val = 0.; + dtemp = 0.; + if (*n <= 0 || *incx <= 0) { + return ret_val; + } + if (*incx == 1) { + m = *n % 6; + if (m != 0) { + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + dtemp += (d__1 = dx[i__], abs(d__1)); + } + if (*n < 6) { + ret_val = dtemp; + return ret_val; + } + } + mp1 = m + 1; + i__1 = *n; + for (i__ = mp1; i__ <= i__1; i__ += 6) { + dtemp = dtemp + (d__1 = dx[i__], abs(d__1)) + (d__2 = dx[i__ + 1], abs(d__2)) + + (d__3 = dx[i__ + 2], abs(d__3)) + (d__4 = dx[i__ + 3], abs(d__4)) + + (d__5 = dx[i__ + 4], abs(d__5)) + (d__6 = dx[i__ + 5], abs(d__6)); + } + } else { + nincx = *n * *incx; + i__1 = nincx; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + dtemp += (d__1 = dx[i__], abs(d__1)); + } + } + ret_val = dtemp; + return ret_val; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dasum.f b/lib/linalg/dasum.f deleted file mode 100644 index 9a360b5acd..0000000000 --- a/lib/linalg/dasum.f +++ /dev/null @@ -1,131 +0,0 @@ -*> \brief \b DASUM -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) -* -* .. Scalar Arguments .. -* INTEGER INCX,N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION DX(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DASUM takes the sum of the absolute values. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> number of elements in input vector(s) -*> \endverbatim -*> -*> \param[in] DX -*> \verbatim -*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> storage spacing between elements of DX -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level1 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> jack dongarra, linpack, 3/11/78. -*> modified 3/93 to return if incx .le. 0. -*> modified 12/3/93, array(1) declarations changed to array(*) -*> \endverbatim -*> -* ===================================================================== - DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - DOUBLE PRECISION DTEMP - INTEGER I,M,MP1,NINCX -* .. -* .. Intrinsic Functions .. - INTRINSIC DABS,MOD -* .. - DASUM = 0.0d0 - DTEMP = 0.0d0 - IF (N.LE.0 .OR. INCX.LE.0) RETURN - IF (INCX.EQ.1) THEN -* code for increment equal to 1 -* -* -* clean-up loop -* - M = MOD(N,6) - IF (M.NE.0) THEN - DO I = 1,M - DTEMP = DTEMP + DABS(DX(I)) - END DO - IF (N.LT.6) THEN - DASUM = DTEMP - RETURN - END IF - END IF - MP1 = M + 1 - DO I = MP1,N,6 - DTEMP = DTEMP + DABS(DX(I)) + DABS(DX(I+1)) + - $ DABS(DX(I+2)) + DABS(DX(I+3)) + - $ DABS(DX(I+4)) + DABS(DX(I+5)) - END DO - ELSE -* -* code for increment not equal to 1 -* - NINCX = N*INCX - DO I = 1,NINCX,INCX - DTEMP = DTEMP + DABS(DX(I)) - END DO - END IF - DASUM = DTEMP - RETURN -* -* End of DASUM -* - END diff --git a/lib/linalg/daxpy.cpp b/lib/linalg/daxpy.cpp new file mode 100644 index 0000000000..1f820f6fc4 --- /dev/null +++ b/lib/linalg/daxpy.cpp @@ -0,0 +1,56 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int daxpy_(integer *n, doublereal *da, doublereal *dx, integer *incx, doublereal *dy, integer *incy) +{ + integer i__1; + integer i__, m, ix, iy, mp1; + --dy; + --dx; + if (*n <= 0) { + return 0; + } + if (*da == 0.) { + return 0; + } + if (*incx == 1 && *incy == 1) { + m = *n % 4; + if (m != 0) { + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + dy[i__] += *da * dx[i__]; + } + } + if (*n < 4) { + return 0; + } + mp1 = m + 1; + i__1 = *n; + for (i__ = mp1; i__ <= i__1; i__ += 4) { + dy[i__] += *da * dx[i__]; + dy[i__ + 1] += *da * dx[i__ + 1]; + dy[i__ + 2] += *da * dx[i__ + 2]; + dy[i__ + 3] += *da * dx[i__ + 3]; + } + } 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__) { + dy[iy] += *da * dx[ix]; + ix += *incx; + iy += *incy; + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/daxpy.f b/lib/linalg/daxpy.f deleted file mode 100644 index 421f7c630b..0000000000 --- a/lib/linalg/daxpy.f +++ /dev/null @@ -1,152 +0,0 @@ -*> \brief \b DAXPY -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION DA -* INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION DX(*),DY(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DAXPY constant times a vector plus a vector. -*> uses unrolled loops for increments equal to one. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> number of elements in input vector(s) -*> \endverbatim -*> -*> \param[in] DA -*> \verbatim -*> DA is DOUBLE PRECISION -*> On entry, DA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] DX -*> \verbatim -*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> storage spacing between elements of DX -*> \endverbatim -*> -*> \param[in,out] DY -*> \verbatim -*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> storage spacing between elements of DY -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level1 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> jack dongarra, linpack, 3/11/78. -*> modified 12/3/93, array(1) declarations changed to array(*) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION DA - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*),DY(*) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I,IX,IY,M,MP1 -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - IF (N.LE.0) RETURN - IF (DA.EQ.0.0d0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 -* -* -* clean-up loop -* - M = MOD(N,4) - IF (M.NE.0) THEN - DO I = 1,M - DY(I) = DY(I) + DA*DX(I) - END DO - END IF - IF (N.LT.4) RETURN - MP1 = M + 1 - DO I = MP1,N,4 - DY(I) = DY(I) + DA*DX(I) - DY(I+1) = DY(I+1) + DA*DX(I+1) - DY(I+2) = DY(I+2) + DA*DX(I+2) - DY(I+3) = DY(I+3) + DA*DX(I+3) - END DO - ELSE -* -* code for unequal increments or equal increments -* not equal to 1 -* - IX = 1 - IY = 1 - IF (INCX.LT.0) IX = (-N+1)*INCX + 1 - IF (INCY.LT.0) IY = (-N+1)*INCY + 1 - DO I = 1,N - DY(IY) = DY(IY) + DA*DX(IX) - IX = IX + INCX - IY = IY + INCY - END DO - END IF - RETURN -* -* End of DAXPY -* - END diff --git a/lib/linalg/dbdsqr.cpp b/lib/linalg/dbdsqr.cpp new file mode 100644 index 0000000000..59498b4ae6 --- /dev/null +++ b/lib/linalg/dbdsqr.cpp @@ -0,0 +1,522 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static doublereal c_b15 = -.125; +static integer c__1 = 1; +static doublereal c_b49 = 1.; +static doublereal c_b72 = -1.; +int dbdsqr_(char *uplo, integer *n, integer *ncvt, integer *nru, integer *ncc, doublereal *d__, + doublereal *e, doublereal *vt, integer *ldvt, doublereal *u, integer *ldu, + doublereal *c__, integer *ldc, doublereal *work, integer *info, ftnlen uplo_len) +{ + integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2; + doublereal d__1, d__2, d__3, d__4; + double pow_lmp_dd(doublereal *, doublereal *), sqrt(doublereal), d_lmp_sign(doublereal *, doublereal *); + integer iterdivn; + doublereal f, g, h__; + integer i__, j, m; + doublereal r__; + integer maxitdivn; + doublereal cs; + integer ll; + doublereal sn, mu; + integer nm1, nm12, nm13, lll; + doublereal eps, sll, tol, abse; + integer idir; + doublereal abss; + integer oldm; + doublereal cosl; + integer isub, iter; + doublereal unfl, sinl, cosr, smin, smax, sinr; + extern int drot_(integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, + doublereal *), + dlas2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *), + dscal_(integer *, doublereal *, doublereal *, integer *); + extern logical lsame_(char *, char *, ftnlen, ftnlen); + doublereal oldcs; + extern int dlasr_(char *, char *, char *, integer *, integer *, doublereal *, doublereal *, + doublereal *, integer *, ftnlen, ftnlen, ftnlen); + integer oldll; + doublereal shift, sigmn, oldsn; + extern int dswap_(integer *, doublereal *, integer *, doublereal *, integer *); + doublereal sminl, sigmx; + logical lower; + extern int dlasq1_(integer *, doublereal *, doublereal *, doublereal *, integer *), + dlasv2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *); + extern doublereal dlamch_(char *, ftnlen); + extern int dlartg_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *), + xerbla_(char *, integer *, ftnlen); + doublereal sminoa, thresh; + logical rotate; + doublereal tolmul; + --d__; + --e; + vt_dim1 = *ldvt; + vt_offset = 1 + vt_dim1; + vt -= vt_offset; + u_dim1 = *ldu; + u_offset = 1 + u_dim1; + u -= u_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --work; + *info = 0; + lower = lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1); + if (!lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1) && !lower) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*ncvt < 0) { + *info = -3; + } else if (*nru < 0) { + *info = -4; + } else if (*ncc < 0) { + *info = -5; + } else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < max(1, *n)) { + *info = -9; + } else if (*ldu < max(1, *nru)) { + *info = -11; + } else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < max(1, *n)) { + *info = -13; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DBDSQR", &i__1, (ftnlen)6); + return 0; + } + if (*n == 0) { + return 0; + } + if (*n == 1) { + goto L160; + } + rotate = *ncvt > 0 || *nru > 0 || *ncc > 0; + if (!rotate) { + dlasq1_(n, &d__[1], &e[1], &work[1], info); + if (*info != 2) { + return 0; + } + *info = 0; + } + nm1 = *n - 1; + nm12 = nm1 + nm1; + nm13 = nm12 + nm1; + idir = 0; + eps = dlamch_((char *)"Epsilon", (ftnlen)7); + unfl = dlamch_((char *)"Safe minimum", (ftnlen)12); + if (lower) { + 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]; + work[i__] = cs; + work[nm1 + i__] = sn; + } + if (*nru > 0) { + dlasr_((char *)"R", (char *)"V", (char *)"F", nru, n, &work[1], &work[*n], &u[u_offset], ldu, (ftnlen)1, + (ftnlen)1, (ftnlen)1); + } + if (*ncc > 0) { + dlasr_((char *)"L", (char *)"V", (char *)"F", n, ncc, &work[1], &work[*n], &c__[c_offset], ldc, (ftnlen)1, + (ftnlen)1, (ftnlen)1); + } + } + d__3 = 100., d__4 = pow_lmp_dd(&eps, &c_b15); + d__1 = 10., d__2 = min(d__3, d__4); + tolmul = max(d__1, d__2); + tol = tolmul * eps; + smax = 0.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__2 = smax, d__3 = (d__1 = d__[i__], abs(d__1)); + smax = max(d__2, d__3); + } + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + d__2 = smax, d__3 = (d__1 = e[i__], abs(d__1)); + smax = max(d__2, d__3); + } + sminl = 0.; + if (tol >= 0.) { + sminoa = abs(d__[1]); + if (sminoa == 0.) { + goto L50; + } + mu = sminoa; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + mu = (d__2 = d__[i__], abs(d__2)) * (mu / (mu + (d__1 = e[i__ - 1], abs(d__1)))); + sminoa = min(sminoa, mu); + if (sminoa == 0.) { + goto L50; + } + } + L50: + sminoa /= sqrt((doublereal)(*n)); + d__1 = tol * sminoa, d__2 = *n * (*n * unfl) * 6; + thresh = max(d__1, d__2); + } else { + d__1 = abs(tol) * smax, d__2 = *n * (*n * unfl) * 6; + thresh = max(d__1, d__2); + } + maxitdivn = *n * 6; + iterdivn = 0; + iter = -1; + oldll = -1; + oldm = -1; + m = *n; +L60: + if (m <= 1) { + goto L160; + } + if (iter >= *n) { + iter -= *n; + ++iterdivn; + if (iterdivn >= maxitdivn) { + goto L200; + } + } + if (tol < 0. && (d__1 = d__[m], abs(d__1)) <= thresh) { + d__[m] = 0.; + } + smax = (d__1 = d__[m], abs(d__1)); + smin = smax; + i__1 = m - 1; + for (lll = 1; lll <= i__1; ++lll) { + ll = m - lll; + abss = (d__1 = d__[ll], abs(d__1)); + abse = (d__1 = e[ll], abs(d__1)); + if (tol < 0. && abss <= thresh) { + d__[ll] = 0.; + } + if (abse <= thresh) { + goto L80; + } + smin = min(smin, abss); + d__1 = max(smax, abss); + smax = max(d__1, abse); + } + ll = 0; + goto L90; +L80: + e[ll] = 0.; + if (ll == m - 1) { + --m; + goto L60; + } +L90: + ++ll; + if (ll == m - 1) { + dlasv2_(&d__[m - 1], &e[m - 1], &d__[m], &sigmn, &sigmx, &sinr, &cosr, &sinl, &cosl); + d__[m - 1] = sigmx; + e[m - 1] = 0.; + d__[m] = sigmn; + if (*ncvt > 0) { + drot_(ncvt, &vt[m - 1 + vt_dim1], ldvt, &vt[m + vt_dim1], ldvt, &cosr, &sinr); + } + if (*nru > 0) { + drot_(nru, &u[(m - 1) * u_dim1 + 1], &c__1, &u[m * u_dim1 + 1], &c__1, &cosl, &sinl); + } + if (*ncc > 0) { + drot_(ncc, &c__[m - 1 + c_dim1], ldc, &c__[m + c_dim1], ldc, &cosl, &sinl); + } + m += -2; + goto L60; + } + if (ll > oldm || m < oldll) { + if ((d__1 = d__[ll], abs(d__1)) >= (d__2 = d__[m], abs(d__2))) { + idir = 1; + } else { + idir = 2; + } + } + if (idir == 1) { + if ((d__2 = e[m - 1], abs(d__2)) <= abs(tol) * (d__1 = d__[m], abs(d__1)) || + tol < 0. && (d__3 = e[m - 1], abs(d__3)) <= thresh) { + e[m - 1] = 0.; + goto L60; + } + if (tol >= 0.) { + mu = (d__1 = d__[ll], abs(d__1)); + sminl = mu; + i__1 = m - 1; + for (lll = ll; lll <= i__1; ++lll) { + if ((d__1 = e[lll], abs(d__1)) <= tol * mu) { + e[lll] = 0.; + goto L60; + } + mu = (d__2 = d__[lll + 1], abs(d__2)) * (mu / (mu + (d__1 = e[lll], abs(d__1)))); + sminl = min(sminl, mu); + } + } + } else { + if ((d__2 = e[ll], abs(d__2)) <= abs(tol) * (d__1 = d__[ll], abs(d__1)) || + tol < 0. && (d__3 = e[ll], abs(d__3)) <= thresh) { + e[ll] = 0.; + goto L60; + } + if (tol >= 0.) { + mu = (d__1 = d__[m], abs(d__1)); + sminl = mu; + i__1 = ll; + for (lll = m - 1; lll >= i__1; --lll) { + if ((d__1 = e[lll], abs(d__1)) <= tol * mu) { + e[lll] = 0.; + goto L60; + } + mu = (d__2 = d__[lll], abs(d__2)) * (mu / (mu + (d__1 = e[lll], abs(d__1)))); + sminl = min(sminl, mu); + } + } + } + oldll = ll; + oldm = m; + d__1 = eps, d__2 = tol * .01; + if (tol >= 0. && *n * tol * (sminl / smax) <= max(d__1, d__2)) { + shift = 0.; + } else { + if (idir == 1) { + sll = (d__1 = d__[ll], abs(d__1)); + dlas2_(&d__[m - 1], &e[m - 1], &d__[m], &shift, &r__); + } else { + sll = (d__1 = d__[m], abs(d__1)); + dlas2_(&d__[ll], &e[ll], &d__[ll + 1], &shift, &r__); + } + if (sll > 0.) { + d__1 = shift / sll; + if (d__1 * d__1 < eps) { + shift = 0.; + } + } + } + iter = iter + m - ll; + if (shift == 0.) { + if (idir == 1) { + cs = 1.; + oldcs = 1.; + i__1 = m - 1; + for (i__ = ll; i__ <= i__1; ++i__) { + d__1 = d__[i__] * cs; + dlartg_(&d__1, &e[i__], &cs, &sn, &r__); + if (i__ > ll) { + e[i__ - 1] = oldsn * r__; + } + d__1 = oldcs * r__; + d__2 = d__[i__ + 1] * sn; + dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]); + work[i__ - ll + 1] = cs; + work[i__ - ll + 1 + nm1] = sn; + work[i__ - ll + 1 + nm12] = oldcs; + work[i__ - ll + 1 + nm13] = oldsn; + } + h__ = d__[m] * cs; + d__[m] = h__ * oldcs; + e[m - 1] = h__ * oldsn; + if (*ncvt > 0) { + i__1 = m - ll + 1; + dlasr_((char *)"L", (char *)"V", (char *)"F", &i__1, ncvt, &work[1], &work[*n], &vt[ll + vt_dim1], ldvt, + (ftnlen)1, (ftnlen)1, (ftnlen)1); + } + if (*nru > 0) { + i__1 = m - ll + 1; + dlasr_((char *)"R", (char *)"V", (char *)"F", nru, &i__1, &work[nm12 + 1], &work[nm13 + 1], + &u[ll * u_dim1 + 1], ldu, (ftnlen)1, (ftnlen)1, (ftnlen)1); + } + if (*ncc > 0) { + i__1 = m - ll + 1; + dlasr_((char *)"L", (char *)"V", (char *)"F", &i__1, ncc, &work[nm12 + 1], &work[nm13 + 1], + &c__[ll + c_dim1], ldc, (ftnlen)1, (ftnlen)1, (ftnlen)1); + } + if ((d__1 = e[m - 1], abs(d__1)) <= thresh) { + e[m - 1] = 0.; + } + } else { + cs = 1.; + oldcs = 1.; + i__1 = ll + 1; + for (i__ = m; i__ >= i__1; --i__) { + d__1 = d__[i__] * cs; + dlartg_(&d__1, &e[i__ - 1], &cs, &sn, &r__); + if (i__ < m) { + e[i__] = oldsn * r__; + } + d__1 = oldcs * r__; + d__2 = d__[i__ - 1] * sn; + dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]); + work[i__ - ll] = cs; + work[i__ - ll + nm1] = -sn; + work[i__ - ll + nm12] = oldcs; + work[i__ - ll + nm13] = -oldsn; + } + h__ = d__[ll] * cs; + d__[ll] = h__ * oldcs; + e[ll] = h__ * oldsn; + if (*ncvt > 0) { + i__1 = m - ll + 1; + dlasr_((char *)"L", (char *)"V", (char *)"B", &i__1, ncvt, &work[nm12 + 1], &work[nm13 + 1], + &vt[ll + vt_dim1], ldvt, (ftnlen)1, (ftnlen)1, (ftnlen)1); + } + if (*nru > 0) { + i__1 = m - ll + 1; + dlasr_((char *)"R", (char *)"V", (char *)"B", nru, &i__1, &work[1], &work[*n], &u[ll * u_dim1 + 1], ldu, + (ftnlen)1, (ftnlen)1, (ftnlen)1); + } + if (*ncc > 0) { + i__1 = m - ll + 1; + dlasr_((char *)"L", (char *)"V", (char *)"B", &i__1, ncc, &work[1], &work[*n], &c__[ll + c_dim1], ldc, + (ftnlen)1, (ftnlen)1, (ftnlen)1); + } + if ((d__1 = e[ll], abs(d__1)) <= thresh) { + e[ll] = 0.; + } + } + } else { + if (idir == 1) { + f = ((d__1 = d__[ll], abs(d__1)) - shift) * + (d_lmp_sign(&c_b49, &d__[ll]) + shift / d__[ll]); + g = e[ll]; + i__1 = m - 1; + for (i__ = ll; i__ <= i__1; ++i__) { + dlartg_(&f, &g, &cosr, &sinr, &r__); + if (i__ > ll) { + e[i__ - 1] = r__; + } + f = cosr * d__[i__] + sinr * e[i__]; + e[i__] = cosr * e[i__] - sinr * d__[i__]; + g = sinr * d__[i__ + 1]; + d__[i__ + 1] = cosr * d__[i__ + 1]; + dlartg_(&f, &g, &cosl, &sinl, &r__); + d__[i__] = r__; + f = cosl * e[i__] + sinl * d__[i__ + 1]; + d__[i__ + 1] = cosl * d__[i__ + 1] - sinl * e[i__]; + if (i__ < m - 1) { + g = sinl * e[i__ + 1]; + e[i__ + 1] = cosl * e[i__ + 1]; + } + work[i__ - ll + 1] = cosr; + work[i__ - ll + 1 + nm1] = sinr; + work[i__ - ll + 1 + nm12] = cosl; + work[i__ - ll + 1 + nm13] = sinl; + } + e[m - 1] = f; + if (*ncvt > 0) { + i__1 = m - ll + 1; + dlasr_((char *)"L", (char *)"V", (char *)"F", &i__1, ncvt, &work[1], &work[*n], &vt[ll + vt_dim1], ldvt, + (ftnlen)1, (ftnlen)1, (ftnlen)1); + } + if (*nru > 0) { + i__1 = m - ll + 1; + dlasr_((char *)"R", (char *)"V", (char *)"F", nru, &i__1, &work[nm12 + 1], &work[nm13 + 1], + &u[ll * u_dim1 + 1], ldu, (ftnlen)1, (ftnlen)1, (ftnlen)1); + } + if (*ncc > 0) { + i__1 = m - ll + 1; + dlasr_((char *)"L", (char *)"V", (char *)"F", &i__1, ncc, &work[nm12 + 1], &work[nm13 + 1], + &c__[ll + c_dim1], ldc, (ftnlen)1, (ftnlen)1, (ftnlen)1); + } + if ((d__1 = e[m - 1], abs(d__1)) <= thresh) { + e[m - 1] = 0.; + } + } else { + f = ((d__1 = d__[m], abs(d__1)) - shift) * (d_lmp_sign(&c_b49, &d__[m]) + shift / d__[m]); + g = e[m - 1]; + i__1 = ll + 1; + for (i__ = m; i__ >= i__1; --i__) { + dlartg_(&f, &g, &cosr, &sinr, &r__); + if (i__ < m) { + e[i__] = r__; + } + f = cosr * d__[i__] + sinr * e[i__ - 1]; + e[i__ - 1] = cosr * e[i__ - 1] - sinr * d__[i__]; + g = sinr * d__[i__ - 1]; + d__[i__ - 1] = cosr * d__[i__ - 1]; + dlartg_(&f, &g, &cosl, &sinl, &r__); + d__[i__] = r__; + f = cosl * e[i__ - 1] + sinl * d__[i__ - 1]; + d__[i__ - 1] = cosl * d__[i__ - 1] - sinl * e[i__ - 1]; + if (i__ > ll + 1) { + g = sinl * e[i__ - 2]; + e[i__ - 2] = cosl * e[i__ - 2]; + } + work[i__ - ll] = cosr; + work[i__ - ll + nm1] = -sinr; + work[i__ - ll + nm12] = cosl; + work[i__ - ll + nm13] = -sinl; + } + e[ll] = f; + if ((d__1 = e[ll], abs(d__1)) <= thresh) { + e[ll] = 0.; + } + if (*ncvt > 0) { + i__1 = m - ll + 1; + dlasr_((char *)"L", (char *)"V", (char *)"B", &i__1, ncvt, &work[nm12 + 1], &work[nm13 + 1], + &vt[ll + vt_dim1], ldvt, (ftnlen)1, (ftnlen)1, (ftnlen)1); + } + if (*nru > 0) { + i__1 = m - ll + 1; + dlasr_((char *)"R", (char *)"V", (char *)"B", nru, &i__1, &work[1], &work[*n], &u[ll * u_dim1 + 1], ldu, + (ftnlen)1, (ftnlen)1, (ftnlen)1); + } + if (*ncc > 0) { + i__1 = m - ll + 1; + dlasr_((char *)"L", (char *)"V", (char *)"B", &i__1, ncc, &work[1], &work[*n], &c__[ll + c_dim1], ldc, + (ftnlen)1, (ftnlen)1, (ftnlen)1); + } + } + } + goto L60; +L160: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (d__[i__] < 0.) { + d__[i__] = -d__[i__]; + if (*ncvt > 0) { + dscal_(ncvt, &c_b72, &vt[i__ + vt_dim1], ldvt); + } + } + } + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + isub = 1; + smin = d__[1]; + i__2 = *n + 1 - i__; + for (j = 2; j <= i__2; ++j) { + if (d__[j] <= smin) { + isub = j; + smin = d__[j]; + } + } + if (isub != *n + 1 - i__) { + d__[isub] = d__[*n + 1 - i__]; + d__[*n + 1 - i__] = smin; + if (*ncvt > 0) { + dswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[*n + 1 - i__ + vt_dim1], ldvt); + } + if (*nru > 0) { + dswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[(*n + 1 - i__) * u_dim1 + 1], &c__1); + } + if (*ncc > 0) { + dswap_(ncc, &c__[isub + c_dim1], ldc, &c__[*n + 1 - i__ + c_dim1], ldc); + } + } + } + goto L220; +L200: + *info = 0; + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + if (e[i__] != 0.) { + ++(*info); + } + } +L220: + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dbdsqr.f b/lib/linalg/dbdsqr.f deleted file mode 100644 index c220a5875d..0000000000 --- a/lib/linalg/dbdsqr.f +++ /dev/null @@ -1,864 +0,0 @@ -*> \brief \b DBDSQR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DBDSQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, -* LDU, C, LDC, WORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU -* .. -* .. Array Arguments .. -* DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ), -* $ VT( LDVT, * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DBDSQR computes the singular values and, optionally, the right and/or -*> left singular vectors from the singular value decomposition (SVD) of -*> a real N-by-N (upper or lower) bidiagonal matrix B using the implicit -*> zero-shift QR algorithm. The SVD of B has the form -*> -*> B = Q * S * P**T -*> -*> where S is the diagonal matrix of singular values, Q is an orthogonal -*> matrix of left singular vectors, and P is an orthogonal matrix of -*> right singular vectors. If left singular vectors are requested, this -*> subroutine actually returns U*Q instead of Q, and, if right singular -*> vectors are requested, this subroutine returns P**T*VT instead of -*> P**T, for given real input matrices U and VT. When U and VT are the -*> orthogonal matrices that reduce a general matrix A to bidiagonal -*> form: A = U*B*VT, as computed by DGEBRD, then -*> -*> A = (U*Q) * S * (P**T*VT) -*> -*> is the SVD of A. Optionally, the subroutine may also compute Q**T*C -*> for a given real input matrix C. -*> -*> See "Computing Small Singular Values of Bidiagonal Matrices With -*> Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, -*> LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11, -*> no. 5, pp. 873-912, Sept 1990) and -*> "Accurate singular values and differential qd algorithms," by -*> B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics -*> Department, University of California at Berkeley, July 1992 -*> for a detailed description of the algorithm. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': B is upper bidiagonal; -*> = 'L': B is lower bidiagonal. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix B. N >= 0. -*> \endverbatim -*> -*> \param[in] NCVT -*> \verbatim -*> NCVT is INTEGER -*> The number of columns of the matrix VT. NCVT >= 0. -*> \endverbatim -*> -*> \param[in] NRU -*> \verbatim -*> NRU is INTEGER -*> The number of rows of the matrix U. NRU >= 0. -*> \endverbatim -*> -*> \param[in] NCC -*> \verbatim -*> NCC is INTEGER -*> The number of columns of the matrix C. NCC >= 0. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, the n diagonal elements of the bidiagonal matrix B. -*> On exit, if INFO=0, the singular values of B in decreasing -*> order. -*> \endverbatim -*> -*> \param[in,out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N-1) -*> On entry, the N-1 offdiagonal elements of the bidiagonal -*> matrix B. -*> On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E -*> will contain the diagonal and superdiagonal elements of a -*> bidiagonal matrix orthogonally equivalent to the one given -*> as input. -*> \endverbatim -*> -*> \param[in,out] VT -*> \verbatim -*> VT is DOUBLE PRECISION array, dimension (LDVT, NCVT) -*> On entry, an N-by-NCVT matrix VT. -*> On exit, VT is overwritten by P**T * VT. -*> Not referenced if NCVT = 0. -*> \endverbatim -*> -*> \param[in] LDVT -*> \verbatim -*> LDVT is INTEGER -*> The leading dimension of the array VT. -*> LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0. -*> \endverbatim -*> -*> \param[in,out] U -*> \verbatim -*> U is DOUBLE PRECISION array, dimension (LDU, N) -*> On entry, an NRU-by-N matrix U. -*> On exit, U is overwritten by U * Q. -*> Not referenced if NRU = 0. -*> \endverbatim -*> -*> \param[in] LDU -*> \verbatim -*> LDU is INTEGER -*> The leading dimension of the array U. LDU >= max(1,NRU). -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension (LDC, NCC) -*> On entry, an N-by-NCC matrix C. -*> On exit, C is overwritten by Q**T * C. -*> Not referenced if NCC = 0. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. -*> LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (4*(N-1)) -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: If INFO = -i, the i-th argument had an illegal value -*> > 0: -*> if NCVT = NRU = NCC = 0, -*> = 1, a split was marked by a positive value in E -*> = 2, current block of Z not diagonalized after 30*N -*> iterations (in inner while loop) -*> = 3, termination criterion of outer while loop not met -*> (program created more than N unreduced blocks) -*> else NCVT = NRU = NCC = 0, -*> the algorithm did not converge; D and E contain the -*> elements of a bidiagonal matrix which is orthogonally -*> similar to the input matrix B; if INFO = i, i -*> elements of E have not converged to zero. -*> \endverbatim -* -*> \par Internal Parameters: -* ========================= -*> -*> \verbatim -*> TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8))) -*> TOLMUL controls the convergence criterion of the QR loop. -*> If it is positive, TOLMUL*EPS is the desired relative -*> precision in the computed singular values. -*> If it is negative, abs(TOLMUL*EPS*sigma_max) is the -*> desired absolute accuracy in the computed singular -*> values (corresponds to relative accuracy -*> abs(TOLMUL*EPS) in the largest singular value. -*> abs(TOLMUL) should be between 1 and 1/EPS, and preferably -*> between 10 (for fast convergence) and .1/EPS -*> (for there to be some accuracy in the results). -*> Default is to lose at either one eighth or 2 of the -*> available decimal digits in each computed singular value -*> (whichever is smaller). -*> -*> MAXITR INTEGER, default = 6 -*> MAXITR controls the maximum number of passes of the -*> algorithm through its inner loop. The algorithms stops -*> (and so fails to converge) if the number of passes -*> through the inner loop exceeds MAXITR*N**2. -*> -*> \endverbatim -* -*> \par Note: -* =========== -*> -*> \verbatim -*> Bug report from Cezary Dendek. -*> On March 23rd 2017, the INTEGER variable MAXIT = MAXITR*N**2 is -*> removed since it can overflow pretty easily (for N larger or equal -*> than 18,919). We instead use MAXITDIVN = MAXITR*N. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -* ===================================================================== - SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, - $ LDU, C, LDC, WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU -* .. -* .. Array Arguments .. - DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ), - $ VT( LDVT, * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) - DOUBLE PRECISION NEGONE - PARAMETER ( NEGONE = -1.0D0 ) - DOUBLE PRECISION HNDRTH - PARAMETER ( HNDRTH = 0.01D0 ) - DOUBLE PRECISION TEN - PARAMETER ( TEN = 10.0D0 ) - DOUBLE PRECISION HNDRD - PARAMETER ( HNDRD = 100.0D0 ) - DOUBLE PRECISION MEIGTH - PARAMETER ( MEIGTH = -0.125D0 ) - INTEGER MAXITR - PARAMETER ( MAXITR = 6 ) -* .. -* .. Local Scalars .. - LOGICAL LOWER, ROTATE - INTEGER I, IDIR, ISUB, ITER, ITERDIVN, J, LL, LLL, M, - $ MAXITDIVN, NM1, NM12, NM13, OLDLL, OLDM - DOUBLE PRECISION ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU, - $ OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL, - $ SINR, SLL, SMAX, SMIN, SMINL, SMINOA, - $ SN, THRESH, TOL, TOLMUL, UNFL -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DLARTG, DLAS2, DLASQ1, DLASR, DLASV2, DROT, - $ DSCAL, DSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - LOWER = LSAME( UPLO, 'L' ) - IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LOWER ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NCVT.LT.0 ) THEN - INFO = -3 - ELSE IF( NRU.LT.0 ) THEN - INFO = -4 - ELSE IF( NCC.LT.0 ) THEN - INFO = -5 - ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR. - $ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN - INFO = -9 - ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN - INFO = -11 - ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR. - $ ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN - INFO = -13 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DBDSQR', -INFO ) - RETURN - END IF - IF( N.EQ.0 ) - $ RETURN - IF( N.EQ.1 ) - $ GO TO 160 -* -* ROTATE is true if any singular vectors desired, false otherwise -* - ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 ) -* -* If no singular vectors desired, use qd algorithm -* - IF( .NOT.ROTATE ) THEN - CALL DLASQ1( N, D, E, WORK, INFO ) -* -* If INFO equals 2, dqds didn't finish, try to finish -* - IF( INFO .NE. 2 ) RETURN - INFO = 0 - END IF -* - NM1 = N - 1 - NM12 = NM1 + NM1 - NM13 = NM12 + NM1 - IDIR = 0 -* -* Get machine constants -* - EPS = DLAMCH( 'Epsilon' ) - UNFL = DLAMCH( 'Safe minimum' ) -* -* If matrix lower bidiagonal, rotate to be upper bidiagonal -* by applying Givens rotations on the left -* - IF( LOWER ) THEN - DO 10 I = 1, N - 1 - CALL DLARTG( D( I ), E( I ), CS, SN, R ) - D( I ) = R - E( I ) = SN*D( I+1 ) - D( I+1 ) = CS*D( I+1 ) - WORK( I ) = CS - WORK( NM1+I ) = SN - 10 CONTINUE -* -* Update singular vectors if desired -* - IF( NRU.GT.0 ) - $ CALL DLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ), WORK( N ), U, - $ LDU ) - IF( NCC.GT.0 ) - $ CALL DLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ), WORK( N ), C, - $ LDC ) - END IF -* -* Compute singular values to relative accuracy TOL -* (By setting TOL to be negative, algorithm will compute -* singular values to absolute accuracy ABS(TOL)*norm(input matrix)) -* - TOLMUL = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) ) - TOL = TOLMUL*EPS -* -* Compute approximate maximum, minimum singular values -* - SMAX = ZERO - DO 20 I = 1, N - SMAX = MAX( SMAX, ABS( D( I ) ) ) - 20 CONTINUE - DO 30 I = 1, N - 1 - SMAX = MAX( SMAX, ABS( E( I ) ) ) - 30 CONTINUE - SMINL = ZERO - IF( TOL.GE.ZERO ) THEN -* -* Relative accuracy desired -* - SMINOA = ABS( D( 1 ) ) - IF( SMINOA.EQ.ZERO ) - $ GO TO 50 - MU = SMINOA - DO 40 I = 2, N - MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) ) - SMINOA = MIN( SMINOA, MU ) - IF( SMINOA.EQ.ZERO ) - $ GO TO 50 - 40 CONTINUE - 50 CONTINUE - SMINOA = SMINOA / SQRT( DBLE( N ) ) - THRESH = MAX( TOL*SMINOA, MAXITR*(N*(N*UNFL)) ) - ELSE -* -* Absolute accuracy desired -* - THRESH = MAX( ABS( TOL )*SMAX, MAXITR*(N*(N*UNFL)) ) - END IF -* -* Prepare for main iteration loop for the singular values -* (MAXIT is the maximum number of passes through the inner -* loop permitted before nonconvergence signalled.) -* - MAXITDIVN = MAXITR*N - ITERDIVN = 0 - ITER = -1 - OLDLL = -1 - OLDM = -1 -* -* M points to last element of unconverged part of matrix -* - M = N -* -* Begin main iteration loop -* - 60 CONTINUE -* -* Check for convergence or exceeding iteration count -* - IF( M.LE.1 ) - $ GO TO 160 -* - IF( ITER.GE.N ) THEN - ITER = ITER - N - ITERDIVN = ITERDIVN + 1 - IF( ITERDIVN.GE.MAXITDIVN ) - $ GO TO 200 - END IF -* -* Find diagonal block of matrix to work on -* - IF( TOL.LT.ZERO .AND. ABS( D( M ) ).LE.THRESH ) - $ D( M ) = ZERO - SMAX = ABS( D( M ) ) - SMIN = SMAX - DO 70 LLL = 1, M - 1 - LL = M - LLL - ABSS = ABS( D( LL ) ) - ABSE = ABS( E( LL ) ) - IF( TOL.LT.ZERO .AND. ABSS.LE.THRESH ) - $ D( LL ) = ZERO - IF( ABSE.LE.THRESH ) - $ GO TO 80 - SMIN = MIN( SMIN, ABSS ) - SMAX = MAX( SMAX, ABSS, ABSE ) - 70 CONTINUE - LL = 0 - GO TO 90 - 80 CONTINUE - E( LL ) = ZERO -* -* Matrix splits since E(LL) = 0 -* - IF( LL.EQ.M-1 ) THEN -* -* Convergence of bottom singular value, return to top of loop -* - M = M - 1 - GO TO 60 - END IF - 90 CONTINUE - LL = LL + 1 -* -* E(LL) through E(M-1) are nonzero, E(LL-1) is zero -* - IF( LL.EQ.M-1 ) THEN -* -* 2 by 2 block, handle separately -* - CALL DLASV2( D( M-1 ), E( M-1 ), D( M ), SIGMN, SIGMX, SINR, - $ COSR, SINL, COSL ) - D( M-1 ) = SIGMX - E( M-1 ) = ZERO - D( M ) = SIGMN -* -* Compute singular vectors, if desired -* - IF( NCVT.GT.0 ) - $ CALL DROT( NCVT, VT( M-1, 1 ), LDVT, VT( M, 1 ), LDVT, COSR, - $ SINR ) - IF( NRU.GT.0 ) - $ CALL DROT( NRU, U( 1, M-1 ), 1, U( 1, M ), 1, COSL, SINL ) - IF( NCC.GT.0 ) - $ CALL DROT( NCC, C( M-1, 1 ), LDC, C( M, 1 ), LDC, COSL, - $ SINL ) - M = M - 2 - GO TO 60 - END IF -* -* If working on new submatrix, choose shift direction -* (from larger end diagonal element towards smaller) -* - IF( LL.GT.OLDM .OR. M.LT.OLDLL ) THEN - IF( ABS( D( LL ) ).GE.ABS( D( M ) ) ) THEN -* -* Chase bulge from top (big end) to bottom (small end) -* - IDIR = 1 - ELSE -* -* Chase bulge from bottom (big end) to top (small end) -* - IDIR = 2 - END IF - END IF -* -* Apply convergence tests -* - IF( IDIR.EQ.1 ) THEN -* -* Run convergence test in forward direction -* First apply standard test to bottom of matrix -* - IF( ABS( E( M-1 ) ).LE.ABS( TOL )*ABS( D( M ) ) .OR. - $ ( TOL.LT.ZERO .AND. ABS( E( M-1 ) ).LE.THRESH ) ) THEN - E( M-1 ) = ZERO - GO TO 60 - END IF -* - IF( TOL.GE.ZERO ) THEN -* -* If relative accuracy desired, -* apply convergence criterion forward -* - MU = ABS( D( LL ) ) - SMINL = MU - DO 100 LLL = LL, M - 1 - IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN - E( LLL ) = ZERO - GO TO 60 - END IF - MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) - SMINL = MIN( SMINL, MU ) - 100 CONTINUE - END IF -* - ELSE -* -* Run convergence test in backward direction -* First apply standard test to top of matrix -* - IF( ABS( E( LL ) ).LE.ABS( TOL )*ABS( D( LL ) ) .OR. - $ ( TOL.LT.ZERO .AND. ABS( E( LL ) ).LE.THRESH ) ) THEN - E( LL ) = ZERO - GO TO 60 - END IF -* - IF( TOL.GE.ZERO ) THEN -* -* If relative accuracy desired, -* apply convergence criterion backward -* - MU = ABS( D( M ) ) - SMINL = MU - DO 110 LLL = M - 1, LL, -1 - IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN - E( LLL ) = ZERO - GO TO 60 - END IF - MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) - SMINL = MIN( SMINL, MU ) - 110 CONTINUE - END IF - END IF - OLDLL = LL - OLDM = M -* -* Compute shift. First, test if shifting would ruin relative -* accuracy, and if so set the shift to zero. -* - IF( TOL.GE.ZERO .AND. N*TOL*( SMINL / SMAX ).LE. - $ MAX( EPS, HNDRTH*TOL ) ) THEN -* -* Use a zero shift to avoid loss of relative accuracy -* - SHIFT = ZERO - ELSE -* -* Compute the shift from 2-by-2 block at end of matrix -* - IF( IDIR.EQ.1 ) THEN - SLL = ABS( D( LL ) ) - CALL DLAS2( D( M-1 ), E( M-1 ), D( M ), SHIFT, R ) - ELSE - SLL = ABS( D( M ) ) - CALL DLAS2( D( LL ), E( LL ), D( LL+1 ), SHIFT, R ) - END IF -* -* Test if shift negligible, and if so set to zero -* - IF( SLL.GT.ZERO ) THEN - IF( ( SHIFT / SLL )**2.LT.EPS ) - $ SHIFT = ZERO - END IF - END IF -* -* Increment iteration count -* - ITER = ITER + M - LL -* -* If SHIFT = 0, do simplified QR iteration -* - IF( SHIFT.EQ.ZERO ) THEN - IF( IDIR.EQ.1 ) THEN -* -* Chase bulge from top to bottom -* Save cosines and sines for later singular vector updates -* - CS = ONE - OLDCS = ONE - DO 120 I = LL, M - 1 - CALL DLARTG( D( I )*CS, E( I ), CS, SN, R ) - IF( I.GT.LL ) - $ E( I-1 ) = OLDSN*R - CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) ) - WORK( I-LL+1 ) = CS - WORK( I-LL+1+NM1 ) = SN - WORK( I-LL+1+NM12 ) = OLDCS - WORK( I-LL+1+NM13 ) = OLDSN - 120 CONTINUE - H = D( M )*CS - D( M ) = H*OLDCS - E( M-1 ) = H*OLDSN -* -* Update singular vectors -* - IF( NCVT.GT.0 ) - $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ), - $ WORK( N ), VT( LL, 1 ), LDVT ) - IF( NRU.GT.0 ) - $ CALL DLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ), - $ WORK( NM13+1 ), U( 1, LL ), LDU ) - IF( NCC.GT.0 ) - $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ), - $ WORK( NM13+1 ), C( LL, 1 ), LDC ) -* -* Test convergence -* - IF( ABS( E( M-1 ) ).LE.THRESH ) - $ E( M-1 ) = ZERO -* - ELSE -* -* Chase bulge from bottom to top -* Save cosines and sines for later singular vector updates -* - CS = ONE - OLDCS = ONE - DO 130 I = M, LL + 1, -1 - CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R ) - IF( I.LT.M ) - $ E( I ) = OLDSN*R - CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) ) - WORK( I-LL ) = CS - WORK( I-LL+NM1 ) = -SN - WORK( I-LL+NM12 ) = OLDCS - WORK( I-LL+NM13 ) = -OLDSN - 130 CONTINUE - H = D( LL )*CS - D( LL ) = H*OLDCS - E( LL ) = H*OLDSN -* -* Update singular vectors -* - IF( NCVT.GT.0 ) - $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ), - $ WORK( NM13+1 ), VT( LL, 1 ), LDVT ) - IF( NRU.GT.0 ) - $ CALL DLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ), - $ WORK( N ), U( 1, LL ), LDU ) - IF( NCC.GT.0 ) - $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ), - $ WORK( N ), C( LL, 1 ), LDC ) -* -* Test convergence -* - IF( ABS( E( LL ) ).LE.THRESH ) - $ E( LL ) = ZERO - END IF - ELSE -* -* Use nonzero shift -* - IF( IDIR.EQ.1 ) THEN -* -* Chase bulge from top to bottom -* Save cosines and sines for later singular vector updates -* - F = ( ABS( D( LL ) )-SHIFT )* - $ ( SIGN( ONE, D( LL ) )+SHIFT / D( LL ) ) - G = E( LL ) - DO 140 I = LL, M - 1 - CALL DLARTG( F, G, COSR, SINR, R ) - IF( I.GT.LL ) - $ E( I-1 ) = R - F = COSR*D( I ) + SINR*E( I ) - E( I ) = COSR*E( I ) - SINR*D( I ) - G = SINR*D( I+1 ) - D( I+1 ) = COSR*D( I+1 ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( I ) = R - F = COSL*E( I ) + SINL*D( I+1 ) - D( I+1 ) = COSL*D( I+1 ) - SINL*E( I ) - IF( I.LT.M-1 ) THEN - G = SINL*E( I+1 ) - E( I+1 ) = COSL*E( I+1 ) - END IF - WORK( I-LL+1 ) = COSR - WORK( I-LL+1+NM1 ) = SINR - WORK( I-LL+1+NM12 ) = COSL - WORK( I-LL+1+NM13 ) = SINL - 140 CONTINUE - E( M-1 ) = F -* -* Update singular vectors -* - IF( NCVT.GT.0 ) - $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ), - $ WORK( N ), VT( LL, 1 ), LDVT ) - IF( NRU.GT.0 ) - $ CALL DLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ), - $ WORK( NM13+1 ), U( 1, LL ), LDU ) - IF( NCC.GT.0 ) - $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ), - $ WORK( NM13+1 ), C( LL, 1 ), LDC ) -* -* Test convergence -* - IF( ABS( E( M-1 ) ).LE.THRESH ) - $ E( M-1 ) = ZERO -* - ELSE -* -* Chase bulge from bottom to top -* Save cosines and sines for later singular vector updates -* - F = ( ABS( D( M ) )-SHIFT )*( SIGN( ONE, D( M ) )+SHIFT / - $ D( M ) ) - G = E( M-1 ) - DO 150 I = M, LL + 1, -1 - CALL DLARTG( F, G, COSR, SINR, R ) - IF( I.LT.M ) - $ E( I ) = R - F = COSR*D( I ) + SINR*E( I-1 ) - E( I-1 ) = COSR*E( I-1 ) - SINR*D( I ) - G = SINR*D( I-1 ) - D( I-1 ) = COSR*D( I-1 ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( I ) = R - F = COSL*E( I-1 ) + SINL*D( I-1 ) - D( I-1 ) = COSL*D( I-1 ) - SINL*E( I-1 ) - IF( I.GT.LL+1 ) THEN - G = SINL*E( I-2 ) - E( I-2 ) = COSL*E( I-2 ) - END IF - WORK( I-LL ) = COSR - WORK( I-LL+NM1 ) = -SINR - WORK( I-LL+NM12 ) = COSL - WORK( I-LL+NM13 ) = -SINL - 150 CONTINUE - E( LL ) = F -* -* Test convergence -* - IF( ABS( E( LL ) ).LE.THRESH ) - $ E( LL ) = ZERO -* -* Update singular vectors if desired -* - IF( NCVT.GT.0 ) - $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ), - $ WORK( NM13+1 ), VT( LL, 1 ), LDVT ) - IF( NRU.GT.0 ) - $ CALL DLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ), - $ WORK( N ), U( 1, LL ), LDU ) - IF( NCC.GT.0 ) - $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ), - $ WORK( N ), C( LL, 1 ), LDC ) - END IF - END IF -* -* QR iteration finished, go back and check convergence -* - GO TO 60 -* -* All singular values converged, so make them positive -* - 160 CONTINUE - DO 170 I = 1, N - IF( D( I ).LT.ZERO ) THEN - D( I ) = -D( I ) -* -* Change sign of singular vectors, if desired -* - IF( NCVT.GT.0 ) - $ CALL DSCAL( NCVT, NEGONE, VT( I, 1 ), LDVT ) - END IF - 170 CONTINUE -* -* Sort the singular values into decreasing order (insertion sort on -* singular values, but only one transposition per singular vector) -* - DO 190 I = 1, N - 1 -* -* Scan for smallest D(I) -* - ISUB = 1 - SMIN = D( 1 ) - DO 180 J = 2, N + 1 - I - IF( D( J ).LE.SMIN ) THEN - ISUB = J - SMIN = D( J ) - END IF - 180 CONTINUE - IF( ISUB.NE.N+1-I ) THEN -* -* Swap singular values and vectors -* - D( ISUB ) = D( N+1-I ) - D( N+1-I ) = SMIN - IF( NCVT.GT.0 ) - $ CALL DSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( N+1-I, 1 ), - $ LDVT ) - IF( NRU.GT.0 ) - $ CALL DSWAP( NRU, U( 1, ISUB ), 1, U( 1, N+1-I ), 1 ) - IF( NCC.GT.0 ) - $ CALL DSWAP( NCC, C( ISUB, 1 ), LDC, C( N+1-I, 1 ), LDC ) - END IF - 190 CONTINUE - GO TO 220 -* -* Maximum number of iterations exceeded, failure to converge -* - 200 CONTINUE - INFO = 0 - DO 210 I = 1, N - 1 - IF( E( I ).NE.ZERO ) - $ INFO = INFO + 1 - 210 CONTINUE - 220 CONTINUE - RETURN -* -* End of DBDSQR -* - END diff --git a/lib/linalg/dcabs1.cpp b/lib/linalg/dcabs1.cpp new file mode 100644 index 0000000000..83332f3177 --- /dev/null +++ b/lib/linalg/dcabs1.cpp @@ -0,0 +1,14 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +doublereal dcabs1_(doublecomplex *z__) +{ + doublereal ret_val, d__1, d__2; + double d_lmp_imag(doublecomplex *); + ret_val = (d__1 = z__->r, abs(d__1)) + (d__2 = d_lmp_imag(z__), abs(d__2)); + return ret_val; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dcabs1.f b/lib/linalg/dcabs1.f deleted file mode 100644 index f6212a8595..0000000000 --- a/lib/linalg/dcabs1.f +++ /dev/null @@ -1,66 +0,0 @@ -*> \brief \b DCABS1 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* DOUBLE PRECISION FUNCTION DCABS1(Z) -* -* .. Scalar Arguments .. -* COMPLEX*16 Z -* .. -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DCABS1 computes |Re(.)| + |Im(.)| of a double complex number -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] Z -*> \verbatim -*> Z is COMPLEX*16 -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level1 -* -* ===================================================================== - DOUBLE PRECISION FUNCTION DCABS1(Z) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - COMPLEX*16 Z -* .. -* .. -* ===================================================================== -* -* .. Intrinsic Functions .. - INTRINSIC ABS,DBLE,DIMAG -* - DCABS1 = ABS(DBLE(Z)) + ABS(DIMAG(Z)) - RETURN -* -* End of DCABS1 -* - END diff --git a/lib/linalg/dcopy.cpp b/lib/linalg/dcopy.cpp new file mode 100644 index 0000000000..1a7d65fc23 --- /dev/null +++ b/lib/linalg/dcopy.cpp @@ -0,0 +1,56 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dcopy_(integer *n, doublereal *dx, integer *incx, doublereal *dy, integer *incy) +{ + integer i__1; + integer i__, m, ix, iy, mp1; + --dy; + --dx; + if (*n <= 0) { + return 0; + } + if (*incx == 1 && *incy == 1) { + m = *n % 7; + if (m != 0) { + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + dy[i__] = dx[i__]; + } + if (*n < 7) { + return 0; + } + } + mp1 = m + 1; + i__1 = *n; + for (i__ = mp1; i__ <= i__1; i__ += 7) { + dy[i__] = dx[i__]; + dy[i__ + 1] = dx[i__ + 1]; + dy[i__ + 2] = dx[i__ + 2]; + dy[i__ + 3] = dx[i__ + 3]; + dy[i__ + 4] = dx[i__ + 4]; + dy[i__ + 5] = dx[i__ + 5]; + dy[i__ + 6] = dx[i__ + 6]; + } + } 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__) { + dy[iy] = dx[ix]; + ix += *incx; + iy += *incy; + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dcopy.f b/lib/linalg/dcopy.f deleted file mode 100644 index ded46c5ecf..0000000000 --- a/lib/linalg/dcopy.f +++ /dev/null @@ -1,146 +0,0 @@ -*> \brief \b DCOPY -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) -* -* .. Scalar Arguments .. -* INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION DX(*),DY(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DCOPY copies a vector, x, to a vector, y. -*> uses unrolled loops for increments equal to 1. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> number of elements in input vector(s) -*> \endverbatim -*> -*> \param[in] DX -*> \verbatim -*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> storage spacing between elements of DX -*> \endverbatim -*> -*> \param[out] DY -*> \verbatim -*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> storage spacing between elements of DY -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level1 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> jack dongarra, linpack, 3/11/78. -*> modified 12/3/93, array(1) declarations changed to array(*) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*),DY(*) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I,IX,IY,M,MP1 -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - IF (N.LE.0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 -* -* -* clean-up loop -* - M = MOD(N,7) - IF (M.NE.0) THEN - DO I = 1,M - DY(I) = DX(I) - END DO - IF (N.LT.7) RETURN - END IF - MP1 = M + 1 - DO I = MP1,N,7 - DY(I) = DX(I) - DY(I+1) = DX(I+1) - DY(I+2) = DX(I+2) - DY(I+3) = DX(I+3) - DY(I+4) = DX(I+4) - DY(I+5) = DX(I+5) - DY(I+6) = DX(I+6) - END DO - ELSE -* -* code for unequal increments or equal increments -* not equal to 1 -* - IX = 1 - IY = 1 - IF (INCX.LT.0) IX = (-N+1)*INCX + 1 - IF (INCY.LT.0) IY = (-N+1)*INCY + 1 - DO I = 1,N - DY(IY) = DX(IX) - IX = IX + INCX - IY = IY + INCY - END DO - END IF - RETURN -* -* End of DCOPY -* - END diff --git a/lib/linalg/ddot.cpp b/lib/linalg/ddot.cpp new file mode 100644 index 0000000000..58a7075238 --- /dev/null +++ b/lib/linalg/ddot.cpp @@ -0,0 +1,58 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +doublereal ddot_(integer *n, doublereal *dx, integer *incx, doublereal *dy, integer *incy) +{ + integer i__1; + doublereal ret_val; + integer i__, m, ix, iy, mp1; + doublereal dtemp; + --dy; + --dx; + ret_val = 0.; + dtemp = 0.; + if (*n <= 0) { + return ret_val; + } + if (*incx == 1 && *incy == 1) { + m = *n % 5; + if (m != 0) { + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + dtemp += dx[i__] * dy[i__]; + } + if (*n < 5) { + ret_val = dtemp; + return ret_val; + } + } + mp1 = m + 1; + i__1 = *n; + for (i__ = mp1; i__ <= i__1; i__ += 5) { + dtemp = dtemp + dx[i__] * dy[i__] + dx[i__ + 1] * dy[i__ + 1] + + dx[i__ + 2] * dy[i__ + 2] + dx[i__ + 3] * dy[i__ + 3] + + dx[i__ + 4] * dy[i__ + 4]; + } + } 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__) { + dtemp += dx[ix] * dy[iy]; + ix += *incx; + iy += *incy; + } + } + ret_val = dtemp; + return ret_val; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/ddot.f b/lib/linalg/ddot.f deleted file mode 100644 index 683a04bd46..0000000000 --- a/lib/linalg/ddot.f +++ /dev/null @@ -1,148 +0,0 @@ -*> \brief \b DDOT -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) -* -* .. Scalar Arguments .. -* INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION DX(*),DY(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DDOT forms the dot product of two vectors. -*> uses unrolled loops for increments equal to one. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> number of elements in input vector(s) -*> \endverbatim -*> -*> \param[in] DX -*> \verbatim -*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> storage spacing between elements of DX -*> \endverbatim -*> -*> \param[in] DY -*> \verbatim -*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> storage spacing between elements of DY -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level1 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> jack dongarra, linpack, 3/11/78. -*> modified 12/3/93, array(1) declarations changed to array(*) -*> \endverbatim -*> -* ===================================================================== - DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*),DY(*) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - DOUBLE PRECISION DTEMP - INTEGER I,IX,IY,M,MP1 -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - DDOT = 0.0d0 - DTEMP = 0.0d0 - IF (N.LE.0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 -* -* -* clean-up loop -* - M = MOD(N,5) - IF (M.NE.0) THEN - DO I = 1,M - DTEMP = DTEMP + DX(I)*DY(I) - END DO - IF (N.LT.5) THEN - DDOT=DTEMP - RETURN - END IF - END IF - MP1 = M + 1 - DO I = MP1,N,5 - DTEMP = DTEMP + DX(I)*DY(I) + DX(I+1)*DY(I+1) + - $ DX(I+2)*DY(I+2) + DX(I+3)*DY(I+3) + DX(I+4)*DY(I+4) - END DO - ELSE -* -* code for unequal increments or equal increments -* not equal to 1 -* - IX = 1 - IY = 1 - IF (INCX.LT.0) IX = (-N+1)*INCX + 1 - IF (INCY.LT.0) IY = (-N+1)*INCY + 1 - DO I = 1,N - DTEMP = DTEMP + DX(IX)*DY(IY) - IX = IX + INCX - IY = IY + INCY - END DO - END IF - DDOT = DTEMP - RETURN -* -* End of DDOT -* - END diff --git a/lib/linalg/dgebd2.cpp b/lib/linalg/dgebd2.cpp new file mode 100644 index 0000000000..ea2ff1bce9 --- /dev/null +++ b/lib/linalg/dgebd2.cpp @@ -0,0 +1,105 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +int dgebd2_(integer *m, integer *n, doublereal *a, integer *lda, doublereal *d__, doublereal *e, + doublereal *tauq, doublereal *taup, doublereal *work, integer *info) +{ + integer a_dim1, a_offset, i__1, i__2, i__3; + integer i__; + 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; + --d__; + --e; + --tauq; + --taup; + --work; + *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 *)"DGEBD2", &i__1, (ftnlen)6); + return 0; + } + if (*m >= *n) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *m - i__ + 1; + i__3 = i__ + 1; + dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3, *m) + i__ * a_dim1], &c__1, + &tauq[i__]); + d__[i__] = a[i__ + i__ * a_dim1]; + a[i__ + i__ * a_dim1] = 1.; + if (i__ < *n) { + i__2 = *m - i__ + 1; + i__3 = *n - i__; + dlarf_((char *)"Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &tauq[i__], + &a[i__ + (i__ + 1) * a_dim1], lda, &work[1], (ftnlen)4); + } + a[i__ + i__ * a_dim1] = d__[i__]; + if (i__ < *n) { + i__2 = *n - i__; + i__3 = i__ + 2; + dlarfg_(&i__2, &a[i__ + (i__ + 1) * a_dim1], &a[i__ + min(i__3, *n) * a_dim1], lda, + &taup[i__]); + e[i__] = a[i__ + (i__ + 1) * a_dim1]; + a[i__ + (i__ + 1) * a_dim1] = 1.; + i__2 = *m - i__; + i__3 = *n - i__; + dlarf_((char *)"Right", &i__2, &i__3, &a[i__ + (i__ + 1) * a_dim1], lda, &taup[i__], + &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &work[1], (ftnlen)5); + a[i__ + (i__ + 1) * a_dim1] = e[i__]; + } else { + taup[i__] = 0.; + } + } + } else { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n - i__ + 1; + i__3 = i__ + 1; + dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3, *n) * a_dim1], lda, + &taup[i__]); + d__[i__] = a[i__ + i__ * a_dim1]; + a[i__ + i__ * a_dim1] = 1.; + if (i__ < *m) { + i__2 = *m - i__; + i__3 = *n - i__ + 1; + dlarf_((char *)"Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &taup[i__], + &a[i__ + 1 + i__ * a_dim1], lda, &work[1], (ftnlen)5); + } + a[i__ + i__ * a_dim1] = d__[i__]; + if (i__ < *m) { + i__2 = *m - i__; + i__3 = i__ + 2; + dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3, *m) + i__ * a_dim1], &c__1, + &tauq[i__]); + e[i__] = a[i__ + 1 + i__ * a_dim1]; + a[i__ + 1 + i__ * a_dim1] = 1.; + i__2 = *m - i__; + i__3 = *n - i__; + dlarf_((char *)"Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &c__1, &tauq[i__], + &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &work[1], (ftnlen)4); + a[i__ + 1 + i__ * a_dim1] = e[i__]; + } else { + tauq[i__] = 0.; + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dgebd2.f b/lib/linalg/dgebd2.f deleted file mode 100644 index daaa187aff..0000000000 --- a/lib/linalg/dgebd2.f +++ /dev/null @@ -1,317 +0,0 @@ -*> \brief \b DGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGEBD2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), -* $ TAUQ( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGEBD2 reduces a real general m by n matrix A to upper or lower -*> bidiagonal form B by an orthogonal transformation: Q**T * A * P = B. -*> -*> If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows in the matrix A. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns in the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the m by n general matrix to be reduced. -*> On exit, -*> if m >= n, the diagonal and the first superdiagonal are -*> overwritten with the upper bidiagonal matrix B; the -*> elements below the diagonal, with the array TAUQ, represent -*> the orthogonal matrix Q as a product of elementary -*> reflectors, and the elements above the first superdiagonal, -*> with the array TAUP, represent the orthogonal matrix P as -*> a product of elementary reflectors; -*> if m < n, the diagonal and the first subdiagonal are -*> overwritten with the lower bidiagonal matrix B; the -*> elements below the first subdiagonal, with the array TAUQ, -*> represent the orthogonal matrix Q as a product of -*> elementary reflectors, and the elements above the diagonal, -*> with the array TAUP, represent the orthogonal matrix P as -*> a product of elementary reflectors. -*> See Further Details. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (min(M,N)) -*> The diagonal elements of the bidiagonal matrix B: -*> D(i) = A(i,i). -*> \endverbatim -*> -*> \param[out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (min(M,N)-1) -*> The off-diagonal elements of the bidiagonal matrix B: -*> if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; -*> if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. -*> \endverbatim -*> -*> \param[out] TAUQ -*> \verbatim -*> TAUQ is DOUBLE PRECISION array, dimension (min(M,N)) -*> The scalar factors of the elementary reflectors which -*> represent the orthogonal matrix Q. See Further Details. -*> \endverbatim -*> -*> \param[out] TAUP -*> \verbatim -*> TAUP is DOUBLE PRECISION array, dimension (min(M,N)) -*> The scalar factors of the elementary reflectors which -*> represent the orthogonal matrix P. See Further Details. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (max(M,N)) -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit. -*> < 0: if INFO = -i, the i-th argument had an illegal value. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleGEcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The matrices Q and P are represented as products of elementary -*> reflectors: -*> -*> If m >= n, -*> -*> Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) -*> -*> Each H(i) and G(i) has the form: -*> -*> H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T -*> -*> where tauq and taup are real scalars, and v and u are real vectors; -*> v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); -*> u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); -*> tauq is stored in TAUQ(i) and taup in TAUP(i). -*> -*> If m < n, -*> -*> Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) -*> -*> Each H(i) and G(i) has the form: -*> -*> H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T -*> -*> where tauq and taup are real scalars, and v and u are real vectors; -*> v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); -*> u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); -*> tauq is stored in TAUQ(i) and taup in TAUP(i). -*> -*> The contents of A on exit are illustrated by the following examples: -*> -*> m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): -*> -*> ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) -*> ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) -*> ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) -*> ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) -*> ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) -*> ( v1 v2 v3 v4 v5 ) -*> -*> where d and e denote diagonal and off-diagonal elements of B, vi -*> denotes an element of the vector defining H(i), and ui an element of -*> the vector defining G(i). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), - $ TAUQ( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DLARFG, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.LT.0 ) THEN - CALL XERBLA( 'DGEBD2', -INFO ) - RETURN - END IF -* - IF( M.GE.N ) THEN -* -* Reduce to upper bidiagonal form -* - DO 10 I = 1, N -* -* Generate elementary reflector H(i) to annihilate A(i+1:m,i) -* - CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, - $ TAUQ( I ) ) - D( I ) = A( I, I ) - A( I, I ) = ONE -* -* Apply H(i) to A(i:m,i+1:n) from the left -* - IF( I.LT.N ) - $ CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAUQ( I ), - $ A( I, I+1 ), LDA, WORK ) - A( I, I ) = D( I ) -* - IF( I.LT.N ) THEN -* -* Generate elementary reflector G(i) to annihilate -* A(i,i+2:n) -* - CALL DLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ), - $ LDA, TAUP( I ) ) - E( I ) = A( I, I+1 ) - A( I, I+1 ) = ONE -* -* Apply G(i) to A(i+1:m,i+1:n) from the right -* - CALL DLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA, - $ TAUP( I ), A( I+1, I+1 ), LDA, WORK ) - A( I, I+1 ) = E( I ) - ELSE - TAUP( I ) = ZERO - END IF - 10 CONTINUE - ELSE -* -* Reduce to lower bidiagonal form -* - DO 20 I = 1, M -* -* Generate elementary reflector G(i) to annihilate A(i,i+1:n) -* - CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, - $ TAUP( I ) ) - D( I ) = A( I, I ) - A( I, I ) = ONE -* -* Apply G(i) to A(i+1:m,i:n) from the right -* - IF( I.LT.M ) - $ CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, - $ TAUP( I ), A( I+1, I ), LDA, WORK ) - A( I, I ) = D( I ) -* - IF( I.LT.M ) THEN -* -* Generate elementary reflector H(i) to annihilate -* A(i+2:m,i) -* - CALL DLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1, - $ TAUQ( I ) ) - E( I ) = A( I+1, I ) - A( I+1, I ) = ONE -* -* Apply H(i) to A(i+1:m,i+1:n) from the left -* - CALL DLARF( 'Left', M-I, N-I, A( I+1, I ), 1, TAUQ( I ), - $ A( I+1, I+1 ), LDA, WORK ) - A( I+1, I ) = E( I ) - ELSE - TAUQ( I ) = ZERO - END IF - 20 CONTINUE - END IF - RETURN -* -* End of DGEBD2 -* - END diff --git a/lib/linalg/dgebrd.cpp b/lib/linalg/dgebrd.cpp new file mode 100644 index 0000000000..d62e506c41 --- /dev/null +++ b/lib/linalg/dgebrd.cpp @@ -0,0 +1,129 @@ +#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 doublereal c_b21 = -1.; +static doublereal c_b22 = 1.; +int dgebrd_(integer *m, integer *n, doublereal *a, integer *lda, doublereal *d__, doublereal *e, + doublereal *tauq, doublereal *taup, doublereal *work, integer *lwork, integer *info) +{ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + integer i__, j, nb, nx, ws; + extern int dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, + ftnlen, ftnlen); + integer nbmin, iinfo, minmn; + extern int dgebd2_(integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, integer *), + dlabrd_(integer *, integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, + integer *), + xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, + ftnlen, ftnlen); + integer ldwrkx, ldwrky, lwkopt; + logical lquery; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --d__; + --e; + --tauq; + --taup; + --work; + *info = 0; + i__1 = 1, i__2 = ilaenv_(&c__1, (char *)"DGEBRD", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); + nb = max(i__1, i__2); + lwkopt = (*m + *n) * nb; + work[1] = (doublereal)lwkopt; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < max(1, *m)) { + *info = -4; + } else { + i__1 = max(1, *m); + if (*lwork < max(i__1, *n) && !lquery) { + *info = -10; + } + } + if (*info < 0) { + i__1 = -(*info); + xerbla_((char *)"DGEBRD", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + minmn = min(*m, *n); + if (minmn == 0) { + work[1] = 1.; + return 0; + } + ws = max(*m, *n); + ldwrkx = *m; + ldwrky = *n; + if (nb > 1 && nb < minmn) { + i__1 = nb, i__2 = ilaenv_(&c__3, (char *)"DGEBRD", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); + nx = max(i__1, i__2); + if (nx < minmn) { + ws = (*m + *n) * nb; + if (*lwork < ws) { + nbmin = ilaenv_(&c__2, (char *)"DGEBRD", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); + if (*lwork >= (*m + *n) * nbmin) { + nb = *lwork / (*m + *n); + } else { + nb = 1; + nx = minmn; + } + } + } + } else { + nx = minmn; + } + i__1 = minmn - nx; + i__2 = nb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + i__3 = *m - i__ + 1; + i__4 = *n - i__ + 1; + dlabrd_(&i__3, &i__4, &nb, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], &tauq[i__], + &taup[i__], &work[1], &ldwrkx, &work[ldwrkx * nb + 1], &ldwrky); + i__3 = *m - i__ - nb + 1; + i__4 = *n - i__ - nb + 1; + dgemm_((char *)"No transpose", (char *)"Transpose", &i__3, &i__4, &nb, &c_b21, &a[i__ + nb + i__ * a_dim1], + lda, &work[ldwrkx * nb + nb + 1], &ldwrky, &c_b22, + &a[i__ + nb + (i__ + nb) * a_dim1], lda, (ftnlen)12, (ftnlen)9); + i__3 = *m - i__ - nb + 1; + i__4 = *n - i__ - nb + 1; + dgemm_((char *)"No transpose", (char *)"No transpose", &i__3, &i__4, &nb, &c_b21, &work[nb + 1], &ldwrkx, + &a[i__ + (i__ + nb) * a_dim1], lda, &c_b22, &a[i__ + nb + (i__ + nb) * a_dim1], lda, + (ftnlen)12, (ftnlen)12); + if (*m >= *n) { + i__3 = i__ + nb - 1; + for (j = i__; j <= i__3; ++j) { + a[j + j * a_dim1] = d__[j]; + a[j + (j + 1) * a_dim1] = e[j]; + } + } else { + i__3 = i__ + nb - 1; + for (j = i__; j <= i__3; ++j) { + a[j + j * a_dim1] = d__[j]; + a[j + 1 + j * a_dim1] = e[j]; + } + } + } + i__2 = *m - i__ + 1; + i__1 = *n - i__ + 1; + dgebd2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], &tauq[i__], &taup[i__], + &work[1], &iinfo); + work[1] = (doublereal)ws; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dgebrd.f b/lib/linalg/dgebrd.f deleted file mode 100644 index 0f0d1651a7..0000000000 --- a/lib/linalg/dgebrd.f +++ /dev/null @@ -1,349 +0,0 @@ -*> \brief \b DGEBRD -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGEBRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, -* INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, LDA, LWORK, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), -* $ TAUQ( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGEBRD reduces a general real M-by-N matrix A to upper or lower -*> bidiagonal form B by an orthogonal transformation: Q**T * A * P = B. -*> -*> If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows in the matrix A. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns in the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the M-by-N general matrix to be reduced. -*> On exit, -*> if m >= n, the diagonal and the first superdiagonal are -*> overwritten with the upper bidiagonal matrix B; the -*> elements below the diagonal, with the array TAUQ, represent -*> the orthogonal matrix Q as a product of elementary -*> reflectors, and the elements above the first superdiagonal, -*> with the array TAUP, represent the orthogonal matrix P as -*> a product of elementary reflectors; -*> if m < n, the diagonal and the first subdiagonal are -*> overwritten with the lower bidiagonal matrix B; the -*> elements below the first subdiagonal, with the array TAUQ, -*> represent the orthogonal matrix Q as a product of -*> elementary reflectors, and the elements above the diagonal, -*> with the array TAUP, represent the orthogonal matrix P as -*> a product of elementary reflectors. -*> See Further Details. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (min(M,N)) -*> The diagonal elements of the bidiagonal matrix B: -*> D(i) = A(i,i). -*> \endverbatim -*> -*> \param[out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (min(M,N)-1) -*> The off-diagonal elements of the bidiagonal matrix B: -*> if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; -*> if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. -*> \endverbatim -*> -*> \param[out] TAUQ -*> \verbatim -*> TAUQ is DOUBLE PRECISION array, dimension (min(M,N)) -*> The scalar factors of the elementary reflectors which -*> represent the orthogonal matrix Q. See Further Details. -*> \endverbatim -*> -*> \param[out] TAUP -*> \verbatim -*> TAUP is DOUBLE PRECISION array, dimension (min(M,N)) -*> The scalar factors of the elementary reflectors which -*> represent the orthogonal matrix P. See Further Details. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The length of the array WORK. LWORK >= max(1,M,N). -*> For optimum performance LWORK >= (M+N)*NB, where NB -*> is the optimal blocksize. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal size of the WORK array, returns -*> this value as the first entry of the WORK array, and no error -*> message related to LWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleGEcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The matrices Q and P are represented as products of elementary -*> reflectors: -*> -*> If m >= n, -*> -*> Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) -*> -*> Each H(i) and G(i) has the form: -*> -*> H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T -*> -*> where tauq and taup are real scalars, and v and u are real vectors; -*> v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); -*> u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); -*> tauq is stored in TAUQ(i) and taup in TAUP(i). -*> -*> If m < n, -*> -*> Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) -*> -*> Each H(i) and G(i) has the form: -*> -*> H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T -*> -*> where tauq and taup are real scalars, and v and u are real vectors; -*> v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); -*> u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); -*> tauq is stored in TAUQ(i) and taup in TAUP(i). -*> -*> The contents of A on exit are illustrated by the following examples: -*> -*> m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): -*> -*> ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) -*> ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) -*> ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) -*> ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) -*> ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) -*> ( v1 v2 v3 v4 v5 ) -*> -*> where d and e denote diagonal and off-diagonal elements of B, vi -*> denotes an element of the vector defining H(i), and ui an element of -*> the vector defining G(i). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, - $ INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), - $ TAUQ( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB, - $ NBMIN, NX, WS -* .. -* .. External Subroutines .. - EXTERNAL DGEBD2, DGEMM, DLABRD, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - NB = MAX( 1, ILAENV( 1, 'DGEBRD', ' ', M, N, -1, -1 ) ) - LWKOPT = ( M+N )*NB - WORK( 1 ) = DBLE( LWKOPT ) - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - ELSE IF( LWORK.LT.MAX( 1, M, N ) .AND. .NOT.LQUERY ) THEN - INFO = -10 - END IF - IF( INFO.LT.0 ) THEN - CALL XERBLA( 'DGEBRD', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - MINMN = MIN( M, N ) - IF( MINMN.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - WS = MAX( M, N ) - LDWRKX = M - LDWRKY = N -* - IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN -* -* Set the crossover point NX. -* - NX = MAX( NB, ILAENV( 3, 'DGEBRD', ' ', M, N, -1, -1 ) ) -* -* Determine when to switch from blocked to unblocked code. -* - IF( NX.LT.MINMN ) THEN - WS = ( M+N )*NB - IF( LWORK.LT.WS ) THEN -* -* Not enough work space for the optimal NB, consider using -* a smaller block size. -* - NBMIN = ILAENV( 2, 'DGEBRD', ' ', M, N, -1, -1 ) - IF( LWORK.GE.( M+N )*NBMIN ) THEN - NB = LWORK / ( M+N ) - ELSE - NB = 1 - NX = MINMN - END IF - END IF - END IF - ELSE - NX = MINMN - END IF -* - DO 30 I = 1, MINMN - NX, NB -* -* Reduce rows and columns i:i+nb-1 to bidiagonal form and return -* the matrices X and Y which are needed to update the unreduced -* part of the matrix -* - CALL DLABRD( M-I+1, N-I+1, NB, A( I, I ), LDA, D( I ), E( I ), - $ TAUQ( I ), TAUP( I ), WORK, LDWRKX, - $ WORK( LDWRKX*NB+1 ), LDWRKY ) -* -* Update the trailing submatrix A(i+nb:m,i+nb:n), using an update -* of the form A := A - V*Y**T - X*U**T -* - CALL DGEMM( 'No transpose', 'Transpose', M-I-NB+1, N-I-NB+1, - $ NB, -ONE, A( I+NB, I ), LDA, - $ WORK( LDWRKX*NB+NB+1 ), LDWRKY, ONE, - $ A( I+NB, I+NB ), LDA ) - CALL DGEMM( 'No transpose', 'No transpose', M-I-NB+1, N-I-NB+1, - $ NB, -ONE, WORK( NB+1 ), LDWRKX, A( I, I+NB ), LDA, - $ ONE, A( I+NB, I+NB ), LDA ) -* -* Copy diagonal and off-diagonal elements of B back into A -* - IF( M.GE.N ) THEN - DO 10 J = I, I + NB - 1 - A( J, J ) = D( J ) - A( J, J+1 ) = E( J ) - 10 CONTINUE - ELSE - DO 20 J = I, I + NB - 1 - A( J, J ) = D( J ) - A( J+1, J ) = E( J ) - 20 CONTINUE - END IF - 30 CONTINUE -* -* Use unblocked code to reduce the remainder of the matrix -* - CALL DGEBD2( M-I+1, N-I+1, A( I, I ), LDA, D( I ), E( I ), - $ TAUQ( I ), TAUP( I ), WORK, IINFO ) - WORK( 1 ) = WS - RETURN -* -* End of DGEBRD -* - END diff --git a/lib/linalg/dgecon.cpp b/lib/linalg/dgecon.cpp new file mode 100644 index 0000000000..01604f5f5d --- /dev/null +++ b/lib/linalg/dgecon.cpp @@ -0,0 +1,101 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +int dgecon_(char *norm, integer *n, doublereal *a, integer *lda, doublereal *anorm, + doublereal *rcond, doublereal *work, integer *iwork, integer *info, ftnlen norm_len) +{ + integer a_dim1, a_offset, i__1; + doublereal d__1; + doublereal sl; + integer ix; + doublereal su; + integer kase, kase1; + doublereal scale; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + integer isave[3]; + extern int drscl_(integer *, doublereal *, doublereal *, integer *), + dlacn2_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, + integer *); + extern doublereal dlamch_(char *, ftnlen); + extern integer idamax_(integer *, doublereal *, integer *); + extern int xerbla_(char *, integer *, ftnlen); + doublereal ainvnm; + extern int dlatrs_(char *, char *, char *, char *, integer *, doublereal *, integer *, + doublereal *, doublereal *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, + ftnlen); + logical onenrm; + char normin[1]; + doublereal smlnum; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --work; + --iwork; + *info = 0; + onenrm = *(unsigned char *)norm == '1' || lsame_(norm, (char *)"O", (ftnlen)1, (ftnlen)1); + if (!onenrm && !lsame_(norm, (char *)"I", (ftnlen)1, (ftnlen)1)) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < max(1, *n)) { + *info = -4; + } else if (*anorm < 0.) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DGECON", &i__1, (ftnlen)6); + return 0; + } + *rcond = 0.; + if (*n == 0) { + *rcond = 1.; + return 0; + } else if (*anorm == 0.) { + return 0; + } + smlnum = dlamch_((char *)"Safe minimum", (ftnlen)12); + ainvnm = 0.; + *(unsigned char *)normin = 'N'; + if (onenrm) { + kase1 = 1; + } else { + kase1 = 2; + } + kase = 0; +L10: + dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == kase1) { + dlatrs_((char *)"Lower", (char *)"No transpose", (char *)"Unit", normin, n, &a[a_offset], lda, &work[1], &sl, + &work[(*n << 1) + 1], info, (ftnlen)5, (ftnlen)12, (ftnlen)4, (ftnlen)1); + dlatrs_((char *)"Upper", (char *)"No transpose", (char *)"Non-unit", normin, n, &a[a_offset], lda, &work[1], + &su, &work[*n * 3 + 1], info, (ftnlen)5, (ftnlen)12, (ftnlen)8, (ftnlen)1); + } else { + dlatrs_((char *)"Upper", (char *)"Transpose", (char *)"Non-unit", normin, n, &a[a_offset], lda, &work[1], &su, + &work[*n * 3 + 1], info, (ftnlen)5, (ftnlen)9, (ftnlen)8, (ftnlen)1); + dlatrs_((char *)"Lower", (char *)"Transpose", (char *)"Unit", normin, n, &a[a_offset], lda, &work[1], &sl, + &work[(*n << 1) + 1], info, (ftnlen)5, (ftnlen)9, (ftnlen)4, (ftnlen)1); + } + scale = sl * su; + *(unsigned char *)normin = 'Y'; + if (scale != 1.) { + ix = idamax_(n, &work[1], &c__1); + if (scale < (d__1 = work[ix], abs(d__1)) * smlnum || scale == 0.) { + goto L20; + } + drscl_(n, &scale, &work[1], &c__1); + } + goto L10; + } + if (ainvnm != 0.) { + *rcond = 1. / ainvnm / *anorm; + } +L20: + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dgecon.f b/lib/linalg/dgecon.f deleted file mode 100644 index aa10dee9a2..0000000000 --- a/lib/linalg/dgecon.f +++ /dev/null @@ -1,258 +0,0 @@ -*> \brief \b DGECON -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGECON + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, -* INFO ) -* -* .. Scalar Arguments .. -* CHARACTER NORM -* INTEGER INFO, LDA, N -* DOUBLE PRECISION ANORM, RCOND -* .. -* .. Array Arguments .. -* INTEGER IWORK( * ) -* DOUBLE PRECISION A( LDA, * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGECON estimates the reciprocal of the condition number of a general -*> real matrix A, in either the 1-norm or the infinity-norm, using -*> the LU factorization computed by DGETRF. -*> -*> An estimate is obtained for norm(inv(A)), and the reciprocal of the -*> condition number is computed as -*> RCOND = 1 / ( norm(A) * norm(inv(A)) ). -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] NORM -*> \verbatim -*> NORM is CHARACTER*1 -*> Specifies whether the 1-norm condition number or the -*> infinity-norm condition number is required: -*> = '1' or 'O': 1-norm; -*> = 'I': Infinity-norm. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> The factors L and U from the factorization A = P*L*U -*> as computed by DGETRF. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in] ANORM -*> \verbatim -*> ANORM is DOUBLE PRECISION -*> If NORM = '1' or 'O', the 1-norm of the original matrix A. -*> If NORM = 'I', the infinity-norm of the original matrix A. -*> \endverbatim -*> -*> \param[out] RCOND -*> \verbatim -*> RCOND is DOUBLE PRECISION -*> The reciprocal of the condition number of the matrix A, -*> computed as RCOND = 1/(norm(A) * norm(inv(A))). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (4*N) -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, dimension (N) -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleGEcomputational -* -* ===================================================================== - SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, - $ INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER NORM - INTEGER INFO, LDA, N - DOUBLE PRECISION ANORM, RCOND -* .. -* .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL ONENRM - CHARACTER NORMIN - INTEGER IX, KASE, KASE1 - DOUBLE PRECISION AINVNM, SCALE, SL, SMLNUM, SU -* .. -* .. Local Arrays .. - INTEGER ISAVE( 3 ) -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, IDAMAX, DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DLACN2, DLATRS, DRSCL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' ) - IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( ANORM.LT.ZERO ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGECON', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - RCOND = ZERO - IF( N.EQ.0 ) THEN - RCOND = ONE - RETURN - ELSE IF( ANORM.EQ.ZERO ) THEN - RETURN - END IF -* - SMLNUM = DLAMCH( 'Safe minimum' ) -* -* Estimate the norm of inv(A). -* - AINVNM = ZERO - NORMIN = 'N' - IF( ONENRM ) THEN - KASE1 = 1 - ELSE - KASE1 = 2 - END IF - KASE = 0 - 10 CONTINUE - CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) - IF( KASE.NE.0 ) THEN - IF( KASE.EQ.KASE1 ) THEN -* -* Multiply by inv(L). -* - CALL DLATRS( 'Lower', 'No transpose', 'Unit', NORMIN, N, A, - $ LDA, WORK, SL, WORK( 2*N+1 ), INFO ) -* -* Multiply by inv(U). -* - CALL DLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, - $ A, LDA, WORK, SU, WORK( 3*N+1 ), INFO ) - ELSE -* -* Multiply by inv(U**T). -* - CALL DLATRS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, A, - $ LDA, WORK, SU, WORK( 3*N+1 ), INFO ) -* -* Multiply by inv(L**T). -* - CALL DLATRS( 'Lower', 'Transpose', 'Unit', NORMIN, N, A, - $ LDA, WORK, SL, WORK( 2*N+1 ), INFO ) - END IF -* -* Divide X by 1/(SL*SU) if doing so will not cause overflow. -* - SCALE = SL*SU - NORMIN = 'Y' - IF( SCALE.NE.ONE ) THEN - IX = IDAMAX( N, WORK, 1 ) - IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO ) - $ GO TO 20 - CALL DRSCL( N, SCALE, WORK, 1 ) - END IF - GO TO 10 - END IF -* -* Compute the estimate of the reciprocal condition number. -* - IF( AINVNM.NE.ZERO ) - $ RCOND = ( ONE / AINVNM ) / ANORM -* - 20 CONTINUE - RETURN -* -* End of DGECON -* - END diff --git a/lib/linalg/dgelq2.cpp b/lib/linalg/dgelq2.cpp new file mode 100644 index 0000000000..dbb3e17a27 --- /dev/null +++ b/lib/linalg/dgelq2.cpp @@ -0,0 +1,53 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dgelq2_(integer *m, integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal *work, + integer *info) +{ + integer a_dim1, a_offset, i__1, i__2, i__3; + integer i__, k; + 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 (*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 *)"DGELQ2", &i__1, (ftnlen)6); + return 0; + } + k = min(*m, *n); + i__1 = k; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n - i__ + 1; + i__3 = i__ + 1; + dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3, *n) * a_dim1], lda, &tau[i__]); + if (i__ < *m) { + aii = a[i__ + i__ * a_dim1]; + a[i__ + i__ * a_dim1] = 1.; + i__2 = *m - i__; + i__3 = *n - i__ + 1; + dlarf_((char *)"Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[i__], + &a[i__ + 1 + i__ * a_dim1], lda, &work[1], (ftnlen)5); + a[i__ + i__ * a_dim1] = aii; + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dgelq2.f b/lib/linalg/dgelq2.f deleted file mode 100644 index 9915c57d47..0000000000 --- a/lib/linalg/dgelq2.f +++ /dev/null @@ -1,197 +0,0 @@ -*> \brief \b DGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGELQ2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGELQ2 computes an LQ factorization of a real m-by-n matrix A: -*> -*> A = ( L 0 ) * Q -*> -*> where: -*> -*> Q is a n-by-n orthogonal matrix; -*> L is a lower-triangular m-by-m matrix; -*> 0 is a m-by-(n-m) zero matrix, if m < n. -*> -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the m by n matrix A. -*> On exit, the elements on and below the diagonal of the array -*> contain the m by min(m,n) lower trapezoidal matrix L (L is -*> lower triangular if m <= n); the elements above the diagonal, -*> with the array TAU, represent the orthogonal matrix Q as a -*> product of elementary reflectors (see Further Details). -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[out] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) -*> The scalar factors of the elementary reflectors (see Further -*> Details). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (M) -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleGEcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The matrix Q is represented as a product of elementary reflectors -*> -*> Q = H(k) . . . H(2) H(1), where k = min(m,n). -*> -*> Each H(i) has the form -*> -*> H(i) = I - tau * v * v**T -*> -*> where tau is a real scalar, and v is a real vector with -*> v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), -*> and tau in TAU(i). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, K - DOUBLE PRECISION AII -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DLARFG, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGELQ2', -INFO ) - RETURN - END IF -* - K = MIN( M, N ) -* - DO 10 I = 1, K -* -* Generate elementary reflector H(i) to annihilate A(i,i+1:n) -* - CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, - $ TAU( I ) ) - IF( I.LT.M ) THEN -* -* Apply H(i) to A(i+1:m,i:n) from the right -* - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ), - $ A( I+1, I ), LDA, WORK ) - A( I, I ) = AII - END IF - 10 CONTINUE - RETURN -* -* End of DGELQ2 -* - END diff --git a/lib/linalg/dgelqf.cpp b/lib/linalg/dgelqf.cpp new file mode 100644 index 0000000000..0d48361669 --- /dev/null +++ b/lib/linalg/dgelqf.cpp @@ -0,0 +1,106 @@ +#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; +int dgelqf_(integer *m, integer *n, 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__, k, ib, nb, nx, iws, nbmin, iinfo; + extern int dgelq2_(integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *), + dlarfb_(char *, char *, char *, char *, integer *, integer *, integer *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, ftnlen, ftnlen, ftnlen, ftnlen), + dlarft_(char *, char *, integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *, 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; + nb = ilaenv_(&c__1, (char *)"DGELQF", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); + lwkopt = *m * nb; + work[1] = (doublereal)lwkopt; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < max(1, *m)) { + *info = -4; + } else if (*lwork < max(1, *m) && !lquery) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DGELQF", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + k = min(*m, *n); + if (k == 0) { + work[1] = 1.; + return 0; + } + nbmin = 2; + nx = 0; + iws = *m; + if (nb > 1 && nb < k) { + i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DGELQF", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); + nx = max(i__1, i__2); + if (nx < k) { + ldwork = *m; + iws = ldwork * nb; + if (*lwork < iws) { + nb = *lwork / ldwork; + i__1 = 2, + i__2 = ilaenv_(&c__2, (char *)"DGELQF", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); + nbmin = max(i__1, i__2); + } + } + } + if (nb >= nbmin && nb < k && nx < k) { + i__1 = k - nx; + i__2 = nb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + i__3 = k - i__ + 1; + ib = min(i__3, nb); + i__3 = *n - i__ + 1; + dgelq2_(&ib, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1], &iinfo); + if (i__ + ib <= *m) { + i__3 = *n - i__ + 1; + dlarft_((char *)"Forward", (char *)"Rowwise", &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], + &work[1], &ldwork, (ftnlen)7, (ftnlen)7); + i__3 = *m - i__ - ib + 1; + i__4 = *n - i__ + 1; + dlarfb_((char *)"Right", (char *)"No transpose", (char *)"Forward", (char *)"Rowwise", &i__3, &i__4, &ib, + &a[i__ + i__ * a_dim1], lda, &work[1], &ldwork, &a[i__ + ib + i__ * a_dim1], + lda, &work[ib + 1], &ldwork, (ftnlen)5, (ftnlen)12, (ftnlen)7, (ftnlen)7); + } + } + } else { + i__ = 1; + } + if (i__ <= k) { + i__2 = *m - i__ + 1; + i__1 = *n - i__ + 1; + dgelq2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1], &iinfo); + } + work[1] = (doublereal)iws; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dgelqf.f b/lib/linalg/dgelqf.f deleted file mode 100644 index ed3372f965..0000000000 --- a/lib/linalg/dgelqf.f +++ /dev/null @@ -1,274 +0,0 @@ -*> \brief \b DGELQF -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGELQF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, LDA, LWORK, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGELQF computes an LQ factorization of a real M-by-N matrix A: -*> -*> A = ( L 0 ) * Q -*> -*> where: -*> -*> Q is a N-by-N orthogonal matrix; -*> L is a lower-triangular M-by-M matrix; -*> 0 is a M-by-(N-M) zero matrix, if M < N. -*> -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the M-by-N matrix A. -*> On exit, the elements on and below the diagonal of the array -*> contain the m-by-min(m,n) lower trapezoidal matrix L (L is -*> lower triangular if m <= n); the elements above the diagonal, -*> with the array TAU, represent the orthogonal matrix Q as a -*> product of elementary reflectors (see Further Details). -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[out] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) -*> The scalar factors of the elementary reflectors (see Further -*> Details). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. LWORK >= max(1,M). -*> For optimum performance LWORK >= M*NB, where NB is the -*> optimal blocksize. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal size of the WORK array, returns -*> this value as the first entry of the WORK array, and no error -*> message related to LWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleGEcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The matrix Q is represented as a product of elementary reflectors -*> -*> Q = H(k) . . . H(2) H(1), where k = min(m,n). -*> -*> Each H(i) has the form -*> -*> H(i) = I - tau * v * v**T -*> -*> where tau is a real scalar, and v is a real vector with -*> v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), -*> and tau in TAU(i). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, - $ NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL DGELQ2, DLARFB, DLARFT, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - NB = ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) - LWKOPT = M*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGELQF', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - K = MIN( M, N ) - IF( K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - NX = 0 - IWS = M - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'DGELQF', ' ', M, N, -1, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = M - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', M, N, -1, - $ -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code initially -* - DO 10 I = 1, K - NX, NB - IB = MIN( K-I+1, NB ) -* -* Compute the LQ factorization of the current block -* A(i:i+ib-1,i:n) -* - CALL DGELQ2( IB, N-I+1, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) - IF( I+IB.LE.M ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ), - $ LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H to A(i+ib:m,i:n) from the right -* - CALL DLARFB( 'Right', 'No transpose', 'Forward', - $ 'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ), - $ LDA, WORK, LDWORK, A( I+IB, I ), LDA, - $ WORK( IB+1 ), LDWORK ) - END IF - 10 CONTINUE - ELSE - I = 1 - END IF -* -* Use unblocked code to factor the last or only block. -* - IF( I.LE.K ) - $ CALL DGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) -* - WORK( 1 ) = IWS - RETURN -* -* End of DGELQF -* - END diff --git a/lib/linalg/dgelsd.cpp b/lib/linalg/dgelsd.cpp new file mode 100644 index 0000000000..479d95dd61 --- /dev/null +++ b/lib/linalg/dgelsd.cpp @@ -0,0 +1,341 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__6 = 6; +static integer c_n1 = -1; +static integer c__9 = 9; +static integer c__0 = 0; +static integer c__1 = 1; +static doublereal c_b82 = 0.; +int dgelsd_(integer *m, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *b, + integer *ldb, doublereal *s, doublereal *rcond, integer *rank, doublereal *work, + integer *lwork, integer *iwork, integer *info) +{ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4; + double log(doublereal); + integer ie, il, mm; + doublereal eps, anrm, bnrm; + integer itau, nlvl, iascl, ibscl; + doublereal sfmin; + integer minmn, maxmn, itaup, itauq, mnthr, nwork; + extern int dlabad_(doublereal *, doublereal *), + 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); + extern int dgelqf_(integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, integer *), + dlalsd_(char *, integer *, integer *, integer *, doublereal *, doublereal *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, integer *, ftnlen), + 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); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, + ftnlen, ftnlen); + doublereal bignum; + extern int dormbr_(char *, char *, char *, integer *, integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, + integer *, ftnlen, ftnlen, ftnlen); + integer wlalsd; + extern int dormlq_(char *, char *, integer *, integer *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, integer *, + ftnlen, ftnlen); + integer ldwork; + extern int dormqr_(char *, char *, integer *, integer *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, integer *, + ftnlen, ftnlen); + integer liwork, minwrk, maxwrk; + doublereal smlnum; + logical lquery; + integer smlsiz; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + --s; + --work; + --iwork; + *info = 0; + minmn = min(*m, *n); + maxmn = max(*m, *n); + mnthr = ilaenv_(&c__6, (char *)"DGELSD", (char *)" ", m, n, nrhs, &c_n1, (ftnlen)6, (ftnlen)1); + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < max(1, *m)) { + *info = -5; + } else if (*ldb < max(1, maxmn)) { + *info = -7; + } + smlsiz = ilaenv_(&c__9, (char *)"DGELSD", (char *)" ", &c__0, &c__0, &c__0, &c__0, (ftnlen)6, (ftnlen)1); + minwrk = 1; + liwork = 1; + minmn = max(1, minmn); + i__1 = (integer)(log((doublereal)minmn / (doublereal)(smlsiz + 1)) / log(2.)) + 1; + nlvl = max(i__1, 0); + if (*info == 0) { + maxwrk = 0; + liwork = minmn * 3 * nlvl + minmn * 11; + mm = *m; + if (*m >= *n && *m >= mnthr) { + mm = *n; + i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, (char *)"DGEQRF", (char *)" ", m, n, &c_n1, &c_n1, + (ftnlen)6, (ftnlen)1); + maxwrk = max(i__1, i__2); + i__1 = maxwrk, i__2 = *n + *nrhs * ilaenv_(&c__1, (char *)"DORMQR", (char *)"LT", m, nrhs, n, &c_n1, + (ftnlen)6, (ftnlen)2); + maxwrk = max(i__1, i__2); + } + if (*m >= *n) { + i__1 = maxwrk, i__2 = *n * 3 + (mm + *n) * ilaenv_(&c__1, (char *)"DGEBRD", (char *)" ", &mm, n, &c_n1, + &c_n1, (ftnlen)6, (ftnlen)1); + maxwrk = max(i__1, i__2); + i__1 = maxwrk, i__2 = *n * 3 + *nrhs * ilaenv_(&c__1, (char *)"DORMBR", (char *)"QLT", &mm, nrhs, n, + &c_n1, (ftnlen)6, (ftnlen)3); + maxwrk = max(i__1, i__2); + i__1 = maxwrk, i__2 = *n * 3 + (*n - 1) * ilaenv_(&c__1, (char *)"DORMBR", (char *)"PLN", n, nrhs, n, + &c_n1, (ftnlen)6, (ftnlen)3); + maxwrk = max(i__1, i__2); + i__1 = smlsiz + 1; + wlalsd = *n * 9 + (*n << 1) * smlsiz + (*n << 3) * nlvl + *n * *nrhs + i__1 * i__1; + i__1 = maxwrk, i__2 = *n * 3 + wlalsd; + maxwrk = max(i__1, i__2); + i__1 = *n * 3 + mm, i__2 = *n * 3 + *nrhs, i__1 = max(i__1, i__2), + i__2 = *n * 3 + wlalsd; + minwrk = max(i__1, i__2); + } + if (*n > *m) { + i__1 = smlsiz + 1; + wlalsd = *m * 9 + (*m << 1) * smlsiz + (*m << 3) * nlvl + *m * *nrhs + i__1 * i__1; + if (*n >= mnthr) { + maxwrk = *m + *m * ilaenv_(&c__1, (char *)"DGELQF", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, + (ftnlen)1); + i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + + (*m << 1) * ilaenv_(&c__1, (char *)"DGEBRD", (char *)" ", m, m, &c_n1, &c_n1, + (ftnlen)6, (ftnlen)1); + maxwrk = max(i__1, i__2); + i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + + *nrhs * ilaenv_(&c__1, (char *)"DORMBR", (char *)"QLT", m, nrhs, m, &c_n1, + (ftnlen)6, (ftnlen)3); + maxwrk = max(i__1, i__2); + i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + + (*m - 1) * ilaenv_(&c__1, (char *)"DORMBR", (char *)"PLN", m, nrhs, m, &c_n1, + (ftnlen)6, (ftnlen)3); + maxwrk = max(i__1, i__2); + if (*nrhs > 1) { + i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs; + maxwrk = max(i__1, i__2); + } else { + i__1 = maxwrk, i__2 = *m * *m + (*m << 1); + maxwrk = max(i__1, i__2); + } + i__1 = maxwrk, i__2 = *m + *nrhs * ilaenv_(&c__1, (char *)"DORMLQ", (char *)"LT", n, nrhs, m, &c_n1, + (ftnlen)6, (ftnlen)2); + maxwrk = max(i__1, i__2); + i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + wlalsd; + maxwrk = max(i__1, i__2); + i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3, i__4), i__3 = max(i__3, *nrhs), + i__4 = *n - *m * 3; + i__1 = maxwrk, i__2 = (*m << 2) + *m * *m + max(i__3, i__4); + maxwrk = max(i__1, i__2); + } else { + maxwrk = *m * 3 + (*n + *m) * ilaenv_(&c__1, (char *)"DGEBRD", (char *)" ", m, n, &c_n1, &c_n1, + (ftnlen)6, (ftnlen)1); + i__1 = maxwrk, i__2 = *m * 3 + *nrhs * ilaenv_(&c__1, (char *)"DORMBR", (char *)"QLT", m, nrhs, n, + &c_n1, (ftnlen)6, (ftnlen)3); + maxwrk = max(i__1, i__2); + i__1 = maxwrk, i__2 = *m * 3 + *m * ilaenv_(&c__1, (char *)"DORMBR", (char *)"PLN", n, nrhs, m, + &c_n1, (ftnlen)6, (ftnlen)3); + maxwrk = max(i__1, i__2); + i__1 = maxwrk, i__2 = *m * 3 + wlalsd; + maxwrk = max(i__1, i__2); + } + i__1 = *m * 3 + *nrhs, i__2 = *m * 3 + *m, i__1 = max(i__1, i__2), + i__2 = *m * 3 + wlalsd; + minwrk = max(i__1, i__2); + } + minwrk = min(minwrk, maxwrk); + work[1] = (doublereal)maxwrk; + iwork[1] = liwork; + if (*lwork < minwrk && !lquery) { + *info = -12; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DGELSD", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + goto L10; + } + if (*m == 0 || *n == 0) { + *rank = 0; + return 0; + } + eps = dlamch_((char *)"P", (ftnlen)1); + sfmin = dlamch_((char *)"S", (ftnlen)1); + smlnum = sfmin / eps; + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + anrm = dlange_((char *)"M", m, n, &a[a_offset], lda, &work[1], (ftnlen)1); + iascl = 0; + if (anrm > 0. && anrm < smlnum) { + dlascl_((char *)"G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, info, (ftnlen)1); + iascl = 1; + } else if (anrm > bignum) { + dlascl_((char *)"G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, info, (ftnlen)1); + iascl = 2; + } else if (anrm == 0.) { + i__1 = max(*m, *n); + dlaset_((char *)"F", &i__1, nrhs, &c_b82, &c_b82, &b[b_offset], ldb, (ftnlen)1); + dlaset_((char *)"F", &minmn, &c__1, &c_b82, &c_b82, &s[1], &c__1, (ftnlen)1); + *rank = 0; + goto L10; + } + bnrm = dlange_((char *)"M", m, nrhs, &b[b_offset], ldb, &work[1], (ftnlen)1); + ibscl = 0; + if (bnrm > 0. && bnrm < smlnum) { + dlascl_((char *)"G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb, info, (ftnlen)1); + ibscl = 1; + } else if (bnrm > bignum) { + dlascl_((char *)"G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb, info, (ftnlen)1); + ibscl = 2; + } + if (*m < *n) { + i__1 = *n - *m; + dlaset_((char *)"F", &i__1, nrhs, &c_b82, &c_b82, &b[*m + 1 + b_dim1], ldb, (ftnlen)1); + } + if (*m >= *n) { + mm = *m; + if (*m >= mnthr) { + mm = *n; + itau = 1; + nwork = itau + *n; + i__1 = *lwork - nwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1, info); + i__1 = *lwork - nwork + 1; + dormqr_((char *)"L", (char *)"T", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[b_offset], ldb, + &work[nwork], &i__1, info, (ftnlen)1, (ftnlen)1); + if (*n > 1) { + i__1 = *n - 1; + i__2 = *n - 1; + dlaset_((char *)"L", &i__1, &i__2, &c_b82, &c_b82, &a[a_dim1 + 2], lda, (ftnlen)1); + } + } + ie = 1; + itauq = ie + *n; + itaup = itauq + *n; + nwork = itaup + *n; + i__1 = *lwork - nwork + 1; + dgebrd_(&mm, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &work[itaup], + &work[nwork], &i__1, info); + i__1 = *lwork - nwork + 1; + dormbr_((char *)"Q", (char *)"L", (char *)"T", &mm, nrhs, n, &a[a_offset], lda, &work[itauq], &b[b_offset], ldb, + &work[nwork], &i__1, info, (ftnlen)1, (ftnlen)1, (ftnlen)1); + dlalsd_((char *)"U", &smlsiz, n, nrhs, &s[1], &work[ie], &b[b_offset], ldb, rcond, rank, + &work[nwork], &iwork[1], info, (ftnlen)1); + if (*info != 0) { + goto L10; + } + i__1 = *lwork - nwork + 1; + dormbr_((char *)"P", (char *)"L", (char *)"N", n, nrhs, n, &a[a_offset], lda, &work[itaup], &b[b_offset], ldb, + &work[nwork], &i__1, info, (ftnlen)1, (ftnlen)1, (ftnlen)1); + } else { + i__1 = *m, i__2 = (*m << 1) - 4, i__1 = max(i__1, i__2), i__1 = max(i__1, *nrhs), + i__2 = *n - *m * 3, i__1 = max(i__1, i__2); + if (*n >= mnthr && *lwork >= (*m << 2) + *m * *m + max(i__1, wlalsd)) { + ldwork = *m; + i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3, i__4), i__3 = max(i__3, *nrhs), + i__4 = *n - *m * 3; + i__1 = (*m << 2) + *m * *lda + max(i__3, i__4), i__2 = *m * *lda + *m + *m * *nrhs, + i__1 = max(i__1, i__2), i__2 = (*m << 2) + *m * *lda + wlalsd; + if (*lwork >= max(i__1, i__2)) { + ldwork = *lda; + } + itau = 1; + nwork = *m + 1; + i__1 = *lwork - nwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1, info); + il = nwork; + dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[il], &ldwork, (ftnlen)1); + i__1 = *m - 1; + i__2 = *m - 1; + dlaset_((char *)"U", &i__1, &i__2, &c_b82, &c_b82, &work[il + ldwork], &ldwork, (ftnlen)1); + ie = il + ldwork * *m; + itauq = ie + *m; + itaup = itauq + *m; + nwork = itaup + *m; + i__1 = *lwork - nwork + 1; + dgebrd_(m, m, &work[il], &ldwork, &s[1], &work[ie], &work[itauq], &work[itaup], + &work[nwork], &i__1, info); + i__1 = *lwork - nwork + 1; + dormbr_((char *)"Q", (char *)"L", (char *)"T", m, nrhs, m, &work[il], &ldwork, &work[itauq], &b[b_offset], ldb, + &work[nwork], &i__1, info, (ftnlen)1, (ftnlen)1, (ftnlen)1); + dlalsd_((char *)"U", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset], ldb, rcond, rank, + &work[nwork], &iwork[1], info, (ftnlen)1); + if (*info != 0) { + goto L10; + } + i__1 = *lwork - nwork + 1; + dormbr_((char *)"P", (char *)"L", (char *)"N", m, nrhs, m, &work[il], &ldwork, &work[itaup], &b[b_offset], ldb, + &work[nwork], &i__1, info, (ftnlen)1, (ftnlen)1, (ftnlen)1); + i__1 = *n - *m; + dlaset_((char *)"F", &i__1, nrhs, &c_b82, &c_b82, &b[*m + 1 + b_dim1], ldb, (ftnlen)1); + nwork = itau + *m; + i__1 = *lwork - nwork + 1; + dormlq_((char *)"L", (char *)"T", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[b_offset], ldb, + &work[nwork], &i__1, info, (ftnlen)1, (ftnlen)1); + } else { + ie = 1; + itauq = ie + *m; + itaup = itauq + *m; + nwork = itaup + *m; + i__1 = *lwork - nwork + 1; + dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &work[itaup], + &work[nwork], &i__1, info); + i__1 = *lwork - nwork + 1; + dormbr_((char *)"Q", (char *)"L", (char *)"T", m, nrhs, n, &a[a_offset], lda, &work[itauq], &b[b_offset], ldb, + &work[nwork], &i__1, info, (ftnlen)1, (ftnlen)1, (ftnlen)1); + dlalsd_((char *)"L", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset], ldb, rcond, rank, + &work[nwork], &iwork[1], info, (ftnlen)1); + if (*info != 0) { + goto L10; + } + i__1 = *lwork - nwork + 1; + dormbr_((char *)"P", (char *)"L", (char *)"N", n, nrhs, m, &a[a_offset], lda, &work[itaup], &b[b_offset], ldb, + &work[nwork], &i__1, info, (ftnlen)1, (ftnlen)1, (ftnlen)1); + } + } + if (iascl == 1) { + dlascl_((char *)"G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb, info, (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &minmn, info, (ftnlen)1); + } else if (iascl == 2) { + dlascl_((char *)"G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb, info, (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &minmn, info, (ftnlen)1); + } + if (ibscl == 1) { + dlascl_((char *)"G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb, info, (ftnlen)1); + } else if (ibscl == 2) { + dlascl_((char *)"G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb, info, (ftnlen)1); + } +L10: + work[1] = (doublereal)maxwrk; + iwork[1] = liwork; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dgelsd.f b/lib/linalg/dgelsd.f deleted file mode 100644 index b3b3d8b2d3..0000000000 --- a/lib/linalg/dgelsd.f +++ /dev/null @@ -1,626 +0,0 @@ -*> \brief DGELSD computes the minimum-norm solution to a linear least squares problem for GE matrices -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGELSD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, -* WORK, LWORK, IWORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK -* DOUBLE PRECISION RCOND -* .. -* .. Array Arguments .. -* INTEGER IWORK( * ) -* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGELSD computes the minimum-norm solution to a real linear least -*> squares problem: -*> minimize 2-norm(| b - A*x |) -*> using the singular value decomposition (SVD) of A. A is an M-by-N -*> matrix which may be rank-deficient. -*> -*> Several right hand side vectors b and solution vectors x can be -*> handled in a single call; they are stored as the columns of the -*> M-by-NRHS right hand side matrix B and the N-by-NRHS solution -*> matrix X. -*> -*> The problem is solved in three steps: -*> (1) Reduce the coefficient matrix A to bidiagonal form with -*> Householder transformations, reducing the original problem -*> into a "bidiagonal least squares problem" (BLS) -*> (2) Solve the BLS using a divide and conquer approach. -*> (3) Apply back all the Householder transformations to solve -*> the original least squares problem. -*> -*> The effective rank of A is determined by treating as zero those -*> singular values which are less than RCOND times the largest singular -*> value. -*> -*> The divide and conquer algorithm makes very mild assumptions about -*> floating point arithmetic. It will work on machines with a guard -*> digit in add/subtract, or on those binary machines without guard -*> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or -*> Cray-2. It could conceivably fail on hexadecimal or decimal machines -*> without guard digits, but we know of none. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of A. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of A. N >= 0. -*> \endverbatim -*> -*> \param[in] NRHS -*> \verbatim -*> NRHS is INTEGER -*> The number of right hand sides, i.e., the number of columns -*> of the matrices B and X. NRHS >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the M-by-N matrix A. -*> On exit, A has been destroyed. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) -*> On entry, the M-by-NRHS right hand side matrix B. -*> On exit, B is overwritten by the N-by-NRHS solution -*> matrix X. If m >= n and RANK = n, the residual -*> sum-of-squares for the solution in the i-th column is given -*> by the sum of squares of elements n+1:m in that column. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >= max(1,max(M,N)). -*> \endverbatim -*> -*> \param[out] S -*> \verbatim -*> S is DOUBLE PRECISION array, dimension (min(M,N)) -*> The singular values of A in decreasing order. -*> The condition number of A in the 2-norm = S(1)/S(min(m,n)). -*> \endverbatim -*> -*> \param[in] RCOND -*> \verbatim -*> RCOND is DOUBLE PRECISION -*> RCOND is used to determine the effective rank of A. -*> Singular values S(i) <= RCOND*S(1) are treated as zero. -*> If RCOND < 0, machine precision is used instead. -*> \endverbatim -*> -*> \param[out] RANK -*> \verbatim -*> RANK is INTEGER -*> The effective rank of A, i.e., the number of singular values -*> which are greater than RCOND*S(1). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. LWORK must be at least 1. -*> The exact minimum amount of workspace needed depends on M, -*> N and NRHS. As long as LWORK is at least -*> 12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2, -*> if M is greater than or equal to N or -*> 12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2, -*> if M is less than N, the code will execute correctly. -*> SMLSIZ is returned by ILAENV and is equal to the maximum -*> size of the subproblems at the bottom of the computation -*> tree (usually about 25), and -*> NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 ) -*> For good performance, LWORK should generally be larger. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal size of the WORK array, returns -*> this value as the first entry of the WORK array, and no error -*> message related to LWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) -*> LIWORK >= max(1, 3 * MINMN * NLVL + 11 * MINMN), -*> where MINMN = MIN( M,N ). -*> On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value. -*> > 0: the algorithm for computing the SVD failed to converge; -*> if INFO = i, i off-diagonal elements of an intermediate -*> bidiagonal form did not converge to zero. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleGEsolve -* -*> \par Contributors: -* ================== -*> -*> Ming Gu and Ren-Cang Li, Computer Science Division, University of -*> California at Berkeley, USA \n -*> Osni Marques, LBNL/NERSC, USA \n -* -* ===================================================================== - SUBROUTINE DGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, - $ WORK, LWORK, IWORK, INFO ) -* -* -- LAPACK driver routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK - DOUBLE PRECISION RCOND -* .. -* .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER IASCL, IBSCL, IE, IL, ITAU, ITAUP, ITAUQ, - $ LDWORK, LIWORK, MAXMN, MAXWRK, MINMN, MINWRK, - $ MM, MNTHR, NLVL, NWORK, SMLSIZ, WLALSD - DOUBLE PRECISION ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM -* .. -* .. External Subroutines .. - EXTERNAL DGEBRD, DGELQF, DGEQRF, DLABAD, DLACPY, DLALSD, - $ DLASCL, DLASET, DORMBR, DORMLQ, DORMQR, XERBLA -* .. -* .. External Functions .. - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL ILAENV, DLAMCH, DLANGE -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, INT, LOG, MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments. -* - INFO = 0 - MINMN = MIN( M, N ) - MAXMN = MAX( M, N ) - MNTHR = ILAENV( 6, 'DGELSD', ' ', M, N, NRHS, -1 ) - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, MAXMN ) ) THEN - INFO = -7 - END IF -* - SMLSIZ = ILAENV( 9, 'DGELSD', ' ', 0, 0, 0, 0 ) -* -* Compute workspace. -* (Note: Comments in the code beginning "Workspace:" describe the -* minimal amount of workspace needed at that point in the code, -* as well as the preferred amount for good performance. -* NB refers to the optimal block size for the immediately -* following subroutine, as returned by ILAENV.) -* - MINWRK = 1 - LIWORK = 1 - MINMN = MAX( 1, MINMN ) - NLVL = MAX( INT( LOG( DBLE( MINMN ) / DBLE( SMLSIZ+1 ) ) / - $ LOG( TWO ) ) + 1, 0 ) -* - IF( INFO.EQ.0 ) THEN - MAXWRK = 0 - LIWORK = 3*MINMN*NLVL + 11*MINMN - MM = M - IF( M.GE.N .AND. M.GE.MNTHR ) THEN -* -* Path 1a - overdetermined, with many more rows than columns. -* - MM = N - MAXWRK = MAX( MAXWRK, N+N*ILAENV( 1, 'DGEQRF', ' ', M, N, - $ -1, -1 ) ) - MAXWRK = MAX( MAXWRK, N+NRHS* - $ ILAENV( 1, 'DORMQR', 'LT', M, NRHS, N, -1 ) ) - END IF - IF( M.GE.N ) THEN -* -* Path 1 - overdetermined or exactly determined. -* - MAXWRK = MAX( MAXWRK, 3*N+( MM+N )* - $ ILAENV( 1, 'DGEBRD', ' ', MM, N, -1, -1 ) ) - MAXWRK = MAX( MAXWRK, 3*N+NRHS* - $ ILAENV( 1, 'DORMBR', 'QLT', MM, NRHS, N, -1 ) ) - MAXWRK = MAX( MAXWRK, 3*N+( N-1 )* - $ ILAENV( 1, 'DORMBR', 'PLN', N, NRHS, N, -1 ) ) - WLALSD = 9*N+2*N*SMLSIZ+8*N*NLVL+N*NRHS+(SMLSIZ+1)**2 - MAXWRK = MAX( MAXWRK, 3*N+WLALSD ) - MINWRK = MAX( 3*N+MM, 3*N+NRHS, 3*N+WLALSD ) - END IF - IF( N.GT.M ) THEN - WLALSD = 9*M+2*M*SMLSIZ+8*M*NLVL+M*NRHS+(SMLSIZ+1)**2 - IF( N.GE.MNTHR ) THEN -* -* Path 2a - underdetermined, with many more columns -* than rows. -* - MAXWRK = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) - MAXWRK = MAX( MAXWRK, M*M+4*M+2*M* - $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) - MAXWRK = MAX( MAXWRK, M*M+4*M+NRHS* - $ ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, M, -1 ) ) - MAXWRK = MAX( MAXWRK, M*M+4*M+( M-1 )* - $ ILAENV( 1, 'DORMBR', 'PLN', M, NRHS, M, -1 ) ) - IF( NRHS.GT.1 ) THEN - MAXWRK = MAX( MAXWRK, M*M+M+M*NRHS ) - ELSE - MAXWRK = MAX( MAXWRK, M*M+2*M ) - END IF - MAXWRK = MAX( MAXWRK, M+NRHS* - $ ILAENV( 1, 'DORMLQ', 'LT', N, NRHS, M, -1 ) ) - MAXWRK = MAX( MAXWRK, M*M+4*M+WLALSD ) -! XXX: Ensure the Path 2a case below is triggered. The workspace -! calculation should use queries for all routines eventually. - MAXWRK = MAX( MAXWRK, - $ 4*M+M*M+MAX( M, 2*M-4, NRHS, N-3*M ) ) - ELSE -* -* Path 2 - remaining underdetermined cases. -* - MAXWRK = 3*M + ( N+M )*ILAENV( 1, 'DGEBRD', ' ', M, N, - $ -1, -1 ) - MAXWRK = MAX( MAXWRK, 3*M+NRHS* - $ ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, N, -1 ) ) - MAXWRK = MAX( MAXWRK, 3*M+M* - $ ILAENV( 1, 'DORMBR', 'PLN', N, NRHS, M, -1 ) ) - MAXWRK = MAX( MAXWRK, 3*M+WLALSD ) - END IF - MINWRK = MAX( 3*M+NRHS, 3*M+M, 3*M+WLALSD ) - END IF - MINWRK = MIN( MINWRK, MAXWRK ) - WORK( 1 ) = MAXWRK - IWORK( 1 ) = LIWORK - - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGELSD', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - GO TO 10 - END IF -* -* Quick return if possible. -* - IF( M.EQ.0 .OR. N.EQ.0 ) THEN - RANK = 0 - RETURN - END IF -* -* Get machine parameters. -* - EPS = DLAMCH( 'P' ) - SFMIN = DLAMCH( 'S' ) - SMLNUM = SFMIN / EPS - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) -* -* Scale A if max entry outside range [SMLNUM,BIGNUM]. -* - ANRM = DLANGE( 'M', M, N, A, LDA, WORK ) - IASCL = 0 - IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN -* -* Scale matrix norm up to SMLNUM. -* - CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO ) - IASCL = 1 - ELSE IF( ANRM.GT.BIGNUM ) THEN -* -* Scale matrix norm down to BIGNUM. -* - CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO ) - IASCL = 2 - ELSE IF( ANRM.EQ.ZERO ) THEN -* -* Matrix all zero. Return zero solution. -* - CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB ) - CALL DLASET( 'F', MINMN, 1, ZERO, ZERO, S, 1 ) - RANK = 0 - GO TO 10 - END IF -* -* Scale B if max entry outside range [SMLNUM,BIGNUM]. -* - BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK ) - IBSCL = 0 - IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN -* -* Scale matrix norm up to SMLNUM. -* - CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO ) - IBSCL = 1 - ELSE IF( BNRM.GT.BIGNUM ) THEN -* -* Scale matrix norm down to BIGNUM. -* - CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO ) - IBSCL = 2 - END IF -* -* If M < N make sure certain entries of B are zero. -* - IF( M.LT.N ) - $ CALL DLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB ) -* -* Overdetermined case. -* - IF( M.GE.N ) THEN -* -* Path 1 - overdetermined or exactly determined. -* - MM = M - IF( M.GE.MNTHR ) THEN -* -* Path 1a - overdetermined, with many more rows than columns. -* - MM = N - ITAU = 1 - NWORK = ITAU + N -* -* Compute A=Q*R. -* (Workspace: need 2*N, prefer N+N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), - $ LWORK-NWORK+1, INFO ) -* -* Multiply B by transpose(Q). -* (Workspace: need N+NRHS, prefer N+NRHS*NB) -* - CALL DORMQR( 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAU ), B, - $ LDB, WORK( NWORK ), LWORK-NWORK+1, INFO ) -* -* Zero out below R. -* - IF( N.GT.1 ) THEN - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA ) - END IF - END IF -* - IE = 1 - ITAUQ = IE + N - ITAUP = ITAUQ + N - NWORK = ITAUP + N -* -* Bidiagonalize R in A. -* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) -* - CALL DGEBRD( MM, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, - $ INFO ) -* -* Multiply B by transpose of left bidiagonalizing vectors of R. -* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) -* - CALL DORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, WORK( ITAUQ ), - $ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO ) -* -* Solve the bidiagonal least squares problem. -* - CALL DLALSD( 'U', SMLSIZ, N, NRHS, S, WORK( IE ), B, LDB, - $ RCOND, RANK, WORK( NWORK ), IWORK, INFO ) - IF( INFO.NE.0 ) THEN - GO TO 10 - END IF -* -* Multiply B by right bidiagonalizing vectors of R. -* - CALL DORMBR( 'P', 'L', 'N', N, NRHS, N, A, LDA, WORK( ITAUP ), - $ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO ) -* - ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+ - $ MAX( M, 2*M-4, NRHS, N-3*M, WLALSD ) ) THEN -* -* Path 2a - underdetermined, with many more columns than rows -* and sufficient workspace for an efficient algorithm. -* - LDWORK = M - IF( LWORK.GE.MAX( 4*M+M*LDA+MAX( M, 2*M-4, NRHS, N-3*M ), - $ M*LDA+M+M*NRHS, 4*M+M*LDA+WLALSD ) )LDWORK = LDA - ITAU = 1 - NWORK = M + 1 -* -* Compute A=L*Q. -* (Workspace: need 2*M, prefer M+M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), - $ LWORK-NWORK+1, INFO ) - IL = NWORK -* -* Copy L to WORK(IL), zeroing out above its diagonal. -* - CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( IL+LDWORK ), - $ LDWORK ) - IE = IL + LDWORK*M - ITAUQ = IE + M - ITAUP = ITAUQ + M - NWORK = ITAUP + M -* -* Bidiagonalize L in WORK(IL). -* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) -* - CALL DGEBRD( M, M, WORK( IL ), LDWORK, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), - $ LWORK-NWORK+1, INFO ) -* -* Multiply B by transpose of left bidiagonalizing vectors of L. -* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) -* - CALL DORMBR( 'Q', 'L', 'T', M, NRHS, M, WORK( IL ), LDWORK, - $ WORK( ITAUQ ), B, LDB, WORK( NWORK ), - $ LWORK-NWORK+1, INFO ) -* -* Solve the bidiagonal least squares problem. -* - CALL DLALSD( 'U', SMLSIZ, M, NRHS, S, WORK( IE ), B, LDB, - $ RCOND, RANK, WORK( NWORK ), IWORK, INFO ) - IF( INFO.NE.0 ) THEN - GO TO 10 - END IF -* -* Multiply B by right bidiagonalizing vectors of L. -* - CALL DORMBR( 'P', 'L', 'N', M, NRHS, M, WORK( IL ), LDWORK, - $ WORK( ITAUP ), B, LDB, WORK( NWORK ), - $ LWORK-NWORK+1, INFO ) -* -* Zero out below first M rows of B. -* - CALL DLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB ) - NWORK = ITAU + M -* -* Multiply transpose(Q) by B. -* (Workspace: need M+NRHS, prefer M+NRHS*NB) -* - CALL DORMLQ( 'L', 'T', N, NRHS, M, A, LDA, WORK( ITAU ), B, - $ LDB, WORK( NWORK ), LWORK-NWORK+1, INFO ) -* - ELSE -* -* Path 2 - remaining underdetermined cases. -* - IE = 1 - ITAUQ = IE + M - ITAUP = ITAUQ + M - NWORK = ITAUP + M -* -* Bidiagonalize A. -* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) -* - CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, - $ INFO ) -* -* Multiply B by transpose of left bidiagonalizing vectors. -* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) -* - CALL DORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAUQ ), - $ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO ) -* -* Solve the bidiagonal least squares problem. -* - CALL DLALSD( 'L', SMLSIZ, M, NRHS, S, WORK( IE ), B, LDB, - $ RCOND, RANK, WORK( NWORK ), IWORK, INFO ) - IF( INFO.NE.0 ) THEN - GO TO 10 - END IF -* -* Multiply B by right bidiagonalizing vectors of A. -* - CALL DORMBR( 'P', 'L', 'N', N, NRHS, M, A, LDA, WORK( ITAUP ), - $ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO ) -* - END IF -* -* Undo scaling. -* - IF( IASCL.EQ.1 ) THEN - CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO ) - CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN, - $ INFO ) - ELSE IF( IASCL.EQ.2 ) THEN - CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO ) - CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN, - $ INFO ) - END IF - IF( IBSCL.EQ.1 ) THEN - CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO ) - ELSE IF( IBSCL.EQ.2 ) THEN - CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO ) - END IF -* - 10 CONTINUE - WORK( 1 ) = MAXWRK - IWORK( 1 ) = LIWORK - RETURN -* -* End of DGELSD -* - END diff --git a/lib/linalg/dgelss.cpp b/lib/linalg/dgelss.cpp new file mode 100644 index 0000000000..e10906f4e9 --- /dev/null +++ b/lib/linalg/dgelss.cpp @@ -0,0 +1,466 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__6 = 6; +static integer c_n1 = -1; +static integer c__0 = 0; +static doublereal c_b46 = 0.; +static integer c__1 = 1; +static doublereal c_b79 = 1.; +int dgelss_(integer *m, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *b, + integer *ldb, doublereal *s, doublereal *rcond, integer *rank, doublereal *work, + integer *lwork, integer *info) +{ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4; + doublereal d__1; + integer i__, bl, ie, il, mm; + doublereal dum[1], eps, thr, anrm, bnrm; + integer itau, lwork_dgebrd__, lwork_dgelqf__, lwork_dgeqrf__, lwork_dorgbr__, lwork_dormbr__, + lwork_dormlq__, lwork_dormqr__; + extern int dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, + ftnlen, ftnlen); + integer iascl, ibscl; + extern int dgemv_(char *, integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, ftnlen), + drscl_(integer *, doublereal *, doublereal *, integer *); + integer chunk; + doublereal sfmin; + integer minmn; + extern int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *); + integer maxmn, itaup, itauq, mnthr, iwork; + extern int dlabad_(doublereal *, doublereal *), + 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), + dbdsqr_(char *, integer *, integer *, integer *, integer *, doublereal *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, ftnlen), + dorgbr_(char *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *, integer *, ftnlen); + doublereal bignum; + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, + ftnlen, ftnlen); + extern int dormbr_(char *, char *, char *, integer *, integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, + integer *, ftnlen, ftnlen, ftnlen), + dormlq_(char *, char *, integer *, integer *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, integer *, ftnlen, + ftnlen); + integer ldwork; + extern int dormqr_(char *, char *, integer *, integer *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, integer *, + ftnlen, ftnlen); + integer minwrk, maxwrk; + doublereal smlnum; + logical lquery; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + --s; + --work; + *info = 0; + minmn = min(*m, *n); + maxmn = max(*m, *n); + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < max(1, *m)) { + *info = -5; + } else if (*ldb < max(1, maxmn)) { + *info = -7; + } + if (*info == 0) { + minwrk = 1; + maxwrk = 1; + if (minmn > 0) { + mm = *m; + mnthr = ilaenv_(&c__6, (char *)"DGELSS", (char *)" ", m, n, nrhs, &c_n1, (ftnlen)6, (ftnlen)1); + if (*m >= *n && *m >= mnthr) { + dgeqrf_(m, n, &a[a_offset], lda, dum, dum, &c_n1, info); + lwork_dgeqrf__ = (integer)dum[0]; + dormqr_((char *)"L", (char *)"T", m, nrhs, n, &a[a_offset], lda, dum, &b[b_offset], ldb, dum, &c_n1, + info, (ftnlen)1, (ftnlen)1); + lwork_dormqr__ = (integer)dum[0]; + mm = *n; + i__1 = maxwrk, i__2 = *n + lwork_dgeqrf__; + maxwrk = max(i__1, i__2); + i__1 = maxwrk, i__2 = *n + lwork_dormqr__; + maxwrk = max(i__1, i__2); + } + if (*m >= *n) { + i__1 = 1, i__2 = *n * 5; + bdspac = max(i__1, i__2); + dgebrd_(&mm, n, &a[a_offset], lda, &s[1], dum, dum, dum, dum, &c_n1, info); + lwork_dgebrd__ = (integer)dum[0]; + dormbr_((char *)"Q", (char *)"L", (char *)"T", &mm, nrhs, n, &a[a_offset], lda, dum, &b[b_offset], ldb, dum, + &c_n1, info, (ftnlen)1, (ftnlen)1, (ftnlen)1); + lwork_dormbr__ = (integer)dum[0]; + dorgbr_((char *)"P", n, n, n, &a[a_offset], lda, dum, dum, &c_n1, info, (ftnlen)1); + lwork_dorgbr__ = (integer)dum[0]; + i__1 = maxwrk, i__2 = *n * 3 + lwork_dgebrd__; + maxwrk = max(i__1, i__2); + i__1 = maxwrk, i__2 = *n * 3 + lwork_dormbr__; + maxwrk = max(i__1, i__2); + i__1 = maxwrk, i__2 = *n * 3 + lwork_dorgbr__; + maxwrk = max(i__1, i__2); + maxwrk = max(maxwrk, bdspac); + i__1 = maxwrk, i__2 = *n * *nrhs; + maxwrk = max(i__1, i__2); + i__1 = *n * 3 + mm, i__2 = *n * 3 + *nrhs, i__1 = max(i__1, i__2); + minwrk = max(i__1, bdspac); + maxwrk = max(minwrk, maxwrk); + } + if (*n > *m) { + i__1 = 1, i__2 = *m * 5; + bdspac = max(i__1, i__2); + i__1 = *m * 3 + *nrhs, i__2 = *m * 3 + *n, i__1 = max(i__1, i__2); + minwrk = max(i__1, bdspac); + if (*n >= mnthr) { + dgelqf_(m, n, &a[a_offset], lda, dum, dum, &c_n1, info); + lwork_dgelqf__ = (integer)dum[0]; + dgebrd_(m, m, &a[a_offset], lda, &s[1], dum, dum, dum, dum, &c_n1, info); + lwork_dgebrd__ = (integer)dum[0]; + dormbr_((char *)"Q", (char *)"L", (char *)"T", m, nrhs, n, &a[a_offset], lda, dum, &b[b_offset], ldb, + dum, &c_n1, info, (ftnlen)1, (ftnlen)1, (ftnlen)1); + lwork_dormbr__ = (integer)dum[0]; + dorgbr_((char *)"P", m, m, m, &a[a_offset], lda, dum, dum, &c_n1, info, (ftnlen)1); + lwork_dorgbr__ = (integer)dum[0]; + dormlq_((char *)"L", (char *)"T", n, nrhs, m, &a[a_offset], lda, dum, &b[b_offset], ldb, dum, + &c_n1, info, (ftnlen)1, (ftnlen)1); + lwork_dormlq__ = (integer)dum[0]; + maxwrk = *m + lwork_dgelqf__; + i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + lwork_dgebrd__; + maxwrk = max(i__1, i__2); + i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + lwork_dormbr__; + maxwrk = max(i__1, i__2); + i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + lwork_dorgbr__; + maxwrk = max(i__1, i__2); + i__1 = maxwrk, i__2 = *m * *m + *m + bdspac; + maxwrk = max(i__1, i__2); + if (*nrhs > 1) { + i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs; + maxwrk = max(i__1, i__2); + } else { + i__1 = maxwrk, i__2 = *m * *m + (*m << 1); + maxwrk = max(i__1, i__2); + } + i__1 = maxwrk, i__2 = *m + lwork_dormlq__; + maxwrk = max(i__1, i__2); + } else { + dgebrd_(m, n, &a[a_offset], lda, &s[1], dum, dum, dum, dum, &c_n1, info); + lwork_dgebrd__ = (integer)dum[0]; + dormbr_((char *)"Q", (char *)"L", (char *)"T", m, nrhs, m, &a[a_offset], lda, dum, &b[b_offset], ldb, + dum, &c_n1, info, (ftnlen)1, (ftnlen)1, (ftnlen)1); + lwork_dormbr__ = (integer)dum[0]; + dorgbr_((char *)"P", m, n, m, &a[a_offset], lda, dum, dum, &c_n1, info, (ftnlen)1); + lwork_dorgbr__ = (integer)dum[0]; + maxwrk = *m * 3 + lwork_dgebrd__; + i__1 = maxwrk, i__2 = *m * 3 + lwork_dormbr__; + maxwrk = max(i__1, i__2); + i__1 = maxwrk, i__2 = *m * 3 + lwork_dorgbr__; + maxwrk = max(i__1, i__2); + maxwrk = max(maxwrk, bdspac); + i__1 = maxwrk, i__2 = *n * *nrhs; + maxwrk = max(i__1, i__2); + } + } + maxwrk = max(minwrk, maxwrk); + } + work[1] = (doublereal)maxwrk; + if (*lwork < minwrk && !lquery) { + *info = -12; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DGELSS", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + if (*m == 0 || *n == 0) { + *rank = 0; + return 0; + } + eps = dlamch_((char *)"P", (ftnlen)1); + sfmin = dlamch_((char *)"S", (ftnlen)1); + smlnum = sfmin / eps; + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + anrm = dlange_((char *)"M", m, n, &a[a_offset], lda, &work[1], (ftnlen)1); + iascl = 0; + if (anrm > 0. && anrm < smlnum) { + dlascl_((char *)"G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, info, (ftnlen)1); + iascl = 1; + } else if (anrm > bignum) { + dlascl_((char *)"G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, info, (ftnlen)1); + iascl = 2; + } else if (anrm == 0.) { + i__1 = max(*m, *n); + dlaset_((char *)"F", &i__1, nrhs, &c_b46, &c_b46, &b[b_offset], ldb, (ftnlen)1); + dlaset_((char *)"F", &minmn, &c__1, &c_b46, &c_b46, &s[1], &minmn, (ftnlen)1); + *rank = 0; + goto L70; + } + bnrm = dlange_((char *)"M", m, nrhs, &b[b_offset], ldb, &work[1], (ftnlen)1); + ibscl = 0; + if (bnrm > 0. && bnrm < smlnum) { + dlascl_((char *)"G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb, info, (ftnlen)1); + ibscl = 1; + } else if (bnrm > bignum) { + dlascl_((char *)"G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb, info, (ftnlen)1); + ibscl = 2; + } + if (*m >= *n) { + mm = *m; + if (*m >= mnthr) { + mm = *n; + itau = 1; + iwork = itau + *n; + i__1 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__1, info); + i__1 = *lwork - iwork + 1; + dormqr_((char *)"L", (char *)"T", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[b_offset], ldb, + &work[iwork], &i__1, info, (ftnlen)1, (ftnlen)1); + if (*n > 1) { + i__1 = *n - 1; + i__2 = *n - 1; + dlaset_((char *)"L", &i__1, &i__2, &c_b46, &c_b46, &a[a_dim1 + 2], lda, (ftnlen)1); + } + } + ie = 1; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + i__1 = *lwork - iwork + 1; + dgebrd_(&mm, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &work[itaup], + &work[iwork], &i__1, info); + i__1 = *lwork - iwork + 1; + dormbr_((char *)"Q", (char *)"L", (char *)"T", &mm, nrhs, n, &a[a_offset], lda, &work[itauq], &b[b_offset], ldb, + &work[iwork], &i__1, info, (ftnlen)1, (ftnlen)1, (ftnlen)1); + i__1 = *lwork - iwork + 1; + dorgbr_((char *)"P", n, n, n, &a[a_offset], lda, &work[itaup], &work[iwork], &i__1, info, + (ftnlen)1); + iwork = ie + *n; + dbdsqr_((char *)"U", n, n, &c__0, nrhs, &s[1], &work[ie], &a[a_offset], lda, dum, &c__1, + &b[b_offset], ldb, &work[iwork], info, (ftnlen)1); + if (*info != 0) { + goto L70; + } + d__1 = *rcond * s[1]; + thr = max(d__1, sfmin); + if (*rcond < 0.) { + d__1 = eps * s[1]; + thr = max(d__1, sfmin); + } + *rank = 0; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (s[i__] > thr) { + drscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb); + ++(*rank); + } else { + dlaset_((char *)"F", &c__1, nrhs, &c_b46, &c_b46, &b[i__ + b_dim1], ldb, (ftnlen)1); + } + } + if (*lwork >= *ldb * *nrhs && *nrhs > 1) { + dgemm_((char *)"T", (char *)"N", n, nrhs, n, &c_b79, &a[a_offset], lda, &b[b_offset], ldb, &c_b46, + &work[1], ldb, (ftnlen)1, (ftnlen)1); + dlacpy_((char *)"G", n, nrhs, &work[1], ldb, &b[b_offset], ldb, (ftnlen)1); + } else if (*nrhs > 1) { + chunk = *lwork / *n; + i__1 = *nrhs; + i__2 = chunk; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + i__3 = *nrhs - i__ + 1; + bl = min(i__3, chunk); + dgemm_((char *)"T", (char *)"N", n, &bl, n, &c_b79, &a[a_offset], lda, &b[i__ * b_dim1 + 1], ldb, + &c_b46, &work[1], n, (ftnlen)1, (ftnlen)1); + dlacpy_((char *)"G", n, &bl, &work[1], n, &b[i__ * b_dim1 + 1], ldb, (ftnlen)1); + } + } else { + dgemv_((char *)"T", n, n, &c_b79, &a[a_offset], lda, &b[b_offset], &c__1, &c_b46, &work[1], + &c__1, (ftnlen)1); + dcopy_(n, &work[1], &c__1, &b[b_offset], &c__1); + } + } else { + i__2 = *m, i__1 = (*m << 1) - 4, i__2 = max(i__2, i__1), i__2 = max(i__2, *nrhs), + i__1 = *n - *m * 3; + if (*n >= mnthr && *lwork >= (*m << 2) + *m * *m + max(i__2, i__1)) { + ldwork = *m; + i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3, i__4), i__3 = max(i__3, *nrhs), + i__4 = *n - *m * 3; + i__2 = (*m << 2) + *m * *lda + max(i__3, i__4), i__1 = *m * *lda + *m + *m * *nrhs; + if (*lwork >= max(i__2, i__1)) { + ldwork = *lda; + } + itau = 1; + iwork = *m + 1; + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, info); + il = iwork; + dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[il], &ldwork, (ftnlen)1); + i__2 = *m - 1; + i__1 = *m - 1; + dlaset_((char *)"U", &i__2, &i__1, &c_b46, &c_b46, &work[il + ldwork], &ldwork, (ftnlen)1); + ie = il + ldwork * *m; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &work[il], &ldwork, &s[1], &work[ie], &work[itauq], &work[itaup], + &work[iwork], &i__2, info); + i__2 = *lwork - iwork + 1; + dormbr_((char *)"Q", (char *)"L", (char *)"T", m, nrhs, m, &work[il], &ldwork, &work[itauq], &b[b_offset], ldb, + &work[iwork], &i__2, info, (ftnlen)1, (ftnlen)1, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", m, m, m, &work[il], &ldwork, &work[itaup], &work[iwork], &i__2, info, + (ftnlen)1); + iwork = ie + *m; + dbdsqr_((char *)"U", m, m, &c__0, nrhs, &s[1], &work[ie], &work[il], &ldwork, &a[a_offset], lda, + &b[b_offset], ldb, &work[iwork], info, (ftnlen)1); + if (*info != 0) { + goto L70; + } + d__1 = *rcond * s[1]; + thr = max(d__1, sfmin); + if (*rcond < 0.) { + d__1 = eps * s[1]; + thr = max(d__1, sfmin); + } + *rank = 0; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + if (s[i__] > thr) { + drscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb); + ++(*rank); + } else { + dlaset_((char *)"F", &c__1, nrhs, &c_b46, &c_b46, &b[i__ + b_dim1], ldb, (ftnlen)1); + } + } + iwork = ie; + if (*lwork >= *ldb * *nrhs + iwork - 1 && *nrhs > 1) { + dgemm_((char *)"T", (char *)"N", m, nrhs, m, &c_b79, &work[il], &ldwork, &b[b_offset], ldb, &c_b46, + &work[iwork], ldb, (ftnlen)1, (ftnlen)1); + dlacpy_((char *)"G", m, nrhs, &work[iwork], ldb, &b[b_offset], ldb, (ftnlen)1); + } else if (*nrhs > 1) { + chunk = (*lwork - iwork + 1) / *m; + i__2 = *nrhs; + i__1 = chunk; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { + i__3 = *nrhs - i__ + 1; + bl = min(i__3, chunk); + dgemm_((char *)"T", (char *)"N", m, &bl, m, &c_b79, &work[il], &ldwork, &b[i__ * b_dim1 + 1], + ldb, &c_b46, &work[iwork], m, (ftnlen)1, (ftnlen)1); + dlacpy_((char *)"G", m, &bl, &work[iwork], m, &b[i__ * b_dim1 + 1], ldb, (ftnlen)1); + } + } else { + dgemv_((char *)"T", m, m, &c_b79, &work[il], &ldwork, &b[b_dim1 + 1], &c__1, &c_b46, + &work[iwork], &c__1, (ftnlen)1); + dcopy_(m, &work[iwork], &c__1, &b[b_dim1 + 1], &c__1); + } + i__1 = *n - *m; + dlaset_((char *)"F", &i__1, nrhs, &c_b46, &c_b46, &b[*m + 1 + b_dim1], ldb, (ftnlen)1); + iwork = itau + *m; + i__1 = *lwork - iwork + 1; + dormlq_((char *)"L", (char *)"T", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[b_offset], ldb, + &work[iwork], &i__1, info, (ftnlen)1, (ftnlen)1); + } else { + ie = 1; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + i__1 = *lwork - iwork + 1; + dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &work[itaup], + &work[iwork], &i__1, info); + i__1 = *lwork - iwork + 1; + dormbr_((char *)"Q", (char *)"L", (char *)"T", m, nrhs, n, &a[a_offset], lda, &work[itauq], &b[b_offset], ldb, + &work[iwork], &i__1, info, (ftnlen)1, (ftnlen)1, (ftnlen)1); + i__1 = *lwork - iwork + 1; + dorgbr_((char *)"P", m, n, m, &a[a_offset], lda, &work[itaup], &work[iwork], &i__1, info, + (ftnlen)1); + iwork = ie + *m; + dbdsqr_((char *)"L", m, n, &c__0, nrhs, &s[1], &work[ie], &a[a_offset], lda, dum, &c__1, + &b[b_offset], ldb, &work[iwork], info, (ftnlen)1); + if (*info != 0) { + goto L70; + } + d__1 = *rcond * s[1]; + thr = max(d__1, sfmin); + if (*rcond < 0.) { + d__1 = eps * s[1]; + thr = max(d__1, sfmin); + } + *rank = 0; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (s[i__] > thr) { + drscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb); + ++(*rank); + } else { + dlaset_((char *)"F", &c__1, nrhs, &c_b46, &c_b46, &b[i__ + b_dim1], ldb, (ftnlen)1); + } + } + if (*lwork >= *ldb * *nrhs && *nrhs > 1) { + dgemm_((char *)"T", (char *)"N", n, nrhs, m, &c_b79, &a[a_offset], lda, &b[b_offset], ldb, &c_b46, + &work[1], ldb, (ftnlen)1, (ftnlen)1); + dlacpy_((char *)"F", n, nrhs, &work[1], ldb, &b[b_offset], ldb, (ftnlen)1); + } else if (*nrhs > 1) { + chunk = *lwork / *n; + i__1 = *nrhs; + i__2 = chunk; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + i__3 = *nrhs - i__ + 1; + bl = min(i__3, chunk); + dgemm_((char *)"T", (char *)"N", n, &bl, m, &c_b79, &a[a_offset], lda, &b[i__ * b_dim1 + 1], + ldb, &c_b46, &work[1], n, (ftnlen)1, (ftnlen)1); + dlacpy_((char *)"F", n, &bl, &work[1], n, &b[i__ * b_dim1 + 1], ldb, (ftnlen)1); + } + } else { + dgemv_((char *)"T", m, n, &c_b79, &a[a_offset], lda, &b[b_offset], &c__1, &c_b46, &work[1], + &c__1, (ftnlen)1); + dcopy_(n, &work[1], &c__1, &b[b_offset], &c__1); + } + } + } + if (iascl == 1) { + dlascl_((char *)"G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb, info, (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &minmn, info, (ftnlen)1); + } else if (iascl == 2) { + dlascl_((char *)"G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb, info, (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &minmn, info, (ftnlen)1); + } + if (ibscl == 1) { + dlascl_((char *)"G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb, info, (ftnlen)1); + } else if (ibscl == 2) { + dlascl_((char *)"G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb, info, (ftnlen)1); + } +L70: + work[1] = (doublereal)maxwrk; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dgelss.f b/lib/linalg/dgelss.f deleted file mode 100644 index c4190f2e09..0000000000 --- a/lib/linalg/dgelss.f +++ /dev/null @@ -1,744 +0,0 @@ -*> \brief DGELSS solves overdetermined or underdetermined systems for GE matrices -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGELSS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, -* WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK -* DOUBLE PRECISION RCOND -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGELSS computes the minimum norm solution to a real linear least -*> squares problem: -*> -*> Minimize 2-norm(| b - A*x |). -*> -*> using the singular value decomposition (SVD) of A. A is an M-by-N -*> matrix which may be rank-deficient. -*> -*> Several right hand side vectors b and solution vectors x can be -*> handled in a single call; they are stored as the columns of the -*> M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix -*> X. -*> -*> The effective rank of A is determined by treating as zero those -*> singular values which are less than RCOND times the largest singular -*> value. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in] NRHS -*> \verbatim -*> NRHS is INTEGER -*> The number of right hand sides, i.e., the number of columns -*> of the matrices B and X. NRHS >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the M-by-N matrix A. -*> On exit, the first min(m,n) rows of A are overwritten with -*> its right singular vectors, stored rowwise. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) -*> On entry, the M-by-NRHS right hand side matrix B. -*> On exit, B is overwritten by the N-by-NRHS solution -*> matrix X. If m >= n and RANK = n, the residual -*> sum-of-squares for the solution in the i-th column is given -*> by the sum of squares of elements n+1:m in that column. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >= max(1,max(M,N)). -*> \endverbatim -*> -*> \param[out] S -*> \verbatim -*> S is DOUBLE PRECISION array, dimension (min(M,N)) -*> The singular values of A in decreasing order. -*> The condition number of A in the 2-norm = S(1)/S(min(m,n)). -*> \endverbatim -*> -*> \param[in] RCOND -*> \verbatim -*> RCOND is DOUBLE PRECISION -*> RCOND is used to determine the effective rank of A. -*> Singular values S(i) <= RCOND*S(1) are treated as zero. -*> If RCOND < 0, machine precision is used instead. -*> \endverbatim -*> -*> \param[out] RANK -*> \verbatim -*> RANK is INTEGER -*> The effective rank of A, i.e., the number of singular values -*> which are greater than RCOND*S(1). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. LWORK >= 1, and also: -*> LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS ) -*> For good performance, LWORK should generally be larger. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal size of the WORK array, returns -*> this value as the first entry of the WORK array, and no error -*> message related to LWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value. -*> > 0: the algorithm for computing the SVD failed to converge; -*> if INFO = i, i off-diagonal elements of an intermediate -*> bidiagonal form did not converge to zero. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleGEsolve -* -* ===================================================================== - SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, - $ WORK, LWORK, INFO ) -* -* -- LAPACK driver routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK - DOUBLE PRECISION RCOND -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER BDSPAC, BL, CHUNK, I, IASCL, IBSCL, IE, IL, - $ ITAU, ITAUP, ITAUQ, IWORK, LDWORK, MAXMN, - $ MAXWRK, MINMN, MINWRK, MM, MNTHR - INTEGER LWORK_DGEQRF, LWORK_DORMQR, LWORK_DGEBRD, - $ LWORK_DORMBR, LWORK_DORGBR, LWORK_DORMLQ, - $ LWORK_DGELQF - DOUBLE PRECISION ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM, THR -* .. -* .. Local Arrays .. - DOUBLE PRECISION DUM( 1 ) -* .. -* .. External Subroutines .. - EXTERNAL DBDSQR, DCOPY, DGEBRD, DGELQF, DGEMM, DGEMV, - $ DGEQRF, DLABAD, DLACPY, DLASCL, DLASET, DORGBR, - $ DORMBR, DORMLQ, DORMQR, DRSCL, XERBLA -* .. -* .. External Functions .. - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL ILAENV, DLAMCH, DLANGE -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - MINMN = MIN( M, N ) - MAXMN = MAX( M, N ) - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, MAXMN ) ) THEN - INFO = -7 - END IF -* -* Compute workspace -* (Note: Comments in the code beginning "Workspace:" describe the -* minimal amount of workspace needed at that point in the code, -* as well as the preferred amount for good performance. -* NB refers to the optimal block size for the immediately -* following subroutine, as returned by ILAENV.) -* - IF( INFO.EQ.0 ) THEN - MINWRK = 1 - MAXWRK = 1 - IF( MINMN.GT.0 ) THEN - MM = M - MNTHR = ILAENV( 6, 'DGELSS', ' ', M, N, NRHS, -1 ) - IF( M.GE.N .AND. M.GE.MNTHR ) THEN -* -* Path 1a - overdetermined, with many more rows than -* columns -* -* Compute space needed for DGEQRF - CALL DGEQRF( M, N, A, LDA, DUM(1), DUM(1), -1, INFO ) - LWORK_DGEQRF = INT( DUM(1) ) -* Compute space needed for DORMQR - CALL DORMQR( 'L', 'T', M, NRHS, N, A, LDA, DUM(1), B, - $ LDB, DUM(1), -1, INFO ) - LWORK_DORMQR = INT( DUM(1) ) - MM = N - MAXWRK = MAX( MAXWRK, N + LWORK_DGEQRF ) - MAXWRK = MAX( MAXWRK, N + LWORK_DORMQR ) - END IF - IF( M.GE.N ) THEN -* -* Path 1 - overdetermined or exactly determined -* -* Compute workspace needed for DBDSQR -* - BDSPAC = MAX( 1, 5*N ) -* Compute space needed for DGEBRD - CALL DGEBRD( MM, N, A, LDA, S, DUM(1), DUM(1), - $ DUM(1), DUM(1), -1, INFO ) - LWORK_DGEBRD = INT( DUM(1) ) -* Compute space needed for DORMBR - CALL DORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, DUM(1), - $ B, LDB, DUM(1), -1, INFO ) - LWORK_DORMBR = INT( DUM(1) ) -* Compute space needed for DORGBR - CALL DORGBR( 'P', N, N, N, A, LDA, DUM(1), - $ DUM(1), -1, INFO ) - LWORK_DORGBR = INT( DUM(1) ) -* Compute total workspace needed - MAXWRK = MAX( MAXWRK, 3*N + LWORK_DGEBRD ) - MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORMBR ) - MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORGBR ) - MAXWRK = MAX( MAXWRK, BDSPAC ) - MAXWRK = MAX( MAXWRK, N*NRHS ) - MINWRK = MAX( 3*N + MM, 3*N + NRHS, BDSPAC ) - MAXWRK = MAX( MINWRK, MAXWRK ) - END IF - IF( N.GT.M ) THEN -* -* Compute workspace needed for DBDSQR -* - BDSPAC = MAX( 1, 5*M ) - MINWRK = MAX( 3*M+NRHS, 3*M+N, BDSPAC ) - IF( N.GE.MNTHR ) THEN -* -* Path 2a - underdetermined, with many more columns -* than rows -* -* Compute space needed for DGELQF - CALL DGELQF( M, N, A, LDA, DUM(1), DUM(1), - $ -1, INFO ) - LWORK_DGELQF = INT( DUM(1) ) -* Compute space needed for DGEBRD - CALL DGEBRD( M, M, A, LDA, S, DUM(1), DUM(1), - $ DUM(1), DUM(1), -1, INFO ) - LWORK_DGEBRD = INT( DUM(1) ) -* Compute space needed for DORMBR - CALL DORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, - $ DUM(1), B, LDB, DUM(1), -1, INFO ) - LWORK_DORMBR = INT( DUM(1) ) -* Compute space needed for DORGBR - CALL DORGBR( 'P', M, M, M, A, LDA, DUM(1), - $ DUM(1), -1, INFO ) - LWORK_DORGBR = INT( DUM(1) ) -* Compute space needed for DORMLQ - CALL DORMLQ( 'L', 'T', N, NRHS, M, A, LDA, DUM(1), - $ B, LDB, DUM(1), -1, INFO ) - LWORK_DORMLQ = INT( DUM(1) ) -* Compute total workspace needed - MAXWRK = M + LWORK_DGELQF - MAXWRK = MAX( MAXWRK, M*M + 4*M + LWORK_DGEBRD ) - MAXWRK = MAX( MAXWRK, M*M + 4*M + LWORK_DORMBR ) - MAXWRK = MAX( MAXWRK, M*M + 4*M + LWORK_DORGBR ) - MAXWRK = MAX( MAXWRK, M*M + M + BDSPAC ) - IF( NRHS.GT.1 ) THEN - MAXWRK = MAX( MAXWRK, M*M + M + M*NRHS ) - ELSE - MAXWRK = MAX( MAXWRK, M*M + 2*M ) - END IF - MAXWRK = MAX( MAXWRK, M + LWORK_DORMLQ ) - ELSE -* -* Path 2 - underdetermined -* -* Compute space needed for DGEBRD - CALL DGEBRD( M, N, A, LDA, S, DUM(1), DUM(1), - $ DUM(1), DUM(1), -1, INFO ) - LWORK_DGEBRD = INT( DUM(1) ) -* Compute space needed for DORMBR - CALL DORMBR( 'Q', 'L', 'T', M, NRHS, M, A, LDA, - $ DUM(1), B, LDB, DUM(1), -1, INFO ) - LWORK_DORMBR = INT( DUM(1) ) -* Compute space needed for DORGBR - CALL DORGBR( 'P', M, N, M, A, LDA, DUM(1), - $ DUM(1), -1, INFO ) - LWORK_DORGBR = INT( DUM(1) ) - MAXWRK = 3*M + LWORK_DGEBRD - MAXWRK = MAX( MAXWRK, 3*M + LWORK_DORMBR ) - MAXWRK = MAX( MAXWRK, 3*M + LWORK_DORGBR ) - MAXWRK = MAX( MAXWRK, BDSPAC ) - MAXWRK = MAX( MAXWRK, N*NRHS ) - END IF - END IF - MAXWRK = MAX( MINWRK, MAXWRK ) - END IF - WORK( 1 ) = MAXWRK -* - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) - $ INFO = -12 - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGELSS', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) THEN - RANK = 0 - RETURN - END IF -* -* Get machine parameters -* - EPS = DLAMCH( 'P' ) - SFMIN = DLAMCH( 'S' ) - SMLNUM = SFMIN / EPS - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) -* -* Scale A if max element outside range [SMLNUM,BIGNUM] -* - ANRM = DLANGE( 'M', M, N, A, LDA, WORK ) - IASCL = 0 - IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN -* -* Scale matrix norm up to SMLNUM -* - CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO ) - IASCL = 1 - ELSE IF( ANRM.GT.BIGNUM ) THEN -* -* Scale matrix norm down to BIGNUM -* - CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO ) - IASCL = 2 - ELSE IF( ANRM.EQ.ZERO ) THEN -* -* Matrix all zero. Return zero solution. -* - CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB ) - CALL DLASET( 'F', MINMN, 1, ZERO, ZERO, S, MINMN ) - RANK = 0 - GO TO 70 - END IF -* -* Scale B if max element outside range [SMLNUM,BIGNUM] -* - BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK ) - IBSCL = 0 - IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN -* -* Scale matrix norm up to SMLNUM -* - CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO ) - IBSCL = 1 - ELSE IF( BNRM.GT.BIGNUM ) THEN -* -* Scale matrix norm down to BIGNUM -* - CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO ) - IBSCL = 2 - END IF -* -* Overdetermined case -* - IF( M.GE.N ) THEN -* -* Path 1 - overdetermined or exactly determined -* - MM = M - IF( M.GE.MNTHR ) THEN -* -* Path 1a - overdetermined, with many more rows than columns -* - MM = N - ITAU = 1 - IWORK = ITAU + N -* -* Compute A=Q*R -* (Workspace: need 2*N, prefer N+N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), - $ LWORK-IWORK+1, INFO ) -* -* Multiply B by transpose(Q) -* (Workspace: need N+NRHS, prefer N+NRHS*NB) -* - CALL DORMQR( 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAU ), B, - $ LDB, WORK( IWORK ), LWORK-IWORK+1, INFO ) -* -* Zero out below R -* - IF( N.GT.1 ) - $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA ) - END IF -* - IE = 1 - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in A -* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) -* - CALL DGEBRD( MM, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, - $ INFO ) -* -* Multiply B by transpose of left bidiagonalizing vectors of R -* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) -* - CALL DORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, WORK( ITAUQ ), - $ B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO ) -* -* Generate right bidiagonalizing vectors of R in A -* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) -* - CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, INFO ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration -* multiply B by transpose of left singular vectors -* compute right singular vectors in A -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, N, 0, NRHS, S, WORK( IE ), A, LDA, DUM, - $ 1, B, LDB, WORK( IWORK ), INFO ) - IF( INFO.NE.0 ) - $ GO TO 70 -* -* Multiply B by reciprocals of singular values -* - THR = MAX( RCOND*S( 1 ), SFMIN ) - IF( RCOND.LT.ZERO ) - $ THR = MAX( EPS*S( 1 ), SFMIN ) - RANK = 0 - DO 10 I = 1, N - IF( S( I ).GT.THR ) THEN - CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB ) - RANK = RANK + 1 - ELSE - CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB ) - END IF - 10 CONTINUE -* -* Multiply B by right singular vectors -* (Workspace: need N, prefer N*NRHS) -* - IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN - CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, A, LDA, B, LDB, ZERO, - $ WORK, LDB ) - CALL DLACPY( 'G', N, NRHS, WORK, LDB, B, LDB ) - ELSE IF( NRHS.GT.1 ) THEN - CHUNK = LWORK / N - DO 20 I = 1, NRHS, CHUNK - BL = MIN( NRHS-I+1, CHUNK ) - CALL DGEMM( 'T', 'N', N, BL, N, ONE, A, LDA, B( 1, I ), - $ LDB, ZERO, WORK, N ) - CALL DLACPY( 'G', N, BL, WORK, N, B( 1, I ), LDB ) - 20 CONTINUE - ELSE - CALL DGEMV( 'T', N, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 ) - CALL DCOPY( N, WORK, 1, B, 1 ) - END IF -* - ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+ - $ MAX( M, 2*M-4, NRHS, N-3*M ) ) THEN -* -* Path 2a - underdetermined, with many more columns than rows -* and sufficient workspace for an efficient algorithm -* - LDWORK = M - IF( LWORK.GE.MAX( 4*M+M*LDA+MAX( M, 2*M-4, NRHS, N-3*M ), - $ M*LDA+M+M*NRHS ) )LDWORK = LDA - ITAU = 1 - IWORK = M + 1 -* -* Compute A=L*Q -* (Workspace: need 2*M, prefer M+M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), - $ LWORK-IWORK+1, INFO ) - IL = IWORK -* -* Copy L to WORK(IL), zeroing out above it -* - CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( IL+LDWORK ), - $ LDWORK ) - IE = IL + LDWORK*M - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in WORK(IL) -* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) -* - CALL DGEBRD( M, M, WORK( IL ), LDWORK, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, INFO ) -* -* Multiply B by transpose of left bidiagonalizing vectors of L -* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) -* - CALL DORMBR( 'Q', 'L', 'T', M, NRHS, M, WORK( IL ), LDWORK, - $ WORK( ITAUQ ), B, LDB, WORK( IWORK ), - $ LWORK-IWORK+1, INFO ) -* -* Generate right bidiagonalizing vectors of R in WORK(IL) -* (Workspace: need M*M+5*M-1, prefer M*M+4*M+(M-1)*NB) -* - CALL DORGBR( 'P', M, M, M, WORK( IL ), LDWORK, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, INFO ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, -* computing right singular vectors of L in WORK(IL) and -* multiplying B by transpose of left singular vectors -* (Workspace: need M*M+M+BDSPAC) -* - CALL DBDSQR( 'U', M, M, 0, NRHS, S, WORK( IE ), WORK( IL ), - $ LDWORK, A, LDA, B, LDB, WORK( IWORK ), INFO ) - IF( INFO.NE.0 ) - $ GO TO 70 -* -* Multiply B by reciprocals of singular values -* - THR = MAX( RCOND*S( 1 ), SFMIN ) - IF( RCOND.LT.ZERO ) - $ THR = MAX( EPS*S( 1 ), SFMIN ) - RANK = 0 - DO 30 I = 1, M - IF( S( I ).GT.THR ) THEN - CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB ) - RANK = RANK + 1 - ELSE - CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB ) - END IF - 30 CONTINUE - IWORK = IE -* -* Multiply B by right singular vectors of L in WORK(IL) -* (Workspace: need M*M+2*M, prefer M*M+M+M*NRHS) -* - IF( LWORK.GE.LDB*NRHS+IWORK-1 .AND. NRHS.GT.1 ) THEN - CALL DGEMM( 'T', 'N', M, NRHS, M, ONE, WORK( IL ), LDWORK, - $ B, LDB, ZERO, WORK( IWORK ), LDB ) - CALL DLACPY( 'G', M, NRHS, WORK( IWORK ), LDB, B, LDB ) - ELSE IF( NRHS.GT.1 ) THEN - CHUNK = ( LWORK-IWORK+1 ) / M - DO 40 I = 1, NRHS, CHUNK - BL = MIN( NRHS-I+1, CHUNK ) - CALL DGEMM( 'T', 'N', M, BL, M, ONE, WORK( IL ), LDWORK, - $ B( 1, I ), LDB, ZERO, WORK( IWORK ), M ) - CALL DLACPY( 'G', M, BL, WORK( IWORK ), M, B( 1, I ), - $ LDB ) - 40 CONTINUE - ELSE - CALL DGEMV( 'T', M, M, ONE, WORK( IL ), LDWORK, B( 1, 1 ), - $ 1, ZERO, WORK( IWORK ), 1 ) - CALL DCOPY( M, WORK( IWORK ), 1, B( 1, 1 ), 1 ) - END IF -* -* Zero out below first M rows of B -* - CALL DLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB ) - IWORK = ITAU + M -* -* Multiply transpose(Q) by B -* (Workspace: need M+NRHS, prefer M+NRHS*NB) -* - CALL DORMLQ( 'L', 'T', N, NRHS, M, A, LDA, WORK( ITAU ), B, - $ LDB, WORK( IWORK ), LWORK-IWORK+1, INFO ) -* - ELSE -* -* Path 2 - remaining underdetermined cases -* - IE = 1 - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize A -* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) -* - CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, - $ INFO ) -* -* Multiply B by transpose of left bidiagonalizing vectors -* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) -* - CALL DORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAUQ ), - $ B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO ) -* -* Generate right bidiagonalizing vectors in A -* (Workspace: need 4*M, prefer 3*M+M*NB) -* - CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, INFO ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, -* computing right singular vectors of A in A and -* multiplying B by transpose of left singular vectors -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'L', M, N, 0, NRHS, S, WORK( IE ), A, LDA, DUM, - $ 1, B, LDB, WORK( IWORK ), INFO ) - IF( INFO.NE.0 ) - $ GO TO 70 -* -* Multiply B by reciprocals of singular values -* - THR = MAX( RCOND*S( 1 ), SFMIN ) - IF( RCOND.LT.ZERO ) - $ THR = MAX( EPS*S( 1 ), SFMIN ) - RANK = 0 - DO 50 I = 1, M - IF( S( I ).GT.THR ) THEN - CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB ) - RANK = RANK + 1 - ELSE - CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB ) - END IF - 50 CONTINUE -* -* Multiply B by right singular vectors of A -* (Workspace: need N, prefer N*NRHS) -* - IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN - CALL DGEMM( 'T', 'N', N, NRHS, M, ONE, A, LDA, B, LDB, ZERO, - $ WORK, LDB ) - CALL DLACPY( 'F', N, NRHS, WORK, LDB, B, LDB ) - ELSE IF( NRHS.GT.1 ) THEN - CHUNK = LWORK / N - DO 60 I = 1, NRHS, CHUNK - BL = MIN( NRHS-I+1, CHUNK ) - CALL DGEMM( 'T', 'N', N, BL, M, ONE, A, LDA, B( 1, I ), - $ LDB, ZERO, WORK, N ) - CALL DLACPY( 'F', N, BL, WORK, N, B( 1, I ), LDB ) - 60 CONTINUE - ELSE - CALL DGEMV( 'T', M, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 ) - CALL DCOPY( N, WORK, 1, B, 1 ) - END IF - END IF -* -* Undo scaling -* - IF( IASCL.EQ.1 ) THEN - CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO ) - CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN, - $ INFO ) - ELSE IF( IASCL.EQ.2 ) THEN - CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO ) - CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN, - $ INFO ) - END IF - IF( IBSCL.EQ.1 ) THEN - CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO ) - ELSE IF( IBSCL.EQ.2 ) THEN - CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO ) - END IF -* - 70 CONTINUE - WORK( 1 ) = MAXWRK - RETURN -* -* End of DGELSS -* - END diff --git a/lib/linalg/dgemm.cpp b/lib/linalg/dgemm.cpp new file mode 100644 index 0000000000..6ffa0440c7 --- /dev/null +++ b/lib/linalg/dgemm.cpp @@ -0,0 +1,173 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dgemm_(char *transa, char *transb, integer *m, integer *n, integer *k, doublereal *alpha, + doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *beta, + doublereal *c__, integer *ldc, ftnlen transa_len, ftnlen transb_len) +{ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, i__3; + integer i__, j, l, info; + logical nota, notb; + doublereal temp; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + integer nrowa, nrowb; + 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; + nota = lsame_(transa, (char *)"N", (ftnlen)1, (ftnlen)1); + notb = lsame_(transb, (char *)"N", (ftnlen)1, (ftnlen)1); + if (nota) { + nrowa = *m; + } else { + nrowa = *k; + } + if (notb) { + nrowb = *k; + } else { + nrowb = *n; + } + info = 0; + if (!nota && !lsame_(transa, (char *)"C", (ftnlen)1, (ftnlen)1) && + !lsame_(transa, (char *)"T", (ftnlen)1, (ftnlen)1)) { + info = 1; + } else if (!notb && !lsame_(transb, (char *)"C", (ftnlen)1, (ftnlen)1) && + !lsame_(transb, (char *)"T", (ftnlen)1, (ftnlen)1)) { + info = 2; + } else if (*m < 0) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*k < 0) { + info = 5; + } else if (*lda < max(1, nrowa)) { + info = 8; + } else if (*ldb < max(1, nrowb)) { + info = 10; + } else if (*ldc < max(1, *m)) { + info = 13; + } + if (info != 0) { + xerbla_((char *)"DGEMM ", &info, (ftnlen)6); + return 0; + } + if (*m == 0 || *n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) { + return 0; + } + if (*alpha == 0.) { + if (*beta == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; + } + } + } + return 0; + } + if (notb) { + if (nota) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; + } + } else if (*beta != 1.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + temp = *alpha * b[l + j * b_dim1]; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] += temp * a[i__ + l * a_dim1]; + } + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + temp += a[l + i__ * a_dim1] * b[l + j * b_dim1]; + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = *alpha * temp; + } else { + c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[i__ + j * c_dim1]; + } + } + } + } + } else { + if (nota) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; + } + } else if (*beta != 1.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + temp = *alpha * b[j + l * b_dim1]; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] += temp * a[i__ + l * a_dim1]; + } + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + temp += a[l + i__ * a_dim1] * b[j + l * b_dim1]; + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = *alpha * temp; + } else { + c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[i__ + j * c_dim1]; + } + } + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dgemm.f b/lib/linalg/dgemm.f deleted file mode 100644 index 8c1b4f2066..0000000000 --- a/lib/linalg/dgemm.f +++ /dev/null @@ -1,379 +0,0 @@ -*> \brief \b DGEMM -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION ALPHA,BETA -* INTEGER K,LDA,LDB,LDC,M,N -* CHARACTER TRANSA,TRANSB -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGEMM performs one of the matrix-matrix operations -*> -*> C := alpha*op( A )*op( B ) + beta*C, -*> -*> where op( X ) is one of -*> -*> op( X ) = X or op( X ) = X**T, -*> -*> alpha and beta are scalars, and A, B and C are matrices, with op( A ) -*> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] TRANSA -*> \verbatim -*> TRANSA is CHARACTER*1 -*> On entry, TRANSA specifies the form of op( A ) to be used in -*> the matrix multiplication as follows: -*> -*> TRANSA = 'N' or 'n', op( A ) = A. -*> -*> TRANSA = 'T' or 't', op( A ) = A**T. -*> -*> TRANSA = 'C' or 'c', op( A ) = A**T. -*> \endverbatim -*> -*> \param[in] TRANSB -*> \verbatim -*> TRANSB is CHARACTER*1 -*> On entry, TRANSB specifies the form of op( B ) to be used in -*> the matrix multiplication as follows: -*> -*> TRANSB = 'N' or 'n', op( B ) = B. -*> -*> TRANSB = 'T' or 't', op( B ) = B**T. -*> -*> TRANSB = 'C' or 'c', op( B ) = B**T. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> On entry, M specifies the number of rows of the matrix -*> op( A ) and of the matrix C. M must be at least zero. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the number of columns of the matrix -*> op( B ) and the number of columns of the matrix C. N must be -*> at least zero. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> On entry, K specifies the number of columns of the matrix -*> op( A ) and the number of rows of the matrix op( B ). K must -*> be at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is DOUBLE PRECISION. -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension ( LDA, ka ), where ka is -*> k when TRANSA = 'N' or 'n', and is m otherwise. -*> Before entry with TRANSA = 'N' or 'n', the leading m by k -*> part of the array A must contain the matrix A, otherwise -*> the leading k by m part of the array A must contain the -*> matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. When TRANSA = 'N' or 'n' then -*> LDA must be at least max( 1, m ), otherwise LDA must be at -*> least max( 1, k ). -*> \endverbatim -*> -*> \param[in] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension ( LDB, kb ), where kb is -*> n when TRANSB = 'N' or 'n', and is k otherwise. -*> Before entry with TRANSB = 'N' or 'n', the leading k by n -*> part of the array B must contain the matrix B, otherwise -*> the leading n by k part of the array B must contain the -*> matrix B. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> On entry, LDB specifies the first dimension of B as declared -*> in the calling (sub) program. When TRANSB = 'N' or 'n' then -*> LDB must be at least max( 1, k ), otherwise LDB must be at -*> least max( 1, n ). -*> \endverbatim -*> -*> \param[in] BETA -*> \verbatim -*> BETA is DOUBLE PRECISION. -*> On entry, BETA specifies the scalar beta. When BETA is -*> supplied as zero then C need not be set on input. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension ( LDC, N ) -*> Before entry, the leading m by n part of the array C must -*> contain the matrix C, except when beta is zero, in which -*> case C need not be set on entry. -*> On exit, the array C is overwritten by the m by n matrix -*> ( alpha*op( A )*op( B ) + beta*C ). -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> On entry, LDC specifies the first dimension of C as declared -*> in the calling (sub) program. LDC must be at least -*> max( 1, m ). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level3 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 3 Blas routine. -*> -*> -- Written on 8-February-1989. -*> Jack Dongarra, Argonne National Laboratory. -*> Iain Duff, AERE Harwell. -*> Jeremy Du Croz, Numerical Algorithms Group Ltd. -*> Sven Hammarling, Numerical Algorithms Group Ltd. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* -* -- Reference BLAS level3 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA,BETA - INTEGER K,LDA,LDB,LDC,M,N - CHARACTER TRANSA,TRANSB -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,J,L,NROWA,NROWB - LOGICAL NOTA,NOTB -* .. -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) -* .. -* -* Set NOTA and NOTB as true if A and B respectively are not -* transposed and set NROWA and NROWB as the number of rows of A -* and B respectively. -* - NOTA = LSAME(TRANSA,'N') - NOTB = LSAME(TRANSB,'N') - IF (NOTA) THEN - NROWA = M - ELSE - NROWA = K - END IF - IF (NOTB) THEN - NROWB = K - ELSE - NROWB = N - END IF -* -* Test the input parameters. -* - INFO = 0 - IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND. - + (.NOT.LSAME(TRANSA,'T'))) THEN - INFO = 1 - ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND. - + (.NOT.LSAME(TRANSB,'T'))) THEN - INFO = 2 - ELSE IF (M.LT.0) THEN - INFO = 3 - ELSE IF (N.LT.0) THEN - INFO = 4 - ELSE IF (K.LT.0) THEN - INFO = 5 - ELSE IF (LDA.LT.MAX(1,NROWA)) THEN - INFO = 8 - ELSE IF (LDB.LT.MAX(1,NROWB)) THEN - INFO = 10 - ELSE IF (LDC.LT.MAX(1,M)) THEN - INFO = 13 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DGEMM ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((M.EQ.0) .OR. (N.EQ.0) .OR. - + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN -* -* And if alpha.eq.zero. -* - IF (ALPHA.EQ.ZERO) THEN - IF (BETA.EQ.ZERO) THEN - DO 20 J = 1,N - DO 10 I = 1,M - C(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1,N - DO 30 I = 1,M - C(I,J) = BETA*C(I,J) - 30 CONTINUE - 40 CONTINUE - END IF - RETURN - END IF -* -* Start the operations. -* - IF (NOTB) THEN - IF (NOTA) THEN -* -* Form C := alpha*A*B + beta*C. -* - DO 90 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 50 I = 1,M - C(I,J) = ZERO - 50 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 60 I = 1,M - C(I,J) = BETA*C(I,J) - 60 CONTINUE - END IF - DO 80 L = 1,K - TEMP = ALPHA*B(L,J) - DO 70 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - ELSE -* -* Form C := alpha*A**T*B + beta*C -* - DO 120 J = 1,N - DO 110 I = 1,M - TEMP = ZERO - DO 100 L = 1,K - TEMP = TEMP + A(L,I)*B(L,J) - 100 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 110 CONTINUE - 120 CONTINUE - END IF - ELSE - IF (NOTA) THEN -* -* Form C := alpha*A*B**T + beta*C -* - DO 170 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 130 I = 1,M - C(I,J) = ZERO - 130 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 140 I = 1,M - C(I,J) = BETA*C(I,J) - 140 CONTINUE - END IF - DO 160 L = 1,K - TEMP = ALPHA*B(J,L) - DO 150 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE - ELSE -* -* Form C := alpha*A**T*B**T + beta*C -* - DO 200 J = 1,N - DO 190 I = 1,M - TEMP = ZERO - DO 180 L = 1,K - TEMP = TEMP + A(L,I)*B(J,L) - 180 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 190 CONTINUE - 200 CONTINUE - END IF - END IF -* - RETURN -* -* End of DGEMM -* - END diff --git a/lib/linalg/dgemv.cpp b/lib/linalg/dgemv.cpp new file mode 100644 index 0000000000..1ec78f9529 --- /dev/null +++ b/lib/linalg/dgemv.cpp @@ -0,0 +1,149 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dgemv_(char *trans, integer *m, integer *n, doublereal *alpha, doublereal *a, integer *lda, + doublereal *x, integer *incx, doublereal *beta, doublereal *y, integer *incy, + ftnlen trans_len) +{ + integer a_dim1, a_offset, i__1, i__2; + integer i__, j, ix, iy, jx, jy, kx, ky, info; + doublereal temp; + integer lenx, leny; + 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_(trans, (char *)"N", (ftnlen)1, (ftnlen)1) && !lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1) && + !lsame_(trans, (char *)"C", (ftnlen)1, (ftnlen)1)) { + info = 1; + } else if (*m < 0) { + info = 2; + } else if (*n < 0) { + info = 3; + } else if (*lda < max(1, *m)) { + info = 6; + } else if (*incx == 0) { + info = 8; + } else if (*incy == 0) { + info = 11; + } + if (info != 0) { + xerbla_((char *)"DGEMV ", &info, (ftnlen)6); + return 0; + } + if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) { + return 0; + } + if (lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1)) { + lenx = *n; + leny = *m; + } else { + lenx = *m; + leny = *n; + } + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (lenx - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (leny - 1) * *incy; + } + if (*beta != 1.) { + if (*incy == 1) { + if (*beta == 0.) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = 0.; + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = *beta * y[i__]; + } + } + } else { + iy = ky; + if (*beta == 0.) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = 0.; + iy += *incy; + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = *beta * y[iy]; + iy += *incy; + } + } + } + } + if (*alpha == 0.) { + return 0; + } + if (lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1)) { + jx = kx; + if (*incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = *alpha * x[jx]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + y[i__] += temp * a[i__ + j * a_dim1]; + } + jx += *incx; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = *alpha * x[jx]; + iy = ky; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + y[iy] += temp * a[i__ + j * a_dim1]; + iy += *incy; + } + jx += *incx; + } + } + } else { + jy = ky; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = 0.; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp += a[i__ + j * a_dim1] * x[i__]; + } + y[jy] += *alpha * temp; + jy += *incy; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = 0.; + ix = kx; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp += a[i__ + j * a_dim1] * x[ix]; + ix += *incx; + } + y[jy] += *alpha * temp; + jy += *incy; + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dgemv.f b/lib/linalg/dgemv.f deleted file mode 100644 index 6625509b3a..0000000000 --- a/lib/linalg/dgemv.f +++ /dev/null @@ -1,327 +0,0 @@ -*> \brief \b DGEMV -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION ALPHA,BETA -* INTEGER INCX,INCY,LDA,M,N -* CHARACTER TRANS -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A(LDA,*),X(*),Y(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGEMV performs one of the matrix-vector operations -*> -*> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, -*> -*> where alpha and beta are scalars, x and y are vectors and A is an -*> m by n matrix. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> On entry, TRANS specifies the operation to be performed as -*> follows: -*> -*> TRANS = 'N' or 'n' y := alpha*A*x + beta*y. -*> -*> TRANS = 'T' or 't' y := alpha*A**T*x + beta*y. -*> -*> TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> On entry, M specifies the number of rows of the matrix A. -*> M must be at least zero. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the number of columns of the matrix A. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is DOUBLE PRECISION. -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension ( LDA, N ) -*> Before entry, the leading m by n part of the array A must -*> contain the matrix of coefficients. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. LDA must be at least -*> max( 1, m ). -*> \endverbatim -*> -*> \param[in] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension at least -*> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' -*> and at least -*> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. -*> Before entry, the incremented array X must contain the -*> vector x. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> On entry, INCX specifies the increment for the elements of -*> X. INCX must not be zero. -*> \endverbatim -*> -*> \param[in] BETA -*> \verbatim -*> BETA is DOUBLE PRECISION. -*> On entry, BETA specifies the scalar beta. When BETA is -*> supplied as zero then Y need not be set on input. -*> \endverbatim -*> -*> \param[in,out] Y -*> \verbatim -*> Y is DOUBLE PRECISION array, dimension at least -*> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' -*> and at least -*> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. -*> Before entry with BETA non-zero, the incremented array Y -*> must contain the vector y. On exit, Y is overwritten by the -*> updated vector y. -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> On entry, INCY specifies the increment for the elements of -*> Y. INCY must not be zero. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level2 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 2 Blas routine. -*> The vector and matrix arguments are not referenced when N = 0, or M = 0 -*> -*> -- Written on 22-October-1986. -*> Jack Dongarra, Argonne National Lab. -*> Jeremy Du Croz, Nag Central Office. -*> Sven Hammarling, Nag Central Office. -*> Richard Hanson, Sandia National Labs. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* -* -- Reference BLAS level2 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA,BETA - INTEGER INCX,INCY,LDA,M,N - CHARACTER TRANS -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),X(*),Y(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. - + .NOT.LSAME(TRANS,'C')) THEN - INFO = 1 - ELSE IF (M.LT.0) THEN - INFO = 2 - ELSE IF (N.LT.0) THEN - INFO = 3 - ELSE IF (LDA.LT.MAX(1,M)) THEN - INFO = 6 - ELSE IF (INCX.EQ.0) THEN - INFO = 8 - ELSE IF (INCY.EQ.0) THEN - INFO = 11 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DGEMV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((M.EQ.0) .OR. (N.EQ.0) .OR. - + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN -* -* Set LENX and LENY, the lengths of the vectors x and y, and set -* up the start points in X and Y. -* - IF (LSAME(TRANS,'N')) THEN - LENX = N - LENY = M - ELSE - LENX = M - LENY = N - END IF - IF (INCX.GT.0) THEN - KX = 1 - ELSE - KX = 1 - (LENX-1)*INCX - END IF - IF (INCY.GT.0) THEN - KY = 1 - ELSE - KY = 1 - (LENY-1)*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* -* First form y := beta*y. -* - IF (BETA.NE.ONE) THEN - IF (INCY.EQ.1) THEN - IF (BETA.EQ.ZERO) THEN - DO 10 I = 1,LENY - Y(I) = ZERO - 10 CONTINUE - ELSE - DO 20 I = 1,LENY - Y(I) = BETA*Y(I) - 20 CONTINUE - END IF - ELSE - IY = KY - IF (BETA.EQ.ZERO) THEN - DO 30 I = 1,LENY - Y(IY) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40 I = 1,LENY - Y(IY) = BETA*Y(IY) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF (ALPHA.EQ.ZERO) RETURN - IF (LSAME(TRANS,'N')) THEN -* -* Form y := alpha*A*x + y. -* - JX = KX - IF (INCY.EQ.1) THEN - DO 60 J = 1,N - TEMP = ALPHA*X(JX) - DO 50 I = 1,M - Y(I) = Y(I) + TEMP*A(I,J) - 50 CONTINUE - JX = JX + INCX - 60 CONTINUE - ELSE - DO 80 J = 1,N - TEMP = ALPHA*X(JX) - IY = KY - DO 70 I = 1,M - Y(IY) = Y(IY) + TEMP*A(I,J) - IY = IY + INCY - 70 CONTINUE - JX = JX + INCX - 80 CONTINUE - END IF - ELSE -* -* Form y := alpha*A**T*x + y. -* - JY = KY - IF (INCX.EQ.1) THEN - DO 100 J = 1,N - TEMP = ZERO - DO 90 I = 1,M - TEMP = TEMP + A(I,J)*X(I) - 90 CONTINUE - Y(JY) = Y(JY) + ALPHA*TEMP - JY = JY + INCY - 100 CONTINUE - ELSE - DO 120 J = 1,N - TEMP = ZERO - IX = KX - DO 110 I = 1,M - TEMP = TEMP + A(I,J)*X(IX) - IX = IX + INCX - 110 CONTINUE - Y(JY) = Y(JY) + ALPHA*TEMP - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of DGEMV -* - END diff --git a/lib/linalg/dgeqr2.cpp b/lib/linalg/dgeqr2.cpp new file mode 100644 index 0000000000..5c3b885bfb --- /dev/null +++ b/lib/linalg/dgeqr2.cpp @@ -0,0 +1,54 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +int dgeqr2_(integer *m, integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal *work, + integer *info) +{ + integer a_dim1, a_offset, i__1, i__2, i__3; + integer i__, k; + 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 (*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 *)"DGEQR2", &i__1, (ftnlen)6); + return 0; + } + k = min(*m, *n); + i__1 = k; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *m - i__ + 1; + i__3 = i__ + 1; + dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3, *m) + i__ * a_dim1], &c__1, &tau[i__]); + if (i__ < *n) { + aii = a[i__ + i__ * a_dim1]; + a[i__ + i__ * a_dim1] = 1.; + i__2 = *m - i__ + 1; + i__3 = *n - i__; + dlarf_((char *)"Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &tau[i__], + &a[i__ + (i__ + 1) * a_dim1], lda, &work[1], (ftnlen)4); + a[i__ + i__ * a_dim1] = aii; + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dgeqr2.f b/lib/linalg/dgeqr2.f deleted file mode 100644 index 5791b3a915..0000000000 --- a/lib/linalg/dgeqr2.f +++ /dev/null @@ -1,198 +0,0 @@ -*> \brief \b DGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGEQR2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGEQR2 computes a QR factorization of a real m-by-n matrix A: -*> -*> A = Q * ( R ), -*> ( 0 ) -*> -*> where: -*> -*> Q is a m-by-m orthogonal matrix; -*> R is an upper-triangular n-by-n matrix; -*> 0 is a (m-n)-by-n zero matrix, if m > n. -*> -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the m by n matrix A. -*> On exit, the elements on and above the diagonal of the array -*> contain the min(m,n) by n upper trapezoidal matrix R (R is -*> upper triangular if m >= n); the elements below the diagonal, -*> with the array TAU, represent the orthogonal matrix Q as a -*> product of elementary reflectors (see Further Details). -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[out] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) -*> The scalar factors of the elementary reflectors (see Further -*> Details). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (N) -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleGEcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The matrix Q is represented as a product of elementary reflectors -*> -*> Q = H(1) H(2) . . . H(k), where k = min(m,n). -*> -*> Each H(i) has the form -*> -*> H(i) = I - tau * v * v**T -*> -*> where tau is a real scalar, and v is a real vector with -*> v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), -*> and tau in TAU(i). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, K - DOUBLE PRECISION AII -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DLARFG, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGEQR2', -INFO ) - RETURN - END IF -* - K = MIN( M, N ) -* - DO 10 I = 1, K -* -* Generate elementary reflector H(i) to annihilate A(i+1:m,i) -* - CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, - $ TAU( I ) ) - IF( I.LT.N ) THEN -* -* Apply H(i) to A(i:m,i+1:n) from the left -* - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), - $ A( I, I+1 ), LDA, WORK ) - A( I, I ) = AII - END IF - 10 CONTINUE - RETURN -* -* End of DGEQR2 -* - END diff --git a/lib/linalg/dgeqrf.cpp b/lib/linalg/dgeqrf.cpp new file mode 100644 index 0000000000..6c70b9f7f7 --- /dev/null +++ b/lib/linalg/dgeqrf.cpp @@ -0,0 +1,113 @@ +#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; +int dgeqrf_(integer *m, integer *n, 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__, k, ib, nb, nx, iws, nbmin, iinfo; + extern int dgeqr2_(integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *), + dlarfb_(char *, char *, char *, char *, integer *, integer *, integer *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, ftnlen, ftnlen, ftnlen, ftnlen), + dlarft_(char *, char *, integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *, 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; + k = min(*m, *n); + *info = 0; + nb = ilaenv_(&c__1, (char *)"DGEQRF", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < max(1, *m)) { + *info = -4; + } else if (!lquery) { + if (*lwork <= 0 || *m > 0 && *lwork < max(1, *n)) { + *info = -7; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DGEQRF", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + if (k == 0) { + lwkopt = 1; + } else { + lwkopt = *n * nb; + } + work[1] = (doublereal)lwkopt; + return 0; + } + if (k == 0) { + work[1] = 1.; + return 0; + } + nbmin = 2; + nx = 0; + iws = *n; + if (nb > 1 && nb < k) { + i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DGEQRF", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); + nx = max(i__1, i__2); + if (nx < k) { + ldwork = *n; + iws = ldwork * nb; + if (*lwork < iws) { + nb = *lwork / ldwork; + i__1 = 2, + i__2 = ilaenv_(&c__2, (char *)"DGEQRF", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); + nbmin = max(i__1, i__2); + } + } + } + if (nb >= nbmin && nb < k && nx < k) { + i__1 = k - nx; + i__2 = nb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + i__3 = k - i__ + 1; + ib = min(i__3, nb); + i__3 = *m - i__ + 1; + dgeqr2_(&i__3, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1], &iinfo); + if (i__ + ib <= *n) { + i__3 = *m - i__ + 1; + dlarft_((char *)"Forward", (char *)"Columnwise", &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], + &work[1], &ldwork, (ftnlen)7, (ftnlen)10); + i__3 = *m - i__ + 1; + i__4 = *n - i__ - ib + 1; + dlarfb_((char *)"Left", (char *)"Transpose", (char *)"Forward", (char *)"Columnwise", &i__3, &i__4, &ib, + &a[i__ + i__ * a_dim1], lda, &work[1], &ldwork, + &a[i__ + (i__ + ib) * a_dim1], lda, &work[ib + 1], &ldwork, (ftnlen)4, + (ftnlen)9, (ftnlen)7, (ftnlen)10); + } + } + } else { + i__ = 1; + } + if (i__ <= k) { + i__2 = *m - i__ + 1; + i__1 = *n - i__ + 1; + dgeqr2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1], &iinfo); + } + work[1] = (doublereal)iws; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dgeqrf.f b/lib/linalg/dgeqrf.f deleted file mode 100644 index 705e939286..0000000000 --- a/lib/linalg/dgeqrf.f +++ /dev/null @@ -1,282 +0,0 @@ -*> \brief \b DGEQRF -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGEQRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, LDA, LWORK, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGEQRF computes a QR factorization of a real M-by-N matrix A: -*> -*> A = Q * ( R ), -*> ( 0 ) -*> -*> where: -*> -*> Q is a M-by-M orthogonal matrix; -*> R is an upper-triangular N-by-N matrix; -*> 0 is a (M-N)-by-N zero matrix, if M > N. -*> -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the M-by-N matrix A. -*> On exit, the elements on and above the diagonal of the array -*> contain the min(M,N)-by-N upper trapezoidal matrix R (R is -*> upper triangular if m >= n); the elements below the diagonal, -*> with the array TAU, represent the orthogonal matrix Q as a -*> product of min(m,n) elementary reflectors (see Further -*> Details). -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[out] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) -*> The scalar factors of the elementary reflectors (see Further -*> Details). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. -*> LWORK >= 1, if MIN(M,N) = 0, and LWORK >= N, otherwise. -*> For optimum performance LWORK >= N*NB, where NB is -*> the optimal blocksize. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal size of the WORK array, returns -*> this value as the first entry of the WORK array, and no error -*> message related to LWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleGEcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The matrix Q is represented as a product of elementary reflectors -*> -*> Q = H(1) H(2) . . . H(k), where k = min(m,n). -*> -*> Each H(i) has the form -*> -*> H(i) = I - tau * v * v**T -*> -*> where tau is a real scalar, and v is a real vector with -*> v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), -*> and tau in TAU(i). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, - $ NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL DGEQR2, DLARFB, DLARFT, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - K = MIN( M, N ) - INFO = 0 - NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - ELSE IF( .NOT.LQUERY ) THEN - IF( LWORK.LE.0 .OR. ( M.GT.0 .AND. LWORK.LT.MAX( 1, N ) ) ) - $ INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGEQRF', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - IF( K.EQ.0 ) THEN - LWKOPT = 1 - ELSE - LWKOPT = N*NB - END IF - WORK( 1 ) = LWKOPT - RETURN - END IF -* -* Quick return if possible -* - IF( K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - NX = 0 - IWS = N - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'DGEQRF', ' ', M, N, -1, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', M, N, -1, - $ -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code initially -* - DO 10 I = 1, K - NX, NB - IB = MIN( K-I+1, NB ) -* -* Compute the QR factorization of the current block -* A(i:m,i:i+ib-1) -* - CALL DGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) - IF( I+IB.LE.N ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, - $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H**T to A(i:m,i+ib:n) from the left -* - CALL DLARFB( 'Left', 'Transpose', 'Forward', - $ 'Columnwise', M-I+1, N-I-IB+1, IB, - $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), - $ LDA, WORK( IB+1 ), LDWORK ) - END IF - 10 CONTINUE - ELSE - I = 1 - END IF -* -* Use unblocked code to factor the last or only block. -* - IF( I.LE.K ) - $ CALL DGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) -* - WORK( 1 ) = IWS - RETURN -* -* End of DGEQRF -* - END diff --git a/lib/linalg/dger.cpp b/lib/linalg/dger.cpp new file mode 100644 index 0000000000..46447e29f3 --- /dev/null +++ b/lib/linalg/dger.cpp @@ -0,0 +1,77 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dger_(integer *m, integer *n, doublereal *alpha, doublereal *x, integer *incx, doublereal *y, + integer *incy, doublereal *a, integer *lda) +{ + integer a_dim1, a_offset, i__1, i__2; + integer i__, j, ix, jy, kx, info; + doublereal temp; + extern int xerbla_(char *, integer *, ftnlen); + --x; + --y; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + info = 0; + if (*m < 0) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 5; + } else if (*incy == 0) { + info = 7; + } else if (*lda < max(1, *m)) { + info = 9; + } + if (info != 0) { + xerbla_((char *)"DGER ", &info, (ftnlen)6); + return 0; + } + if (*m == 0 || *n == 0 || *alpha == 0.) { + return 0; + } + if (*incy > 0) { + jy = 1; + } else { + jy = 1 - (*n - 1) * *incy; + } + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (y[jy] != 0.) { + temp = *alpha * y[jy]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] += x[i__] * temp; + } + } + jy += *incy; + } + } else { + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*m - 1) * *incx; + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (y[jy] != 0.) { + temp = *alpha * y[jy]; + ix = kx; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] += x[ix] * temp; + ix += *incx; + } + } + jy += *incy; + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dger.f b/lib/linalg/dger.f deleted file mode 100644 index 8c19cb4e41..0000000000 --- a/lib/linalg/dger.f +++ /dev/null @@ -1,224 +0,0 @@ -*> \brief \b DGER -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION ALPHA -* INTEGER INCX,INCY,LDA,M,N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A(LDA,*),X(*),Y(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGER performs the rank 1 operation -*> -*> A := alpha*x*y**T + A, -*> -*> where alpha is a scalar, x is an m element vector, y is an n element -*> vector and A is an m by n matrix. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> On entry, M specifies the number of rows of the matrix A. -*> M must be at least zero. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the number of columns of the matrix A. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is DOUBLE PRECISION. -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension at least -*> ( 1 + ( m - 1 )*abs( INCX ) ). -*> Before entry, the incremented array X must contain the m -*> element vector x. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> On entry, INCX specifies the increment for the elements of -*> X. INCX must not be zero. -*> \endverbatim -*> -*> \param[in] Y -*> \verbatim -*> Y is DOUBLE PRECISION array, dimension at least -*> ( 1 + ( n - 1 )*abs( INCY ) ). -*> Before entry, the incremented array Y must contain the n -*> element vector y. -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> On entry, INCY specifies the increment for the elements of -*> Y. INCY must not be zero. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension ( LDA, N ) -*> Before entry, the leading m by n part of the array A must -*> contain the matrix of coefficients. On exit, A is -*> overwritten by the updated matrix. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. LDA must be at least -*> max( 1, m ). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level2 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 2 Blas routine. -*> -*> -- Written on 22-October-1986. -*> Jack Dongarra, Argonne National Lab. -*> Jeremy Du Croz, Nag Central Office. -*> Sven Hammarling, Nag Central Office. -*> Richard Hanson, Sandia National Labs. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* -* -- Reference BLAS level2 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX,INCY,LDA,M,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),X(*),Y(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER (ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,IX,J,JY,KX -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (M.LT.0) THEN - INFO = 1 - ELSE IF (N.LT.0) THEN - INFO = 2 - ELSE IF (INCX.EQ.0) THEN - INFO = 5 - ELSE IF (INCY.EQ.0) THEN - INFO = 7 - ELSE IF (LDA.LT.MAX(1,M)) THEN - INFO = 9 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DGER ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF (INCY.GT.0) THEN - JY = 1 - ELSE - JY = 1 - (N-1)*INCY - END IF - IF (INCX.EQ.1) THEN - DO 20 J = 1,N - IF (Y(JY).NE.ZERO) THEN - TEMP = ALPHA*Y(JY) - DO 10 I = 1,M - A(I,J) = A(I,J) + X(I)*TEMP - 10 CONTINUE - END IF - JY = JY + INCY - 20 CONTINUE - ELSE - IF (INCX.GT.0) THEN - KX = 1 - ELSE - KX = 1 - (M-1)*INCX - END IF - DO 40 J = 1,N - IF (Y(JY).NE.ZERO) THEN - TEMP = ALPHA*Y(JY) - IX = KX - DO 30 I = 1,M - A(I,J) = A(I,J) + X(IX)*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JY = JY + INCY - 40 CONTINUE - END IF -* - RETURN -* -* End of DGER -* - END diff --git a/lib/linalg/dgesv.cpp b/lib/linalg/dgesv.cpp new file mode 100644 index 0000000000..41f85f4566 --- /dev/null +++ b/lib/linalg/dgesv.cpp @@ -0,0 +1,44 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dgesv_(integer *n, integer *nrhs, doublereal *a, integer *lda, integer *ipiv, doublereal *b, + integer *ldb, integer *info) +{ + integer a_dim1, a_offset, b_dim1, b_offset, i__1; + extern int dgetrf_(integer *, integer *, doublereal *, integer *, integer *, integer *), + xerbla_(char *, integer *, ftnlen), + dgetrs_(char *, integer *, integer *, doublereal *, integer *, integer *, doublereal *, + integer *, 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; + if (*n < 0) { + *info = -1; + } else if (*nrhs < 0) { + *info = -2; + } else if (*lda < max(1, *n)) { + *info = -4; + } else if (*ldb < max(1, *n)) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DGESV ", &i__1, (ftnlen)6); + return 0; + } + dgetrf_(n, n, &a[a_offset], lda, &ipiv[1], info); + if (*info == 0) { + dgetrs_((char *)"No transpose", n, nrhs, &a[a_offset], lda, &ipiv[1], &b[b_offset], ldb, info, + (ftnlen)12); + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dgesv.f b/lib/linalg/dgesv.f deleted file mode 100644 index 3609c52f47..0000000000 --- a/lib/linalg/dgesv.f +++ /dev/null @@ -1,176 +0,0 @@ -*> \brief DGESV computes the solution to system of linear equations A * X = B for GE matrices -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGESV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGESV computes the solution to a real system of linear equations -*> A * X = B, -*> where A is an N-by-N matrix and X and B are N-by-NRHS matrices. -*> -*> The LU decomposition with partial pivoting and row interchanges is -*> used to factor A as -*> A = P * L * U, -*> where P is a permutation matrix, L is unit lower triangular, and U is -*> upper triangular. The factored form of A is then used to solve the -*> system of equations A * X = B. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of linear equations, i.e., the order of the -*> matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in] NRHS -*> \verbatim -*> NRHS is INTEGER -*> The number of right hand sides, i.e., the number of columns -*> of the matrix B. NRHS >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the N-by-N coefficient matrix A. -*> On exit, the factors L and U from the factorization -*> A = P*L*U; the unit diagonal elements of L are not stored. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[out] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (N) -*> The pivot indices that define the permutation matrix P; -*> row i of the matrix was interchanged with row IPIV(i). -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) -*> On entry, the N-by-NRHS matrix of right hand side matrix B. -*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >= max(1,N). -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> > 0: if INFO = i, U(i,i) is exactly zero. The factorization -*> has been completed, but the factor U is exactly -*> singular, so the solution could not be computed. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleGEsolve -* -* ===================================================================== - SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* -- LAPACK driver routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* ===================================================================== -* -* .. External Subroutines .. - EXTERNAL DGETRF, DGETRS, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGESV ', -INFO ) - RETURN - END IF -* -* Compute the LU factorization of A. -* - CALL DGETRF( N, N, A, LDA, IPIV, INFO ) - IF( INFO.EQ.0 ) THEN -* -* Solve the system A*X = B, overwriting B with X. -* - CALL DGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB, - $ INFO ) - END IF - RETURN -* -* End of DGESV -* - END diff --git a/lib/linalg/dgesvd.cpp b/lib/linalg/dgesvd.cpp new file mode 100644 index 0000000000..43765bce16 --- /dev/null +++ b/lib/linalg/dgesvd.cpp @@ -0,0 +1,1906 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__6 = 6; +static integer c__0 = 0; +static integer c__2 = 2; +static integer c_n1 = -1; +static doublereal c_b57 = 0.; +static integer c__1 = 1; +static doublereal c_b79 = 1.; +int dgesvd_(char *jobu, char *jobvt, integer *m, integer *n, doublereal *a, integer *lda, + doublereal *s, doublereal *u, integer *ldu, doublereal *vt, integer *ldvt, + doublereal *work, integer *lwork, integer *info, ftnlen jobu_len, ftnlen jobvt_len) +{ + address a__1[2]; + integer a_dim1, a_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1[2], i__2, i__3, i__4; + char ch__1[2]; + int s_lmp_cat(char *, char **, integer *, integer *, ftnlen); + double sqrt(doublereal); + integer i__, ie, ir, iu, blk, ncu; + doublereal dum[1], eps; + integer nru, iscl; + doublereal anrm; + integer ierr, itau, ncvt, nrvt, lwork_dgebrd__, lwork_dgelqf__, lwork_dgeqrf__; + 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, iwork; + logical wntua, wntva, wntun, wntuo, wntvn, wntvo, wntus, wntvs; + extern int 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), + dbdsqr_(char *, integer *, integer *, integer *, integer *, doublereal *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, ftnlen), + dorgbr_(char *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *, integer *, ftnlen); + doublereal bignum; + extern int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, + ftnlen, ftnlen); + 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 ldwrkr, minwrk, ldwrku, maxwrk; + doublereal smlnum; + logical lquery, wntuas, wntvas; + integer lwork_dorgbr_p__, lwork_dorgbr_q__, lwork_dorglq_m__, lwork_dorglq_n__, + lwork_dorgqr_m__, lwork_dorgqr_n__; + 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; + *info = 0; + minmn = min(*m, *n); + wntua = lsame_(jobu, (char *)"A", (ftnlen)1, (ftnlen)1); + wntus = lsame_(jobu, (char *)"S", (ftnlen)1, (ftnlen)1); + wntuas = wntua || wntus; + wntuo = lsame_(jobu, (char *)"O", (ftnlen)1, (ftnlen)1); + wntun = lsame_(jobu, (char *)"N", (ftnlen)1, (ftnlen)1); + wntva = lsame_(jobvt, (char *)"A", (ftnlen)1, (ftnlen)1); + wntvs = lsame_(jobvt, (char *)"S", (ftnlen)1, (ftnlen)1); + wntvas = wntva || wntvs; + wntvo = lsame_(jobvt, (char *)"O", (ftnlen)1, (ftnlen)1); + wntvn = lsame_(jobvt, (char *)"N", (ftnlen)1, (ftnlen)1); + lquery = *lwork == -1; + if (!(wntua || wntus || wntuo || wntun)) { + *info = -1; + } else if (!(wntva || wntvs || wntvo || wntvn) || wntvo && wntuo) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*lda < max(1, *m)) { + *info = -6; + } else if (*ldu < 1 || wntuas && *ldu < *m) { + *info = -9; + } else if (*ldvt < 1 || wntva && *ldvt < *n || wntvs && *ldvt < minmn) { + *info = -11; + } + if (*info == 0) { + minwrk = 1; + maxwrk = 1; + if (*m >= *n && minmn > 0) { + i__1[0] = 1, a__1[0] = jobu; + i__1[1] = 1, a__1[1] = jobvt; + s_lmp_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); + mnthr = ilaenv_(&c__6, (char *)"DGESVD", ch__1, m, n, &c__0, &c__0, (ftnlen)6, (ftnlen)2); + bdspac = *n * 5; + dgeqrf_(m, n, &a[a_offset], lda, dum, dum, &c_n1, &ierr); + lwork_dgeqrf__ = (integer)dum[0]; + dorgqr_(m, n, n, &a[a_offset], lda, dum, dum, &c_n1, &ierr); + lwork_dorgqr_n__ = (integer)dum[0]; + dorgqr_(m, m, n, &a[a_offset], lda, dum, dum, &c_n1, &ierr); + lwork_dorgqr_m__ = (integer)dum[0]; + dgebrd_(n, n, &a[a_offset], lda, &s[1], dum, dum, dum, dum, &c_n1, &ierr); + lwork_dgebrd__ = (integer)dum[0]; + dorgbr_((char *)"P", n, n, n, &a[a_offset], lda, dum, dum, &c_n1, &ierr, (ftnlen)1); + lwork_dorgbr_p__ = (integer)dum[0]; + dorgbr_((char *)"Q", n, n, n, &a[a_offset], lda, dum, dum, &c_n1, &ierr, (ftnlen)1); + lwork_dorgbr_q__ = (integer)dum[0]; + if (*m >= mnthr) { + if (wntun) { + maxwrk = *n + lwork_dgeqrf__; + i__2 = maxwrk, i__3 = *n * 3 + lwork_dgebrd__; + maxwrk = max(i__2, i__3); + if (wntvo || wntvas) { + i__2 = maxwrk, i__3 = *n * 3 + lwork_dorgbr_p__; + maxwrk = max(i__2, i__3); + } + maxwrk = max(maxwrk, bdspac); + i__2 = *n << 2; + minwrk = max(i__2, bdspac); + } else if (wntuo && wntvn) { + wrkbl = *n + lwork_dgeqrf__; + i__2 = wrkbl, i__3 = *n + lwork_dorgqr_n__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dgebrd__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_q__; + wrkbl = max(i__2, i__3); + wrkbl = max(wrkbl, bdspac); + i__2 = *n * *n + wrkbl, i__3 = *n * *n + *m * *n + *n; + maxwrk = max(i__2, i__3); + i__2 = *n * 3 + *m; + minwrk = max(i__2, bdspac); + } else if (wntuo && wntvas) { + wrkbl = *n + lwork_dgeqrf__; + i__2 = wrkbl, i__3 = *n + lwork_dorgqr_n__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dgebrd__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_q__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_p__; + wrkbl = max(i__2, i__3); + wrkbl = max(wrkbl, bdspac); + i__2 = *n * *n + wrkbl, i__3 = *n * *n + *m * *n + *n; + maxwrk = max(i__2, i__3); + i__2 = *n * 3 + *m; + minwrk = max(i__2, bdspac); + } else if (wntus && wntvn) { + wrkbl = *n + lwork_dgeqrf__; + i__2 = wrkbl, i__3 = *n + lwork_dorgqr_n__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dgebrd__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_q__; + wrkbl = max(i__2, i__3); + wrkbl = max(wrkbl, bdspac); + maxwrk = *n * *n + wrkbl; + i__2 = *n * 3 + *m; + minwrk = max(i__2, bdspac); + } else if (wntus && wntvo) { + wrkbl = *n + lwork_dgeqrf__; + i__2 = wrkbl, i__3 = *n + lwork_dorgqr_n__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dgebrd__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_q__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_p__; + wrkbl = max(i__2, i__3); + wrkbl = max(wrkbl, bdspac); + maxwrk = (*n << 1) * *n + wrkbl; + i__2 = *n * 3 + *m; + minwrk = max(i__2, bdspac); + } else if (wntus && wntvas) { + wrkbl = *n + lwork_dgeqrf__; + i__2 = wrkbl, i__3 = *n + lwork_dorgqr_n__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dgebrd__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_q__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_p__; + wrkbl = max(i__2, i__3); + wrkbl = max(wrkbl, bdspac); + maxwrk = *n * *n + wrkbl; + i__2 = *n * 3 + *m; + minwrk = max(i__2, bdspac); + } else if (wntua && wntvn) { + wrkbl = *n + lwork_dgeqrf__; + i__2 = wrkbl, i__3 = *n + lwork_dorgqr_m__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dgebrd__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_q__; + wrkbl = max(i__2, i__3); + wrkbl = max(wrkbl, bdspac); + maxwrk = *n * *n + wrkbl; + i__2 = *n * 3 + *m; + minwrk = max(i__2, bdspac); + } else if (wntua && wntvo) { + wrkbl = *n + lwork_dgeqrf__; + i__2 = wrkbl, i__3 = *n + lwork_dorgqr_m__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dgebrd__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_q__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_p__; + wrkbl = max(i__2, i__3); + wrkbl = max(wrkbl, bdspac); + maxwrk = (*n << 1) * *n + wrkbl; + i__2 = *n * 3 + *m; + minwrk = max(i__2, bdspac); + } else if (wntua && wntvas) { + wrkbl = *n + lwork_dgeqrf__; + i__2 = wrkbl, i__3 = *n + lwork_dorgqr_m__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dgebrd__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_q__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *n * 3 + lwork_dorgbr_p__; + wrkbl = max(i__2, i__3); + wrkbl = max(wrkbl, bdspac); + maxwrk = *n * *n + wrkbl; + i__2 = *n * 3 + *m; + minwrk = max(i__2, bdspac); + } + } else { + dgebrd_(m, n, &a[a_offset], lda, &s[1], dum, dum, dum, dum, &c_n1, &ierr); + lwork_dgebrd__ = (integer)dum[0]; + maxwrk = *n * 3 + lwork_dgebrd__; + if (wntus || wntuo) { + dorgbr_((char *)"Q", m, n, n, &a[a_offset], lda, dum, dum, &c_n1, &ierr, (ftnlen)1); + lwork_dorgbr_q__ = (integer)dum[0]; + i__2 = maxwrk, i__3 = *n * 3 + lwork_dorgbr_q__; + maxwrk = max(i__2, i__3); + } + if (wntua) { + dorgbr_((char *)"Q", m, m, n, &a[a_offset], lda, dum, dum, &c_n1, &ierr, (ftnlen)1); + lwork_dorgbr_q__ = (integer)dum[0]; + i__2 = maxwrk, i__3 = *n * 3 + lwork_dorgbr_q__; + maxwrk = max(i__2, i__3); + } + if (!wntvn) { + i__2 = maxwrk, i__3 = *n * 3 + lwork_dorgbr_p__; + maxwrk = max(i__2, i__3); + } + maxwrk = max(maxwrk, bdspac); + i__2 = *n * 3 + *m; + minwrk = max(i__2, bdspac); + } + } else if (minmn > 0) { + i__1[0] = 1, a__1[0] = jobu; + i__1[1] = 1, a__1[1] = jobvt; + s_lmp_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); + mnthr = ilaenv_(&c__6, (char *)"DGESVD", ch__1, m, n, &c__0, &c__0, (ftnlen)6, (ftnlen)2); + bdspac = *m * 5; + dgelqf_(m, n, &a[a_offset], lda, dum, dum, &c_n1, &ierr); + lwork_dgelqf__ = (integer)dum[0]; + dorglq_(n, n, m, dum, n, dum, dum, &c_n1, &ierr); + lwork_dorglq_n__ = (integer)dum[0]; + dorglq_(m, n, m, &a[a_offset], lda, dum, dum, &c_n1, &ierr); + lwork_dorglq_m__ = (integer)dum[0]; + dgebrd_(m, m, &a[a_offset], lda, &s[1], dum, dum, dum, dum, &c_n1, &ierr); + lwork_dgebrd__ = (integer)dum[0]; + dorgbr_((char *)"P", m, m, m, &a[a_offset], n, dum, dum, &c_n1, &ierr, (ftnlen)1); + lwork_dorgbr_p__ = (integer)dum[0]; + dorgbr_((char *)"Q", m, m, m, &a[a_offset], n, dum, dum, &c_n1, &ierr, (ftnlen)1); + lwork_dorgbr_q__ = (integer)dum[0]; + if (*n >= mnthr) { + if (wntvn) { + maxwrk = *m + lwork_dgelqf__; + i__2 = maxwrk, i__3 = *m * 3 + lwork_dgebrd__; + maxwrk = max(i__2, i__3); + if (wntuo || wntuas) { + i__2 = maxwrk, i__3 = *m * 3 + lwork_dorgbr_q__; + maxwrk = max(i__2, i__3); + } + maxwrk = max(maxwrk, bdspac); + i__2 = *m << 2; + minwrk = max(i__2, bdspac); + } else if (wntvo && wntun) { + wrkbl = *m + lwork_dgelqf__; + i__2 = wrkbl, i__3 = *m + lwork_dorglq_m__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dgebrd__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_p__; + wrkbl = max(i__2, i__3); + wrkbl = max(wrkbl, bdspac); + i__2 = *m * *m + wrkbl, i__3 = *m * *m + *m * *n + *m; + maxwrk = max(i__2, i__3); + i__2 = *m * 3 + *n; + minwrk = max(i__2, bdspac); + } else if (wntvo && wntuas) { + wrkbl = *m + lwork_dgelqf__; + i__2 = wrkbl, i__3 = *m + lwork_dorglq_m__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dgebrd__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_p__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_q__; + wrkbl = max(i__2, i__3); + wrkbl = max(wrkbl, bdspac); + i__2 = *m * *m + wrkbl, i__3 = *m * *m + *m * *n + *m; + maxwrk = max(i__2, i__3); + i__2 = *m * 3 + *n; + minwrk = max(i__2, bdspac); + } else if (wntvs && wntun) { + wrkbl = *m + lwork_dgelqf__; + i__2 = wrkbl, i__3 = *m + lwork_dorglq_m__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dgebrd__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_p__; + wrkbl = max(i__2, i__3); + wrkbl = max(wrkbl, bdspac); + maxwrk = *m * *m + wrkbl; + i__2 = *m * 3 + *n; + minwrk = max(i__2, bdspac); + } else if (wntvs && wntuo) { + wrkbl = *m + lwork_dgelqf__; + i__2 = wrkbl, i__3 = *m + lwork_dorglq_m__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dgebrd__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_p__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_q__; + wrkbl = max(i__2, i__3); + wrkbl = max(wrkbl, bdspac); + maxwrk = (*m << 1) * *m + wrkbl; + i__2 = *m * 3 + *n; + minwrk = max(i__2, bdspac); + } else if (wntvs && wntuas) { + wrkbl = *m + lwork_dgelqf__; + i__2 = wrkbl, i__3 = *m + lwork_dorglq_m__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dgebrd__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_p__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_q__; + wrkbl = max(i__2, i__3); + wrkbl = max(wrkbl, bdspac); + maxwrk = *m * *m + wrkbl; + i__2 = *m * 3 + *n; + minwrk = max(i__2, bdspac); + } else if (wntva && wntun) { + wrkbl = *m + lwork_dgelqf__; + i__2 = wrkbl, i__3 = *m + lwork_dorglq_n__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dgebrd__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_p__; + wrkbl = max(i__2, i__3); + wrkbl = max(wrkbl, bdspac); + maxwrk = *m * *m + wrkbl; + i__2 = *m * 3 + *n; + minwrk = max(i__2, bdspac); + } else if (wntva && wntuo) { + wrkbl = *m + lwork_dgelqf__; + i__2 = wrkbl, i__3 = *m + lwork_dorglq_n__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dgebrd__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_p__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_q__; + wrkbl = max(i__2, i__3); + wrkbl = max(wrkbl, bdspac); + maxwrk = (*m << 1) * *m + wrkbl; + i__2 = *m * 3 + *n; + minwrk = max(i__2, bdspac); + } else if (wntva && wntuas) { + wrkbl = *m + lwork_dgelqf__; + i__2 = wrkbl, i__3 = *m + lwork_dorglq_n__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dgebrd__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_p__; + wrkbl = max(i__2, i__3); + i__2 = wrkbl, i__3 = *m * 3 + lwork_dorgbr_q__; + wrkbl = max(i__2, i__3); + wrkbl = max(wrkbl, bdspac); + maxwrk = *m * *m + wrkbl; + i__2 = *m * 3 + *n; + minwrk = max(i__2, bdspac); + } + } else { + dgebrd_(m, n, &a[a_offset], lda, &s[1], dum, dum, dum, dum, &c_n1, &ierr); + lwork_dgebrd__ = (integer)dum[0]; + maxwrk = *m * 3 + lwork_dgebrd__; + if (wntvs || wntvo) { + dorgbr_((char *)"P", m, n, m, &a[a_offset], n, dum, dum, &c_n1, &ierr, (ftnlen)1); + lwork_dorgbr_p__ = (integer)dum[0]; + i__2 = maxwrk, i__3 = *m * 3 + lwork_dorgbr_p__; + maxwrk = max(i__2, i__3); + } + if (wntva) { + dorgbr_((char *)"P", n, n, m, &a[a_offset], n, dum, dum, &c_n1, &ierr, (ftnlen)1); + lwork_dorgbr_p__ = (integer)dum[0]; + i__2 = maxwrk, i__3 = *m * 3 + lwork_dorgbr_p__; + maxwrk = max(i__2, i__3); + } + if (!wntun) { + i__2 = maxwrk, i__3 = *m * 3 + lwork_dorgbr_q__; + maxwrk = max(i__2, i__3); + } + maxwrk = max(maxwrk, bdspac); + i__2 = *m * 3 + *n; + minwrk = max(i__2, bdspac); + } + } + maxwrk = max(maxwrk, minwrk); + work[1] = (doublereal)maxwrk; + if (*lwork < minwrk && !lquery) { + *info = -13; + } + } + if (*info != 0) { + i__2 = -(*info); + xerbla_((char *)"DGESVD", &i__2, (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 (wntun) { + itau = 1; + iwork = itau + *n; + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + if (*n > 1) { + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &a[a_dim1 + 2], lda, (ftnlen)1); + } + ie = 1; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &work[itaup], + &work[iwork], &i__2, &ierr); + ncvt = 0; + if (wntvo || wntvas) { + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", n, n, n, &a[a_offset], lda, &work[itaup], &work[iwork], &i__2, + &ierr, (ftnlen)1); + ncvt = *n; + } + iwork = ie + *n; + dbdsqr_((char *)"U", n, &ncvt, &c__0, &c__0, &s[1], &work[ie], &a[a_offset], lda, dum, + &c__1, dum, &c__1, &work[iwork], info, (ftnlen)1); + if (wntvas) { + dlacpy_((char *)"F", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt, (ftnlen)1); + } + } else if (wntuo && wntvn) { + i__2 = *n << 2; + if (*lwork >= *n * *n + max(i__2, bdspac)) { + ir = 1; + i__2 = wrkbl, i__3 = *lda * *n + *n; + if (*lwork >= max(i__2, i__3) + *lda * *n) { + ldwrku = *lda; + ldwrkr = *lda; + } else { + i__2 = wrkbl, i__3 = *lda * *n + *n; + if (*lwork >= max(i__2, i__3) + *n * *n) { + ldwrku = *lda; + ldwrkr = *n; + } else { + ldwrku = (*lwork - *n * *n - *n) / *n; + ldwrkr = *n; + } + } + itau = ir + ldwrkr * *n; + iwork = itau + *n; + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr, (ftnlen)1); + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &work[ir + 1], &ldwrkr, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &work[itauq], &work[itaup], + &work[iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", n, n, n, &work[ir], &ldwrkr, &work[itauq], &work[iwork], &i__2, + &ierr, (ftnlen)1); + iwork = ie + *n; + dbdsqr_((char *)"U", n, &c__0, n, &c__0, &s[1], &work[ie], dum, &c__1, &work[ir], + &ldwrkr, dum, &c__1, &work[iwork], info, (ftnlen)1); + iu = ie + *n; + i__2 = *m; + i__3 = ldwrku; + for (i__ = 1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3) { + i__4 = *m - i__ + 1; + chunk = min(i__4, ldwrku); + dgemm_((char *)"N", (char *)"N", &chunk, n, n, &c_b79, &a[i__ + a_dim1], lda, &work[ir], + &ldwrkr, &c_b57, &work[iu], &ldwrku, (ftnlen)1, (ftnlen)1); + dlacpy_((char *)"F", &chunk, n, &work[iu], &ldwrku, &a[i__ + a_dim1], lda, + (ftnlen)1); + } + } else { + ie = 1; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + i__3 = *lwork - iwork + 1; + dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &work[itaup], + &work[iwork], &i__3, &ierr); + i__3 = *lwork - iwork + 1; + dorgbr_((char *)"Q", m, n, n, &a[a_offset], lda, &work[itauq], &work[iwork], &i__3, + &ierr, (ftnlen)1); + iwork = ie + *n; + dbdsqr_((char *)"U", n, &c__0, m, &c__0, &s[1], &work[ie], dum, &c__1, &a[a_offset], + lda, dum, &c__1, &work[iwork], info, (ftnlen)1); + } + } else if (wntuo && wntvas) { + i__3 = *n << 2; + if (*lwork >= *n * *n + max(i__3, bdspac)) { + ir = 1; + i__3 = wrkbl, i__2 = *lda * *n + *n; + if (*lwork >= max(i__3, i__2) + *lda * *n) { + ldwrku = *lda; + ldwrkr = *lda; + } else { + i__3 = wrkbl, i__2 = *lda * *n + *n; + if (*lwork >= max(i__3, i__2) + *n * *n) { + ldwrku = *lda; + ldwrkr = *n; + } else { + ldwrku = (*lwork - *n * *n - *n) / *n; + ldwrkr = *n; + } + } + itau = ir + ldwrkr * *n; + iwork = itau + *n; + i__3 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__3, &ierr); + dlacpy_((char *)"U", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt, (ftnlen)1); + if (*n > 1) { + i__3 = *n - 1; + i__2 = *n - 1; + dlaset_((char *)"L", &i__3, &i__2, &c_b57, &c_b57, &vt[vt_dim1 + 2], ldvt, + (ftnlen)1); + } + i__3 = *lwork - iwork + 1; + dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__3, &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + i__3 = *lwork - iwork + 1; + dgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie], &work[itauq], + &work[itaup], &work[iwork], &i__3, &ierr); + dlacpy_((char *)"L", n, n, &vt[vt_offset], ldvt, &work[ir], &ldwrkr, (ftnlen)1); + i__3 = *lwork - iwork + 1; + dorgbr_((char *)"Q", n, n, n, &work[ir], &ldwrkr, &work[itauq], &work[iwork], &i__3, + &ierr, (ftnlen)1); + i__3 = *lwork - iwork + 1; + dorgbr_((char *)"P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], &work[iwork], &i__3, + &ierr, (ftnlen)1); + iwork = ie + *n; + dbdsqr_((char *)"U", n, n, n, &c__0, &s[1], &work[ie], &vt[vt_offset], ldvt, &work[ir], + &ldwrkr, dum, &c__1, &work[iwork], info, (ftnlen)1); + iu = ie + *n; + i__3 = *m; + i__2 = ldwrku; + for (i__ = 1; i__2 < 0 ? i__ >= i__3 : i__ <= i__3; i__ += i__2) { + i__4 = *m - i__ + 1; + chunk = min(i__4, ldwrku); + dgemm_((char *)"N", (char *)"N", &chunk, n, n, &c_b79, &a[i__ + a_dim1], lda, &work[ir], + &ldwrkr, &c_b57, &work[iu], &ldwrku, (ftnlen)1, (ftnlen)1); + dlacpy_((char *)"F", &chunk, n, &work[iu], &ldwrku, &a[i__ + a_dim1], lda, + (ftnlen)1); + } + } else { + itau = 1; + iwork = itau + *n; + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"U", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt, (ftnlen)1); + if (*n > 1) { + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &vt[vt_dim1 + 2], ldvt, + (ftnlen)1); + } + i__2 = *lwork - iwork + 1; + dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie], &work[itauq], + &work[itaup], &work[iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dormbr_((char *)"Q", (char *)"R", (char *)"N", m, n, n, &vt[vt_offset], ldvt, &work[itauq], + &a[a_offset], lda, &work[iwork], &i__2, &ierr, (ftnlen)1, (ftnlen)1, + (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], &work[iwork], &i__2, + &ierr, (ftnlen)1); + iwork = ie + *n; + dbdsqr_((char *)"U", n, n, m, &c__0, &s[1], &work[ie], &vt[vt_offset], ldvt, + &a[a_offset], lda, dum, &c__1, &work[iwork], info, (ftnlen)1); + } + } else if (wntus) { + if (wntvn) { + i__2 = *n << 2; + if (*lwork >= *n * *n + max(i__2, bdspac)) { + ir = 1; + if (*lwork >= wrkbl + *lda * *n) { + ldwrkr = *lda; + } else { + ldwrkr = *n; + } + itau = ir + ldwrkr * *n; + iwork = itau + *n; + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr, (ftnlen)1); + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &work[ir + 1], &ldwrkr, + (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, + &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &work[itauq], + &work[itaup], &work[iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", n, n, n, &work[ir], &ldwrkr, &work[itauq], &work[iwork], &i__2, + &ierr, (ftnlen)1); + iwork = ie + *n; + dbdsqr_((char *)"U", n, &c__0, n, &c__0, &s[1], &work[ie], dum, &c__1, &work[ir], + &ldwrkr, dum, &c__1, &work[iwork], info, (ftnlen)1); + dgemm_((char *)"N", (char *)"N", m, n, n, &c_b79, &a[a_offset], lda, &work[ir], &ldwrkr, + &c_b57, &u[u_offset], ldu, (ftnlen)1, (ftnlen)1); + } else { + itau = 1; + iwork = itau + *n; + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"L", m, n, &a[a_offset], lda, &u[u_offset], ldu, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgqr_(m, n, n, &u[u_offset], ldu, &work[itau], &work[iwork], &i__2, + &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + if (*n > 1) { + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &a[a_dim1 + 2], lda, + (ftnlen)1); + } + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], + &work[itaup], &work[iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dormbr_((char *)"Q", (char *)"R", (char *)"N", m, n, n, &a[a_offset], lda, &work[itauq], + &u[u_offset], ldu, &work[iwork], &i__2, &ierr, (ftnlen)1, (ftnlen)1, + (ftnlen)1); + iwork = ie + *n; + dbdsqr_((char *)"U", n, &c__0, m, &c__0, &s[1], &work[ie], dum, &c__1, &u[u_offset], + ldu, dum, &c__1, &work[iwork], info, (ftnlen)1); + } + } else if (wntvo) { + i__2 = *n << 2; + if (*lwork >= (*n << 1) * *n + max(i__2, bdspac)) { + iu = 1; + if (*lwork >= wrkbl + (*lda << 1) * *n) { + ldwrku = *lda; + ir = iu + ldwrku * *n; + ldwrkr = *lda; + } else if (*lwork >= wrkbl + (*lda + *n) * *n) { + ldwrku = *lda; + ir = iu + ldwrku * *n; + ldwrkr = *n; + } else { + ldwrku = *n; + ir = iu + ldwrku * *n; + ldwrkr = *n; + } + itau = ir + ldwrkr * *n; + iwork = itau + *n; + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"U", n, n, &a[a_offset], lda, &work[iu], &ldwrku, (ftnlen)1); + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &work[iu + 1], &ldwrku, + (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, + &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], &work[itauq], + &work[itaup], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"U", n, n, &work[iu], &ldwrku, &work[ir], &ldwrkr, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", n, n, n, &work[iu], &ldwrku, &work[itauq], &work[iwork], &i__2, + &ierr, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", n, n, n, &work[ir], &ldwrkr, &work[itaup], &work[iwork], &i__2, + &ierr, (ftnlen)1); + iwork = ie + *n; + dbdsqr_((char *)"U", n, n, n, &c__0, &s[1], &work[ie], &work[ir], &ldwrkr, + &work[iu], &ldwrku, dum, &c__1, &work[iwork], info, (ftnlen)1); + dgemm_((char *)"N", (char *)"N", m, n, n, &c_b79, &a[a_offset], lda, &work[iu], &ldwrku, + &c_b57, &u[u_offset], ldu, (ftnlen)1, (ftnlen)1); + dlacpy_((char *)"F", n, n, &work[ir], &ldwrkr, &a[a_offset], lda, (ftnlen)1); + } else { + itau = 1; + iwork = itau + *n; + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"L", m, n, &a[a_offset], lda, &u[u_offset], ldu, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgqr_(m, n, n, &u[u_offset], ldu, &work[itau], &work[iwork], &i__2, + &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + if (*n > 1) { + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &a[a_dim1 + 2], lda, + (ftnlen)1); + } + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], + &work[itaup], &work[iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dormbr_((char *)"Q", (char *)"R", (char *)"N", m, n, n, &a[a_offset], lda, &work[itauq], + &u[u_offset], ldu, &work[iwork], &i__2, &ierr, (ftnlen)1, (ftnlen)1, + (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", n, n, n, &a[a_offset], lda, &work[itaup], &work[iwork], &i__2, + &ierr, (ftnlen)1); + iwork = ie + *n; + dbdsqr_((char *)"U", n, n, m, &c__0, &s[1], &work[ie], &a[a_offset], lda, + &u[u_offset], ldu, dum, &c__1, &work[iwork], info, (ftnlen)1); + } + } else if (wntvas) { + i__2 = *n << 2; + if (*lwork >= *n * *n + max(i__2, bdspac)) { + iu = 1; + if (*lwork >= wrkbl + *lda * *n) { + ldwrku = *lda; + } else { + ldwrku = *n; + } + itau = iu + ldwrku * *n; + iwork = itau + *n; + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"U", n, n, &a[a_offset], lda, &work[iu], &ldwrku, (ftnlen)1); + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &work[iu + 1], &ldwrku, + (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, + &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], &work[itauq], + &work[itaup], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"U", n, n, &work[iu], &ldwrku, &vt[vt_offset], ldvt, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", n, n, n, &work[iu], &ldwrku, &work[itauq], &work[iwork], &i__2, + &ierr, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], &work[iwork], + &i__2, &ierr, (ftnlen)1); + iwork = ie + *n; + dbdsqr_((char *)"U", n, n, n, &c__0, &s[1], &work[ie], &vt[vt_offset], ldvt, + &work[iu], &ldwrku, dum, &c__1, &work[iwork], info, (ftnlen)1); + dgemm_((char *)"N", (char *)"N", m, n, n, &c_b79, &a[a_offset], lda, &work[iu], &ldwrku, + &c_b57, &u[u_offset], ldu, (ftnlen)1, (ftnlen)1); + } else { + itau = 1; + iwork = itau + *n; + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"L", m, n, &a[a_offset], lda, &u[u_offset], ldu, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgqr_(m, n, n, &u[u_offset], ldu, &work[itau], &work[iwork], &i__2, + &ierr); + dlacpy_((char *)"U", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt, (ftnlen)1); + if (*n > 1) { + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &vt[vt_dim1 + 2], ldvt, + (ftnlen)1); + } + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie], &work[itauq], + &work[itaup], &work[iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dormbr_((char *)"Q", (char *)"R", (char *)"N", m, n, n, &vt[vt_offset], ldvt, &work[itauq], + &u[u_offset], ldu, &work[iwork], &i__2, &ierr, (ftnlen)1, (ftnlen)1, + (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], &work[iwork], + &i__2, &ierr, (ftnlen)1); + iwork = ie + *n; + dbdsqr_((char *)"U", n, n, m, &c__0, &s[1], &work[ie], &vt[vt_offset], ldvt, + &u[u_offset], ldu, dum, &c__1, &work[iwork], info, (ftnlen)1); + } + } + } else if (wntua) { + if (wntvn) { + i__2 = *n + *m, i__3 = *n << 2, i__2 = max(i__2, i__3); + if (*lwork >= *n * *n + max(i__2, bdspac)) { + ir = 1; + if (*lwork >= wrkbl + *lda * *n) { + ldwrkr = *lda; + } else { + ldwrkr = *n; + } + itau = ir + ldwrkr * *n; + iwork = itau + *n; + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"L", m, n, &a[a_offset], lda, &u[u_offset], ldu, (ftnlen)1); + dlacpy_((char *)"U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr, (ftnlen)1); + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &work[ir + 1], &ldwrkr, + (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &work[iwork], &i__2, + &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &work[itauq], + &work[itaup], &work[iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", n, n, n, &work[ir], &ldwrkr, &work[itauq], &work[iwork], &i__2, + &ierr, (ftnlen)1); + iwork = ie + *n; + dbdsqr_((char *)"U", n, &c__0, n, &c__0, &s[1], &work[ie], dum, &c__1, &work[ir], + &ldwrkr, dum, &c__1, &work[iwork], info, (ftnlen)1); + dgemm_((char *)"N", (char *)"N", m, n, n, &c_b79, &u[u_offset], ldu, &work[ir], &ldwrkr, + &c_b57, &a[a_offset], lda, (ftnlen)1, (ftnlen)1); + dlacpy_((char *)"F", m, n, &a[a_offset], lda, &u[u_offset], ldu, (ftnlen)1); + } else { + itau = 1; + iwork = itau + *n; + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"L", m, n, &a[a_offset], lda, &u[u_offset], ldu, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &work[iwork], &i__2, + &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + if (*n > 1) { + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &a[a_dim1 + 2], lda, + (ftnlen)1); + } + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], + &work[itaup], &work[iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dormbr_((char *)"Q", (char *)"R", (char *)"N", m, n, n, &a[a_offset], lda, &work[itauq], + &u[u_offset], ldu, &work[iwork], &i__2, &ierr, (ftnlen)1, (ftnlen)1, + (ftnlen)1); + iwork = ie + *n; + dbdsqr_((char *)"U", n, &c__0, m, &c__0, &s[1], &work[ie], dum, &c__1, &u[u_offset], + ldu, dum, &c__1, &work[iwork], info, (ftnlen)1); + } + } else if (wntvo) { + i__2 = *n + *m, i__3 = *n << 2, i__2 = max(i__2, i__3); + if (*lwork >= (*n << 1) * *n + max(i__2, bdspac)) { + iu = 1; + if (*lwork >= wrkbl + (*lda << 1) * *n) { + ldwrku = *lda; + ir = iu + ldwrku * *n; + ldwrkr = *lda; + } else if (*lwork >= wrkbl + (*lda + *n) * *n) { + ldwrku = *lda; + ir = iu + ldwrku * *n; + ldwrkr = *n; + } else { + ldwrku = *n; + ir = iu + ldwrku * *n; + ldwrkr = *n; + } + itau = ir + ldwrkr * *n; + iwork = itau + *n; + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"L", m, n, &a[a_offset], lda, &u[u_offset], ldu, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &work[iwork], &i__2, + &ierr); + dlacpy_((char *)"U", n, n, &a[a_offset], lda, &work[iu], &ldwrku, (ftnlen)1); + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &work[iu + 1], &ldwrku, + (ftnlen)1); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], &work[itauq], + &work[itaup], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"U", n, n, &work[iu], &ldwrku, &work[ir], &ldwrkr, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", n, n, n, &work[iu], &ldwrku, &work[itauq], &work[iwork], &i__2, + &ierr, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", n, n, n, &work[ir], &ldwrkr, &work[itaup], &work[iwork], &i__2, + &ierr, (ftnlen)1); + iwork = ie + *n; + dbdsqr_((char *)"U", n, n, n, &c__0, &s[1], &work[ie], &work[ir], &ldwrkr, + &work[iu], &ldwrku, dum, &c__1, &work[iwork], info, (ftnlen)1); + dgemm_((char *)"N", (char *)"N", m, n, n, &c_b79, &u[u_offset], ldu, &work[iu], &ldwrku, + &c_b57, &a[a_offset], lda, (ftnlen)1, (ftnlen)1); + dlacpy_((char *)"F", m, n, &a[a_offset], lda, &u[u_offset], ldu, (ftnlen)1); + dlacpy_((char *)"F", n, n, &work[ir], &ldwrkr, &a[a_offset], lda, (ftnlen)1); + } else { + itau = 1; + iwork = itau + *n; + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"L", m, n, &a[a_offset], lda, &u[u_offset], ldu, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &work[iwork], &i__2, + &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + if (*n > 1) { + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &a[a_dim1 + 2], lda, + (ftnlen)1); + } + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], + &work[itaup], &work[iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dormbr_((char *)"Q", (char *)"R", (char *)"N", m, n, n, &a[a_offset], lda, &work[itauq], + &u[u_offset], ldu, &work[iwork], &i__2, &ierr, (ftnlen)1, (ftnlen)1, + (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", n, n, n, &a[a_offset], lda, &work[itaup], &work[iwork], &i__2, + &ierr, (ftnlen)1); + iwork = ie + *n; + dbdsqr_((char *)"U", n, n, m, &c__0, &s[1], &work[ie], &a[a_offset], lda, + &u[u_offset], ldu, dum, &c__1, &work[iwork], info, (ftnlen)1); + } + } else if (wntvas) { + i__2 = *n + *m, i__3 = *n << 2, i__2 = max(i__2, i__3); + if (*lwork >= *n * *n + max(i__2, bdspac)) { + iu = 1; + if (*lwork >= wrkbl + *lda * *n) { + ldwrku = *lda; + } else { + ldwrku = *n; + } + itau = iu + ldwrku * *n; + iwork = itau + *n; + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"L", m, n, &a[a_offset], lda, &u[u_offset], ldu, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &work[iwork], &i__2, + &ierr); + dlacpy_((char *)"U", n, n, &a[a_offset], lda, &work[iu], &ldwrku, (ftnlen)1); + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &work[iu + 1], &ldwrku, + (ftnlen)1); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], &work[itauq], + &work[itaup], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"U", n, n, &work[iu], &ldwrku, &vt[vt_offset], ldvt, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", n, n, n, &work[iu], &ldwrku, &work[itauq], &work[iwork], &i__2, + &ierr, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], &work[iwork], + &i__2, &ierr, (ftnlen)1); + iwork = ie + *n; + dbdsqr_((char *)"U", n, n, n, &c__0, &s[1], &work[ie], &vt[vt_offset], ldvt, + &work[iu], &ldwrku, dum, &c__1, &work[iwork], info, (ftnlen)1); + dgemm_((char *)"N", (char *)"N", m, n, n, &c_b79, &u[u_offset], ldu, &work[iu], &ldwrku, + &c_b57, &a[a_offset], lda, (ftnlen)1, (ftnlen)1); + dlacpy_((char *)"F", m, n, &a[a_offset], lda, &u[u_offset], ldu, (ftnlen)1); + } else { + itau = 1; + iwork = itau + *n; + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"L", m, n, &a[a_offset], lda, &u[u_offset], ldu, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &work[iwork], &i__2, + &ierr); + dlacpy_((char *)"U", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt, (ftnlen)1); + if (*n > 1) { + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_((char *)"L", &i__2, &i__3, &c_b57, &c_b57, &vt[vt_dim1 + 2], ldvt, + (ftnlen)1); + } + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie], &work[itauq], + &work[itaup], &work[iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dormbr_((char *)"Q", (char *)"R", (char *)"N", m, n, n, &vt[vt_offset], ldvt, &work[itauq], + &u[u_offset], ldu, &work[iwork], &i__2, &ierr, (ftnlen)1, (ftnlen)1, + (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], &work[iwork], + &i__2, &ierr, (ftnlen)1); + iwork = ie + *n; + dbdsqr_((char *)"U", n, n, m, &c__0, &s[1], &work[ie], &vt[vt_offset], ldvt, + &u[u_offset], ldu, dum, &c__1, &work[iwork], info, (ftnlen)1); + } + } + } + } else { + ie = 1; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + i__2 = *lwork - iwork + 1; + dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &work[itaup], + &work[iwork], &i__2, &ierr); + if (wntuas) { + dlacpy_((char *)"L", m, n, &a[a_offset], lda, &u[u_offset], ldu, (ftnlen)1); + if (wntus) { + ncu = *n; + } + if (wntua) { + ncu = *m; + } + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", m, &ncu, n, &u[u_offset], ldu, &work[itauq], &work[iwork], &i__2, + &ierr, (ftnlen)1); + } + if (wntvas) { + dlacpy_((char *)"U", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], &work[iwork], &i__2, + &ierr, (ftnlen)1); + } + if (wntuo) { + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", m, n, n, &a[a_offset], lda, &work[itauq], &work[iwork], &i__2, &ierr, + (ftnlen)1); + } + if (wntvo) { + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", n, n, n, &a[a_offset], lda, &work[itaup], &work[iwork], &i__2, &ierr, + (ftnlen)1); + } + iwork = ie + *n; + if (wntuas || wntuo) { + nru = *m; + } + if (wntun) { + nru = 0; + } + if (wntvas || wntvo) { + ncvt = *n; + } + if (wntvn) { + ncvt = 0; + } + if (!wntuo && !wntvo) { + dbdsqr_((char *)"U", n, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[vt_offset], ldvt, + &u[u_offset], ldu, dum, &c__1, &work[iwork], info, (ftnlen)1); + } else if (!wntuo && wntvo) { + dbdsqr_((char *)"U", n, &ncvt, &nru, &c__0, &s[1], &work[ie], &a[a_offset], lda, + &u[u_offset], ldu, dum, &c__1, &work[iwork], info, (ftnlen)1); + } else { + dbdsqr_((char *)"U", n, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[vt_offset], ldvt, + &a[a_offset], lda, dum, &c__1, &work[iwork], info, (ftnlen)1); + } + } + } else { + if (*n >= mnthr) { + if (wntvn) { + itau = 1; + iwork = itau + *m; + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &a[(a_dim1 << 1) + 1], lda, (ftnlen)1); + ie = 1; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &work[itaup], + &work[iwork], &i__2, &ierr); + if (wntuo || wntuas) { + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", m, m, m, &a[a_offset], lda, &work[itauq], &work[iwork], &i__2, + &ierr, (ftnlen)1); + } + iwork = ie + *m; + nru = 0; + if (wntuo || wntuas) { + nru = *m; + } + dbdsqr_((char *)"U", m, &c__0, &nru, &c__0, &s[1], &work[ie], dum, &c__1, &a[a_offset], lda, + dum, &c__1, &work[iwork], info, (ftnlen)1); + if (wntuas) { + dlacpy_((char *)"F", m, m, &a[a_offset], lda, &u[u_offset], ldu, (ftnlen)1); + } + } else if (wntvo && wntun) { + i__2 = *m << 2; + if (*lwork >= *m * *m + max(i__2, bdspac)) { + ir = 1; + i__2 = wrkbl, i__3 = *lda * *n + *m; + if (*lwork >= max(i__2, i__3) + *lda * *m) { + ldwrku = *lda; + chunk = *n; + ldwrkr = *lda; + } else { + i__2 = wrkbl, i__3 = *lda * *n + *m; + if (*lwork >= max(i__2, i__3) + *m * *m) { + ldwrku = *lda; + chunk = *n; + ldwrkr = *m; + } else { + ldwrku = *m; + chunk = (*lwork - *m * *m - *m) / *m; + ldwrkr = *m; + } + } + itau = ir + ldwrkr * *m; + iwork = itau + *m; + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[ir], &ldwrkr, (ftnlen)1); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &work[ir + ldwrkr], &ldwrkr, + (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &work[ie], &work[itauq], &work[itaup], + &work[iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", m, m, m, &work[ir], &ldwrkr, &work[itaup], &work[iwork], &i__2, + &ierr, (ftnlen)1); + iwork = ie + *m; + dbdsqr_((char *)"U", m, m, &c__0, &c__0, &s[1], &work[ie], &work[ir], &ldwrkr, dum, + &c__1, dum, &c__1, &work[iwork], info, (ftnlen)1); + iu = ie + *m; + i__2 = *n; + i__3 = chunk; + for (i__ = 1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3) { + i__4 = *n - i__ + 1; + blk = min(i__4, chunk); + dgemm_((char *)"N", (char *)"N", m, &blk, m, &c_b79, &work[ir], &ldwrkr, + &a[i__ * a_dim1 + 1], lda, &c_b57, &work[iu], &ldwrku, (ftnlen)1, + (ftnlen)1); + dlacpy_((char *)"F", m, &blk, &work[iu], &ldwrku, &a[i__ * a_dim1 + 1], lda, + (ftnlen)1); + } + } else { + ie = 1; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + i__3 = *lwork - iwork + 1; + dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &work[itaup], + &work[iwork], &i__3, &ierr); + i__3 = *lwork - iwork + 1; + dorgbr_((char *)"P", m, n, m, &a[a_offset], lda, &work[itaup], &work[iwork], &i__3, + &ierr, (ftnlen)1); + iwork = ie + *m; + dbdsqr_((char *)"L", m, n, &c__0, &c__0, &s[1], &work[ie], &a[a_offset], lda, dum, + &c__1, dum, &c__1, &work[iwork], info, (ftnlen)1); + } + } else if (wntvo && wntuas) { + i__3 = *m << 2; + if (*lwork >= *m * *m + max(i__3, bdspac)) { + ir = 1; + i__3 = wrkbl, i__2 = *lda * *n + *m; + if (*lwork >= max(i__3, i__2) + *lda * *m) { + ldwrku = *lda; + chunk = *n; + ldwrkr = *lda; + } else { + i__3 = wrkbl, i__2 = *lda * *n + *m; + if (*lwork >= max(i__3, i__2) + *m * *m) { + ldwrku = *lda; + chunk = *n; + ldwrkr = *m; + } else { + ldwrku = *m; + chunk = (*lwork - *m * *m - *m) / *m; + ldwrkr = *m; + } + } + itau = ir + ldwrkr * *m; + iwork = itau + *m; + i__3 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__3, &ierr); + dlacpy_((char *)"L", m, m, &a[a_offset], lda, &u[u_offset], ldu, (ftnlen)1); + i__3 = *m - 1; + i__2 = *m - 1; + dlaset_((char *)"U", &i__3, &i__2, &c_b57, &c_b57, &u[(u_dim1 << 1) + 1], ldu, + (ftnlen)1); + i__3 = *lwork - iwork + 1; + dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[iwork], &i__3, &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + i__3 = *lwork - iwork + 1; + dgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], &work[itauq], &work[itaup], + &work[iwork], &i__3, &ierr); + dlacpy_((char *)"U", m, m, &u[u_offset], ldu, &work[ir], &ldwrkr, (ftnlen)1); + i__3 = *lwork - iwork + 1; + dorgbr_((char *)"P", m, m, m, &work[ir], &ldwrkr, &work[itaup], &work[iwork], &i__3, + &ierr, (ftnlen)1); + i__3 = *lwork - iwork + 1; + dorgbr_((char *)"Q", m, m, m, &u[u_offset], ldu, &work[itauq], &work[iwork], &i__3, + &ierr, (ftnlen)1); + iwork = ie + *m; + dbdsqr_((char *)"U", m, m, m, &c__0, &s[1], &work[ie], &work[ir], &ldwrkr, &u[u_offset], + ldu, dum, &c__1, &work[iwork], info, (ftnlen)1); + iu = ie + *m; + i__3 = *n; + i__2 = chunk; + for (i__ = 1; i__2 < 0 ? i__ >= i__3 : i__ <= i__3; i__ += i__2) { + i__4 = *n - i__ + 1; + blk = min(i__4, chunk); + dgemm_((char *)"N", (char *)"N", m, &blk, m, &c_b79, &work[ir], &ldwrkr, + &a[i__ * a_dim1 + 1], lda, &c_b57, &work[iu], &ldwrku, (ftnlen)1, + (ftnlen)1); + dlacpy_((char *)"F", m, &blk, &work[iu], &ldwrku, &a[i__ * a_dim1 + 1], lda, + (ftnlen)1); + } + } else { + itau = 1; + iwork = itau + *m; + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"L", m, m, &a[a_offset], lda, &u[u_offset], ldu, (ftnlen)1); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &u[(u_dim1 << 1) + 1], ldu, + (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], &work[itauq], &work[itaup], + &work[iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dormbr_((char *)"P", (char *)"L", (char *)"T", m, n, m, &u[u_offset], ldu, &work[itaup], &a[a_offset], + lda, &work[iwork], &i__2, &ierr, (ftnlen)1, (ftnlen)1, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", m, m, m, &u[u_offset], ldu, &work[itauq], &work[iwork], &i__2, + &ierr, (ftnlen)1); + iwork = ie + *m; + dbdsqr_((char *)"U", m, n, m, &c__0, &s[1], &work[ie], &a[a_offset], lda, &u[u_offset], + ldu, dum, &c__1, &work[iwork], info, (ftnlen)1); + } + } else if (wntvs) { + if (wntun) { + i__2 = *m << 2; + if (*lwork >= *m * *m + max(i__2, bdspac)) { + ir = 1; + if (*lwork >= wrkbl + *lda * *m) { + ldwrkr = *lda; + } else { + ldwrkr = *m; + } + itau = ir + ldwrkr * *m; + iwork = itau + *m; + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[ir], &ldwrkr, (ftnlen)1); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &work[ir + ldwrkr], &ldwrkr, + (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, + &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &work[ie], &work[itauq], + &work[itaup], &work[iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", m, m, m, &work[ir], &ldwrkr, &work[itaup], &work[iwork], &i__2, + &ierr, (ftnlen)1); + iwork = ie + *m; + dbdsqr_((char *)"U", m, m, &c__0, &c__0, &s[1], &work[ie], &work[ir], &ldwrkr, dum, + &c__1, dum, &c__1, &work[iwork], info, (ftnlen)1); + dgemm_((char *)"N", (char *)"N", m, n, m, &c_b79, &work[ir], &ldwrkr, &a[a_offset], lda, + &c_b57, &vt[vt_offset], ldvt, (ftnlen)1, (ftnlen)1); + } else { + itau = 1; + iwork = itau + *m; + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], &work[iwork], &i__2, + &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &a[(a_dim1 << 1) + 1], lda, + (ftnlen)1); + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], + &work[itaup], &work[iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dormbr_((char *)"P", (char *)"L", (char *)"T", m, n, m, &a[a_offset], lda, &work[itaup], + &vt[vt_offset], ldvt, &work[iwork], &i__2, &ierr, (ftnlen)1, + (ftnlen)1, (ftnlen)1); + iwork = ie + *m; + dbdsqr_((char *)"U", m, n, &c__0, &c__0, &s[1], &work[ie], &vt[vt_offset], ldvt, + dum, &c__1, dum, &c__1, &work[iwork], info, (ftnlen)1); + } + } else if (wntuo) { + i__2 = *m << 2; + if (*lwork >= (*m << 1) * *m + max(i__2, bdspac)) { + iu = 1; + if (*lwork >= wrkbl + (*lda << 1) * *m) { + ldwrku = *lda; + ir = iu + ldwrku * *m; + ldwrkr = *lda; + } else if (*lwork >= wrkbl + (*lda + *m) * *m) { + ldwrku = *lda; + ir = iu + ldwrku * *m; + ldwrkr = *m; + } else { + ldwrku = *m; + ir = iu + ldwrku * *m; + ldwrkr = *m; + } + itau = ir + ldwrkr * *m; + iwork = itau + *m; + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[iu], &ldwrku, (ftnlen)1); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &work[iu + ldwrku], &ldwrku, + (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, + &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], &work[itauq], + &work[itaup], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"L", m, m, &work[iu], &ldwrku, &work[ir], &ldwrkr, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", m, m, m, &work[iu], &ldwrku, &work[itaup], &work[iwork], &i__2, + &ierr, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", m, m, m, &work[ir], &ldwrkr, &work[itauq], &work[iwork], &i__2, + &ierr, (ftnlen)1); + iwork = ie + *m; + dbdsqr_((char *)"U", m, m, m, &c__0, &s[1], &work[ie], &work[iu], &ldwrku, + &work[ir], &ldwrkr, dum, &c__1, &work[iwork], info, (ftnlen)1); + dgemm_((char *)"N", (char *)"N", m, n, m, &c_b79, &work[iu], &ldwrku, &a[a_offset], lda, + &c_b57, &vt[vt_offset], ldvt, (ftnlen)1, (ftnlen)1); + dlacpy_((char *)"F", m, m, &work[ir], &ldwrkr, &a[a_offset], lda, (ftnlen)1); + } else { + itau = 1; + iwork = itau + *m; + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], &work[iwork], &i__2, + &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &a[(a_dim1 << 1) + 1], lda, + (ftnlen)1); + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], + &work[itaup], &work[iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dormbr_((char *)"P", (char *)"L", (char *)"T", m, n, m, &a[a_offset], lda, &work[itaup], + &vt[vt_offset], ldvt, &work[iwork], &i__2, &ierr, (ftnlen)1, + (ftnlen)1, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", m, m, m, &a[a_offset], lda, &work[itauq], &work[iwork], &i__2, + &ierr, (ftnlen)1); + iwork = ie + *m; + dbdsqr_((char *)"U", m, n, m, &c__0, &s[1], &work[ie], &vt[vt_offset], ldvt, + &a[a_offset], lda, dum, &c__1, &work[iwork], info, (ftnlen)1); + } + } else if (wntuas) { + i__2 = *m << 2; + if (*lwork >= *m * *m + max(i__2, bdspac)) { + iu = 1; + if (*lwork >= wrkbl + *lda * *m) { + ldwrku = *lda; + } else { + ldwrku = *m; + } + itau = iu + ldwrku * *m; + iwork = itau + *m; + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[iu], &ldwrku, (ftnlen)1); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &work[iu + ldwrku], &ldwrku, + (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, + &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], &work[itauq], + &work[itaup], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"L", m, m, &work[iu], &ldwrku, &u[u_offset], ldu, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", m, m, m, &work[iu], &ldwrku, &work[itaup], &work[iwork], &i__2, + &ierr, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", m, m, m, &u[u_offset], ldu, &work[itauq], &work[iwork], &i__2, + &ierr, (ftnlen)1); + iwork = ie + *m; + dbdsqr_((char *)"U", m, m, m, &c__0, &s[1], &work[ie], &work[iu], &ldwrku, + &u[u_offset], ldu, dum, &c__1, &work[iwork], info, (ftnlen)1); + dgemm_((char *)"N", (char *)"N", m, n, m, &c_b79, &work[iu], &ldwrku, &a[a_offset], lda, + &c_b57, &vt[vt_offset], ldvt, (ftnlen)1, (ftnlen)1); + } else { + itau = 1; + iwork = itau + *m; + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], &work[iwork], &i__2, + &ierr); + dlacpy_((char *)"L", m, m, &a[a_offset], lda, &u[u_offset], ldu, (ftnlen)1); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &u[(u_dim1 << 1) + 1], ldu, + (ftnlen)1); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], &work[itauq], + &work[itaup], &work[iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dormbr_((char *)"P", (char *)"L", (char *)"T", m, n, m, &u[u_offset], ldu, &work[itaup], + &vt[vt_offset], ldvt, &work[iwork], &i__2, &ierr, (ftnlen)1, + (ftnlen)1, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", m, m, m, &u[u_offset], ldu, &work[itauq], &work[iwork], &i__2, + &ierr, (ftnlen)1); + iwork = ie + *m; + dbdsqr_((char *)"U", m, n, m, &c__0, &s[1], &work[ie], &vt[vt_offset], ldvt, + &u[u_offset], ldu, dum, &c__1, &work[iwork], info, (ftnlen)1); + } + } + } else if (wntva) { + if (wntun) { + i__2 = *n + *m, i__3 = *m << 2, i__2 = max(i__2, i__3); + if (*lwork >= *m * *m + max(i__2, bdspac)) { + ir = 1; + if (*lwork >= wrkbl + *lda * *m) { + ldwrkr = *lda; + } else { + ldwrkr = *m; + } + itau = ir + ldwrkr * *m; + iwork = itau + *m; + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt, (ftnlen)1); + dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[ir], &ldwrkr, (ftnlen)1); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &work[ir + ldwrkr], &ldwrkr, + (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &work[iwork], &i__2, + &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &work[ie], &work[itauq], + &work[itaup], &work[iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", m, m, m, &work[ir], &ldwrkr, &work[itaup], &work[iwork], &i__2, + &ierr, (ftnlen)1); + iwork = ie + *m; + dbdsqr_((char *)"U", m, m, &c__0, &c__0, &s[1], &work[ie], &work[ir], &ldwrkr, dum, + &c__1, dum, &c__1, &work[iwork], info, (ftnlen)1); + dgemm_((char *)"N", (char *)"N", m, n, m, &c_b79, &work[ir], &ldwrkr, &vt[vt_offset], ldvt, + &c_b57, &a[a_offset], lda, (ftnlen)1, (ftnlen)1); + dlacpy_((char *)"F", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt, (ftnlen)1); + } else { + itau = 1; + iwork = itau + *m; + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &work[iwork], &i__2, + &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &a[(a_dim1 << 1) + 1], lda, + (ftnlen)1); + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], + &work[itaup], &work[iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dormbr_((char *)"P", (char *)"L", (char *)"T", m, n, m, &a[a_offset], lda, &work[itaup], + &vt[vt_offset], ldvt, &work[iwork], &i__2, &ierr, (ftnlen)1, + (ftnlen)1, (ftnlen)1); + iwork = ie + *m; + dbdsqr_((char *)"U", m, n, &c__0, &c__0, &s[1], &work[ie], &vt[vt_offset], ldvt, + dum, &c__1, dum, &c__1, &work[iwork], info, (ftnlen)1); + } + } else if (wntuo) { + i__2 = *n + *m, i__3 = *m << 2, i__2 = max(i__2, i__3); + if (*lwork >= (*m << 1) * *m + max(i__2, bdspac)) { + iu = 1; + if (*lwork >= wrkbl + (*lda << 1) * *m) { + ldwrku = *lda; + ir = iu + ldwrku * *m; + ldwrkr = *lda; + } else if (*lwork >= wrkbl + (*lda + *m) * *m) { + ldwrku = *lda; + ir = iu + ldwrku * *m; + ldwrkr = *m; + } else { + ldwrku = *m; + ir = iu + ldwrku * *m; + ldwrkr = *m; + } + itau = ir + ldwrkr * *m; + iwork = itau + *m; + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &work[iwork], &i__2, + &ierr); + dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[iu], &ldwrku, (ftnlen)1); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &work[iu + ldwrku], &ldwrku, + (ftnlen)1); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], &work[itauq], + &work[itaup], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"L", m, m, &work[iu], &ldwrku, &work[ir], &ldwrkr, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", m, m, m, &work[iu], &ldwrku, &work[itaup], &work[iwork], &i__2, + &ierr, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", m, m, m, &work[ir], &ldwrkr, &work[itauq], &work[iwork], &i__2, + &ierr, (ftnlen)1); + iwork = ie + *m; + dbdsqr_((char *)"U", m, m, m, &c__0, &s[1], &work[ie], &work[iu], &ldwrku, + &work[ir], &ldwrkr, dum, &c__1, &work[iwork], info, (ftnlen)1); + dgemm_((char *)"N", (char *)"N", m, n, m, &c_b79, &work[iu], &ldwrku, &vt[vt_offset], ldvt, + &c_b57, &a[a_offset], lda, (ftnlen)1, (ftnlen)1); + dlacpy_((char *)"F", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt, (ftnlen)1); + dlacpy_((char *)"F", m, m, &work[ir], &ldwrkr, &a[a_offset], lda, (ftnlen)1); + } else { + itau = 1; + iwork = itau + *m; + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &work[iwork], &i__2, + &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &a[(a_dim1 << 1) + 1], lda, + (ftnlen)1); + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], + &work[itaup], &work[iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dormbr_((char *)"P", (char *)"L", (char *)"T", m, n, m, &a[a_offset], lda, &work[itaup], + &vt[vt_offset], ldvt, &work[iwork], &i__2, &ierr, (ftnlen)1, + (ftnlen)1, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", m, m, m, &a[a_offset], lda, &work[itauq], &work[iwork], &i__2, + &ierr, (ftnlen)1); + iwork = ie + *m; + dbdsqr_((char *)"U", m, n, m, &c__0, &s[1], &work[ie], &vt[vt_offset], ldvt, + &a[a_offset], lda, dum, &c__1, &work[iwork], info, (ftnlen)1); + } + } else if (wntuas) { + i__2 = *n + *m, i__3 = *m << 2, i__2 = max(i__2, i__3); + if (*lwork >= *m * *m + max(i__2, bdspac)) { + iu = 1; + if (*lwork >= wrkbl + *lda * *m) { + ldwrku = *lda; + } else { + ldwrku = *m; + } + itau = iu + ldwrku * *m; + iwork = itau + *m; + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &work[iwork], &i__2, + &ierr); + dlacpy_((char *)"L", m, m, &a[a_offset], lda, &work[iu], &ldwrku, (ftnlen)1); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &work[iu + ldwrku], &ldwrku, + (ftnlen)1); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], &work[itauq], + &work[itaup], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"L", m, m, &work[iu], &ldwrku, &u[u_offset], ldu, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", m, m, m, &work[iu], &ldwrku, &work[itaup], &work[iwork], &i__2, + &ierr, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", m, m, m, &u[u_offset], ldu, &work[itauq], &work[iwork], &i__2, + &ierr, (ftnlen)1); + iwork = ie + *m; + dbdsqr_((char *)"U", m, m, m, &c__0, &s[1], &work[ie], &work[iu], &ldwrku, + &u[u_offset], ldu, dum, &c__1, &work[iwork], info, (ftnlen)1); + dgemm_((char *)"N", (char *)"N", m, n, m, &c_b79, &work[iu], &ldwrku, &vt[vt_offset], ldvt, + &c_b57, &a[a_offset], lda, (ftnlen)1, (ftnlen)1); + dlacpy_((char *)"F", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt, (ftnlen)1); + } else { + itau = 1; + iwork = itau + *m; + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, &ierr); + dlacpy_((char *)"U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &work[iwork], &i__2, + &ierr); + dlacpy_((char *)"L", m, m, &a[a_offset], lda, &u[u_offset], ldu, (ftnlen)1); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_((char *)"U", &i__2, &i__3, &c_b57, &c_b57, &u[(u_dim1 << 1) + 1], ldu, + (ftnlen)1); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], &work[itauq], + &work[itaup], &work[iwork], &i__2, &ierr); + i__2 = *lwork - iwork + 1; + dormbr_((char *)"P", (char *)"L", (char *)"T", m, n, m, &u[u_offset], ldu, &work[itaup], + &vt[vt_offset], ldvt, &work[iwork], &i__2, &ierr, (ftnlen)1, + (ftnlen)1, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", m, m, m, &u[u_offset], ldu, &work[itauq], &work[iwork], &i__2, + &ierr, (ftnlen)1); + iwork = ie + *m; + dbdsqr_((char *)"U", m, n, m, &c__0, &s[1], &work[ie], &vt[vt_offset], ldvt, + &u[u_offset], ldu, dum, &c__1, &work[iwork], info, (ftnlen)1); + } + } + } + } else { + ie = 1; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + i__2 = *lwork - iwork + 1; + dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &work[itaup], + &work[iwork], &i__2, &ierr); + if (wntuas) { + dlacpy_((char *)"L", m, m, &a[a_offset], lda, &u[u_offset], ldu, (ftnlen)1); + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", m, m, n, &u[u_offset], ldu, &work[itauq], &work[iwork], &i__2, &ierr, + (ftnlen)1); + } + if (wntvas) { + dlacpy_((char *)"U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt, (ftnlen)1); + if (wntva) { + nrvt = *n; + } + if (wntvs) { + nrvt = *m; + } + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", &nrvt, n, m, &vt[vt_offset], ldvt, &work[itaup], &work[iwork], &i__2, + &ierr, (ftnlen)1); + } + if (wntuo) { + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"Q", m, m, n, &a[a_offset], lda, &work[itauq], &work[iwork], &i__2, &ierr, + (ftnlen)1); + } + if (wntvo) { + i__2 = *lwork - iwork + 1; + dorgbr_((char *)"P", m, n, m, &a[a_offset], lda, &work[itaup], &work[iwork], &i__2, &ierr, + (ftnlen)1); + } + iwork = ie + *m; + if (wntuas || wntuo) { + nru = *m; + } + if (wntun) { + nru = 0; + } + if (wntvas || wntvo) { + ncvt = *n; + } + if (wntvn) { + ncvt = 0; + } + if (!wntuo && !wntvo) { + dbdsqr_((char *)"L", m, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[vt_offset], ldvt, + &u[u_offset], ldu, dum, &c__1, &work[iwork], info, (ftnlen)1); + } else if (!wntuo && wntvo) { + dbdsqr_((char *)"L", m, &ncvt, &nru, &c__0, &s[1], &work[ie], &a[a_offset], lda, + &u[u_offset], ldu, dum, &c__1, &work[iwork], info, (ftnlen)1); + } else { + dbdsqr_((char *)"L", m, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[vt_offset], ldvt, + &a[a_offset], lda, dum, &c__1, &work[iwork], info, (ftnlen)1); + } + } + } + if (*info != 0) { + if (ie > 2) { + i__2 = minmn - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__ + 1] = work[i__ + ie - 1]; + } + } + if (ie < 2) { + for (i__ = minmn - 1; i__ >= 1; --i__) { + work[i__ + 1] = work[i__ + ie - 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 (*info != 0 && anrm > bignum) { + i__2 = minmn - 1; + dlascl_((char *)"G", &c__0, &c__0, &bignum, &anrm, &i__2, &c__1, &work[2], &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); + } + if (*info != 0 && anrm < smlnum) { + i__2 = minmn - 1; + dlascl_((char *)"G", &c__0, &c__0, &smlnum, &anrm, &i__2, &c__1, &work[2], &minmn, &ierr, + (ftnlen)1); + } + } + work[1] = (doublereal)maxwrk; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dgesvd.f b/lib/linalg/dgesvd.f deleted file mode 100644 index 7cc8b35129..0000000000 --- a/lib/linalg/dgesvd.f +++ /dev/null @@ -1,3501 +0,0 @@ -*> \brief DGESVD computes the singular value decomposition (SVD) for GE matrices -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGESVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, -* WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER JOBU, JOBVT -* INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ), -* $ VT( LDVT, * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGESVD computes the singular value decomposition (SVD) of a real -*> M-by-N matrix A, optionally computing the left and/or right singular -*> vectors. The SVD is written -*> -*> A = U * SIGMA * transpose(V) -*> -*> where SIGMA is an M-by-N matrix which is zero except for its -*> min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and -*> V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA -*> are the singular values of A; they are real and non-negative, and -*> are returned in descending order. The first min(m,n) columns of -*> U and V are the left and right singular vectors of A. -*> -*> Note that the routine returns V**T, not V. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] JOBU -*> \verbatim -*> JOBU is CHARACTER*1 -*> Specifies options for computing all or part of the matrix U: -*> = 'A': all M columns of U are returned in array U: -*> = 'S': the first min(m,n) columns of U (the left singular -*> vectors) are returned in the array U; -*> = 'O': the first min(m,n) columns of U (the left singular -*> vectors) are overwritten on the array A; -*> = 'N': no columns of U (no left singular vectors) are -*> computed. -*> \endverbatim -*> -*> \param[in] JOBVT -*> \verbatim -*> JOBVT is CHARACTER*1 -*> Specifies options for computing all or part of the matrix -*> V**T: -*> = 'A': all N rows of V**T are returned in the array VT; -*> = 'S': the first min(m,n) rows of V**T (the right singular -*> vectors) are returned in the array VT; -*> = 'O': the first min(m,n) rows of V**T (the right singular -*> vectors) are overwritten on the array A; -*> = 'N': no rows of V**T (no right singular vectors) are -*> computed. -*> -*> JOBVT and JOBU cannot both be 'O'. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the input matrix A. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the input matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the M-by-N matrix A. -*> On exit, -*> if JOBU = 'O', A is overwritten with the first min(m,n) -*> columns of U (the left singular vectors, -*> stored columnwise); -*> if JOBVT = 'O', A is overwritten with the first min(m,n) -*> rows of V**T (the right singular vectors, -*> stored rowwise); -*> if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A -*> are destroyed. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[out] S -*> \verbatim -*> S is DOUBLE PRECISION array, dimension (min(M,N)) -*> The singular values of A, sorted so that S(i) >= S(i+1). -*> \endverbatim -*> -*> \param[out] U -*> \verbatim -*> U is DOUBLE PRECISION array, dimension (LDU,UCOL) -*> (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'. -*> If JOBU = 'A', U contains the M-by-M orthogonal matrix U; -*> if JOBU = 'S', U contains the first min(m,n) columns of U -*> (the left singular vectors, stored columnwise); -*> if JOBU = 'N' or 'O', U is not referenced. -*> \endverbatim -*> -*> \param[in] LDU -*> \verbatim -*> LDU is INTEGER -*> The leading dimension of the array U. LDU >= 1; if -*> JOBU = 'S' or 'A', LDU >= M. -*> \endverbatim -*> -*> \param[out] VT -*> \verbatim -*> VT is DOUBLE PRECISION array, dimension (LDVT,N) -*> If JOBVT = 'A', VT contains the N-by-N orthogonal matrix -*> V**T; -*> if JOBVT = 'S', VT contains the first min(m,n) rows of -*> V**T (the right singular vectors, stored rowwise); -*> if JOBVT = 'N' or 'O', VT is not referenced. -*> \endverbatim -*> -*> \param[in] LDVT -*> \verbatim -*> LDVT is INTEGER -*> The leading dimension of the array VT. LDVT >= 1; if -*> JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK; -*> if INFO > 0, WORK(2:MIN(M,N)) contains the unconverged -*> superdiagonal elements of an upper bidiagonal matrix B -*> whose diagonal is in S (not necessarily sorted). B -*> satisfies A = U * B * VT, so it has the same singular values -*> as A, and singular vectors related by U and VT. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. -*> LWORK >= MAX(1,5*MIN(M,N)) for the paths (see comments inside code): -*> - PATH 1 (M much larger than N, JOBU='N') -*> - PATH 1t (N much larger than M, JOBVT='N') -*> LWORK >= MAX(1,3*MIN(M,N) + MAX(M,N),5*MIN(M,N)) for the other paths -*> For good performance, LWORK should generally be larger. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal size of the WORK array, returns -*> this value as the first entry of the WORK array, and no error -*> message related to LWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit. -*> < 0: if INFO = -i, the i-th argument had an illegal value. -*> > 0: if DBDSQR did not converge, INFO specifies how many -*> superdiagonals of an intermediate bidiagonal form B -*> did not converge to zero. See the description of WORK -*> above for details. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleGEsing -* -* ===================================================================== - SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, - $ VT, LDVT, WORK, LWORK, INFO ) -* -* -- LAPACK driver routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER JOBU, JOBVT - INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ), - $ VT( LDVT, * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY, WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS, - $ WNTVA, WNTVAS, WNTVN, WNTVO, WNTVS - INTEGER BDSPAC, BLK, CHUNK, I, IE, IERR, IR, ISCL, - $ ITAU, ITAUP, ITAUQ, IU, IWORK, LDWRKR, LDWRKU, - $ MAXWRK, MINMN, MINWRK, MNTHR, NCU, NCVT, NRU, - $ NRVT, WRKBL - INTEGER LWORK_DGEQRF, LWORK_DORGQR_N, LWORK_DORGQR_M, - $ LWORK_DGEBRD, LWORK_DORGBR_P, LWORK_DORGBR_Q, - $ LWORK_DGELQF, LWORK_DORGLQ_N, LWORK_DORGLQ_M - DOUBLE PRECISION ANRM, BIGNUM, EPS, SMLNUM -* .. -* .. Local Arrays .. - DOUBLE PRECISION DUM( 1 ) -* .. -* .. External Subroutines .. - EXTERNAL DBDSQR, DGEBRD, DGELQF, DGEMM, DGEQRF, DLACPY, - $ DLASCL, DLASET, DORGBR, DORGLQ, DORGQR, DORMBR, - $ XERBLA -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - MINMN = MIN( M, N ) - WNTUA = LSAME( JOBU, 'A' ) - WNTUS = LSAME( JOBU, 'S' ) - WNTUAS = WNTUA .OR. WNTUS - WNTUO = LSAME( JOBU, 'O' ) - WNTUN = LSAME( JOBU, 'N' ) - WNTVA = LSAME( JOBVT, 'A' ) - WNTVS = LSAME( JOBVT, 'S' ) - WNTVAS = WNTVA .OR. WNTVS - WNTVO = LSAME( JOBVT, 'O' ) - WNTVN = LSAME( JOBVT, 'N' ) - LQUERY = ( LWORK.EQ.-1 ) -* - IF( .NOT.( WNTUA .OR. WNTUS .OR. WNTUO .OR. WNTUN ) ) THEN - INFO = -1 - ELSE IF( .NOT.( WNTVA .OR. WNTVS .OR. WNTVO .OR. WNTVN ) .OR. - $ ( WNTVO .AND. WNTUO ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -6 - ELSE IF( LDU.LT.1 .OR. ( WNTUAS .AND. LDU.LT.M ) ) THEN - INFO = -9 - ELSE IF( LDVT.LT.1 .OR. ( WNTVA .AND. LDVT.LT.N ) .OR. - $ ( WNTVS .AND. LDVT.LT.MINMN ) ) THEN - INFO = -11 - END IF -* -* Compute workspace -* (Note: Comments in the code beginning "Workspace:" describe the -* minimal amount of workspace needed at that point in the code, -* as well as the preferred amount for good performance. -* NB refers to the optimal block size for the immediately -* following subroutine, as returned by ILAENV.) -* - IF( INFO.EQ.0 ) THEN - MINWRK = 1 - MAXWRK = 1 - IF( M.GE.N .AND. MINMN.GT.0 ) THEN -* -* Compute space needed for DBDSQR -* - MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 ) - BDSPAC = 5*N -* Compute space needed for DGEQRF - CALL DGEQRF( M, N, A, LDA, DUM(1), DUM(1), -1, IERR ) - LWORK_DGEQRF = INT( DUM(1) ) -* Compute space needed for DORGQR - CALL DORGQR( M, N, N, A, LDA, DUM(1), DUM(1), -1, IERR ) - LWORK_DORGQR_N = INT( DUM(1) ) - CALL DORGQR( M, M, N, A, LDA, DUM(1), DUM(1), -1, IERR ) - LWORK_DORGQR_M = INT( DUM(1) ) -* Compute space needed for DGEBRD - CALL DGEBRD( N, N, A, LDA, S, DUM(1), DUM(1), - $ DUM(1), DUM(1), -1, IERR ) - LWORK_DGEBRD = INT( DUM(1) ) -* Compute space needed for DORGBR P - CALL DORGBR( 'P', N, N, N, A, LDA, DUM(1), - $ DUM(1), -1, IERR ) - LWORK_DORGBR_P = INT( DUM(1) ) -* Compute space needed for DORGBR Q - CALL DORGBR( 'Q', N, N, N, A, LDA, DUM(1), - $ DUM(1), -1, IERR ) - LWORK_DORGBR_Q = INT( DUM(1) ) -* - IF( M.GE.MNTHR ) THEN - IF( WNTUN ) THEN -* -* Path 1 (M much larger than N, JOBU='N') -* - MAXWRK = N + LWORK_DGEQRF - MAXWRK = MAX( MAXWRK, 3*N + LWORK_DGEBRD ) - IF( WNTVO .OR. WNTVAS ) - $ MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORGBR_P ) - MAXWRK = MAX( MAXWRK, BDSPAC ) - MINWRK = MAX( 4*N, BDSPAC ) - ELSE IF( WNTUO .AND. WNTVN ) THEN -* -* Path 2 (M much larger than N, JOBU='O', JOBVT='N') -* - WRKBL = N + LWORK_DGEQRF - WRKBL = MAX( WRKBL, N + LWORK_DORGQR_N ) - WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q ) - WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = MAX( N*N + WRKBL, N*N + M*N + N ) - MINWRK = MAX( 3*N + M, BDSPAC ) - ELSE IF( WNTUO .AND. WNTVAS ) THEN -* -* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or -* 'A') -* - WRKBL = N + LWORK_DGEQRF - WRKBL = MAX( WRKBL, N + LWORK_DORGQR_N ) - WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q ) - WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_P ) - WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = MAX( N*N + WRKBL, N*N + M*N + N ) - MINWRK = MAX( 3*N + M, BDSPAC ) - ELSE IF( WNTUS .AND. WNTVN ) THEN -* -* Path 4 (M much larger than N, JOBU='S', JOBVT='N') -* - WRKBL = N + LWORK_DGEQRF - WRKBL = MAX( WRKBL, N + LWORK_DORGQR_N ) - WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q ) - WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = N*N + WRKBL - MINWRK = MAX( 3*N + M, BDSPAC ) - ELSE IF( WNTUS .AND. WNTVO ) THEN -* -* Path 5 (M much larger than N, JOBU='S', JOBVT='O') -* - WRKBL = N + LWORK_DGEQRF - WRKBL = MAX( WRKBL, N + LWORK_DORGQR_N ) - WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q ) - WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_P ) - WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = 2*N*N + WRKBL - MINWRK = MAX( 3*N + M, BDSPAC ) - ELSE IF( WNTUS .AND. WNTVAS ) THEN -* -* Path 6 (M much larger than N, JOBU='S', JOBVT='S' or -* 'A') -* - WRKBL = N + LWORK_DGEQRF - WRKBL = MAX( WRKBL, N + LWORK_DORGQR_N ) - WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q ) - WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_P ) - WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = N*N + WRKBL - MINWRK = MAX( 3*N + M, BDSPAC ) - ELSE IF( WNTUA .AND. WNTVN ) THEN -* -* Path 7 (M much larger than N, JOBU='A', JOBVT='N') -* - WRKBL = N + LWORK_DGEQRF - WRKBL = MAX( WRKBL, N + LWORK_DORGQR_M ) - WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q ) - WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = N*N + WRKBL - MINWRK = MAX( 3*N + M, BDSPAC ) - ELSE IF( WNTUA .AND. WNTVO ) THEN -* -* Path 8 (M much larger than N, JOBU='A', JOBVT='O') -* - WRKBL = N + LWORK_DGEQRF - WRKBL = MAX( WRKBL, N + LWORK_DORGQR_M ) - WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q ) - WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_P ) - WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = 2*N*N + WRKBL - MINWRK = MAX( 3*N + M, BDSPAC ) - ELSE IF( WNTUA .AND. WNTVAS ) THEN -* -* Path 9 (M much larger than N, JOBU='A', JOBVT='S' or -* 'A') -* - WRKBL = N + LWORK_DGEQRF - WRKBL = MAX( WRKBL, N + LWORK_DORGQR_M ) - WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q ) - WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_P ) - WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = N*N + WRKBL - MINWRK = MAX( 3*N + M, BDSPAC ) - END IF - ELSE -* -* Path 10 (M at least N, but not much larger) -* - CALL DGEBRD( M, N, A, LDA, S, DUM(1), DUM(1), - $ DUM(1), DUM(1), -1, IERR ) - LWORK_DGEBRD = INT( DUM(1) ) - MAXWRK = 3*N + LWORK_DGEBRD - IF( WNTUS .OR. WNTUO ) THEN - CALL DORGBR( 'Q', M, N, N, A, LDA, DUM(1), - $ DUM(1), -1, IERR ) - LWORK_DORGBR_Q = INT( DUM(1) ) - MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORGBR_Q ) - END IF - IF( WNTUA ) THEN - CALL DORGBR( 'Q', M, M, N, A, LDA, DUM(1), - $ DUM(1), -1, IERR ) - LWORK_DORGBR_Q = INT( DUM(1) ) - MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORGBR_Q ) - END IF - IF( .NOT.WNTVN ) THEN - MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORGBR_P ) - END IF - MAXWRK = MAX( MAXWRK, BDSPAC ) - MINWRK = MAX( 3*N + M, BDSPAC ) - END IF - ELSE IF( MINMN.GT.0 ) THEN -* -* Compute space needed for DBDSQR -* - MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 ) - BDSPAC = 5*M -* Compute space needed for DGELQF - CALL DGELQF( M, N, A, LDA, DUM(1), DUM(1), -1, IERR ) - LWORK_DGELQF = INT( DUM(1) ) -* Compute space needed for DORGLQ - CALL DORGLQ( N, N, M, DUM(1), N, DUM(1), DUM(1), -1, IERR ) - LWORK_DORGLQ_N = INT( DUM(1) ) - CALL DORGLQ( M, N, M, A, LDA, DUM(1), DUM(1), -1, IERR ) - LWORK_DORGLQ_M = INT( DUM(1) ) -* Compute space needed for DGEBRD - CALL DGEBRD( M, M, A, LDA, S, DUM(1), DUM(1), - $ DUM(1), DUM(1), -1, IERR ) - LWORK_DGEBRD = INT( DUM(1) ) -* Compute space needed for DORGBR P - CALL DORGBR( 'P', M, M, M, A, N, DUM(1), - $ DUM(1), -1, IERR ) - LWORK_DORGBR_P = INT( DUM(1) ) -* Compute space needed for DORGBR Q - CALL DORGBR( 'Q', M, M, M, A, N, DUM(1), - $ DUM(1), -1, IERR ) - LWORK_DORGBR_Q = INT( DUM(1) ) - IF( N.GE.MNTHR ) THEN - IF( WNTVN ) THEN -* -* Path 1t(N much larger than M, JOBVT='N') -* - MAXWRK = M + LWORK_DGELQF - MAXWRK = MAX( MAXWRK, 3*M + LWORK_DGEBRD ) - IF( WNTUO .OR. WNTUAS ) - $ MAXWRK = MAX( MAXWRK, 3*M + LWORK_DORGBR_Q ) - MAXWRK = MAX( MAXWRK, BDSPAC ) - MINWRK = MAX( 4*M, BDSPAC ) - ELSE IF( WNTVO .AND. WNTUN ) THEN -* -* Path 2t(N much larger than M, JOBU='N', JOBVT='O') -* - WRKBL = M + LWORK_DGELQF - WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_M ) - WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P ) - WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = MAX( M*M + WRKBL, M*M + M*N + M ) - MINWRK = MAX( 3*M + N, BDSPAC ) - ELSE IF( WNTVO .AND. WNTUAS ) THEN -* -* Path 3t(N much larger than M, JOBU='S' or 'A', -* JOBVT='O') -* - WRKBL = M + LWORK_DGELQF - WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_M ) - WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P ) - WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_Q ) - WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = MAX( M*M + WRKBL, M*M + M*N + M ) - MINWRK = MAX( 3*M + N, BDSPAC ) - ELSE IF( WNTVS .AND. WNTUN ) THEN -* -* Path 4t(N much larger than M, JOBU='N', JOBVT='S') -* - WRKBL = M + LWORK_DGELQF - WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_M ) - WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P ) - WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = M*M + WRKBL - MINWRK = MAX( 3*M + N, BDSPAC ) - ELSE IF( WNTVS .AND. WNTUO ) THEN -* -* Path 5t(N much larger than M, JOBU='O', JOBVT='S') -* - WRKBL = M + LWORK_DGELQF - WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_M ) - WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P ) - WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_Q ) - WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = 2*M*M + WRKBL - MINWRK = MAX( 3*M + N, BDSPAC ) - ELSE IF( WNTVS .AND. WNTUAS ) THEN -* -* Path 6t(N much larger than M, JOBU='S' or 'A', -* JOBVT='S') -* - WRKBL = M + LWORK_DGELQF - WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_M ) - WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P ) - WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_Q ) - WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = M*M + WRKBL - MINWRK = MAX( 3*M + N, BDSPAC ) - ELSE IF( WNTVA .AND. WNTUN ) THEN -* -* Path 7t(N much larger than M, JOBU='N', JOBVT='A') -* - WRKBL = M + LWORK_DGELQF - WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_N ) - WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P ) - WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = M*M + WRKBL - MINWRK = MAX( 3*M + N, BDSPAC ) - ELSE IF( WNTVA .AND. WNTUO ) THEN -* -* Path 8t(N much larger than M, JOBU='O', JOBVT='A') -* - WRKBL = M + LWORK_DGELQF - WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_N ) - WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P ) - WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_Q ) - WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = 2*M*M + WRKBL - MINWRK = MAX( 3*M + N, BDSPAC ) - ELSE IF( WNTVA .AND. WNTUAS ) THEN -* -* Path 9t(N much larger than M, JOBU='S' or 'A', -* JOBVT='A') -* - WRKBL = M + LWORK_DGELQF - WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_N ) - WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD ) - WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P ) - WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_Q ) - WRKBL = MAX( WRKBL, BDSPAC ) - MAXWRK = M*M + WRKBL - MINWRK = MAX( 3*M + N, BDSPAC ) - END IF - ELSE -* -* Path 10t(N greater than M, but not much larger) -* - CALL DGEBRD( M, N, A, LDA, S, DUM(1), DUM(1), - $ DUM(1), DUM(1), -1, IERR ) - LWORK_DGEBRD = INT( DUM(1) ) - MAXWRK = 3*M + LWORK_DGEBRD - IF( WNTVS .OR. WNTVO ) THEN -* Compute space needed for DORGBR P - CALL DORGBR( 'P', M, N, M, A, N, DUM(1), - $ DUM(1), -1, IERR ) - LWORK_DORGBR_P = INT( DUM(1) ) - MAXWRK = MAX( MAXWRK, 3*M + LWORK_DORGBR_P ) - END IF - IF( WNTVA ) THEN - CALL DORGBR( 'P', N, N, M, A, N, DUM(1), - $ DUM(1), -1, IERR ) - LWORK_DORGBR_P = INT( DUM(1) ) - MAXWRK = MAX( MAXWRK, 3*M + LWORK_DORGBR_P ) - END IF - IF( .NOT.WNTUN ) THEN - MAXWRK = MAX( MAXWRK, 3*M + LWORK_DORGBR_Q ) - END IF - MAXWRK = MAX( MAXWRK, BDSPAC ) - MINWRK = MAX( 3*M + N, BDSPAC ) - END IF - END IF - MAXWRK = MAX( MAXWRK, MINWRK ) - WORK( 1 ) = MAXWRK -* - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN - INFO = -13 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGESVD', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) THEN - RETURN - END IF -* -* Get machine constants -* - EPS = DLAMCH( 'P' ) - SMLNUM = SQRT( DLAMCH( 'S' ) ) / EPS - BIGNUM = ONE / SMLNUM -* -* Scale A if max element outside range [SMLNUM,BIGNUM] -* - ANRM = DLANGE( 'M', M, N, A, LDA, DUM ) - ISCL = 0 - IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN - ISCL = 1 - CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR ) - ELSE IF( ANRM.GT.BIGNUM ) THEN - ISCL = 1 - CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR ) - END IF -* - IF( M.GE.N ) THEN -* -* A has at least as many rows as columns. If A has sufficiently -* more rows than columns, first reduce using the QR -* decomposition (if sufficient workspace available) -* - IF( M.GE.MNTHR ) THEN -* - IF( WNTUN ) THEN -* -* Path 1 (M much larger than N, JOBU='N') -* No left singular vectors to be computed -* - ITAU = 1 - IWORK = ITAU + N -* -* Compute A=Q*R -* (Workspace: need 2*N, prefer N + N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Zero out below R -* - IF( N .GT. 1 ) THEN - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), - $ LDA ) - END IF - IE = 1 - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in A -* (Workspace: need 4*N, prefer 3*N + 2*N*NB) -* - CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, - $ IERR ) - NCVT = 0 - IF( WNTVO .OR. WNTVAS ) THEN -* -* If right singular vectors desired, generate P'. -* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) -* - CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - NCVT = N - END IF - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing right -* singular vectors of A in A if desired -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, NCVT, 0, 0, S, WORK( IE ), A, LDA, - $ DUM, 1, DUM, 1, WORK( IWORK ), INFO ) -* -* If right singular vectors desired in VT, copy them there -* - IF( WNTVAS ) - $ CALL DLACPY( 'F', N, N, A, LDA, VT, LDVT ) -* - ELSE IF( WNTUO .AND. WNTVN ) THEN -* -* Path 2 (M much larger than N, JOBU='O', JOBVT='N') -* N left singular vectors to be overwritten on A and -* no right singular vectors to be computed -* - IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IR = 1 - IF( LWORK.GE.MAX( WRKBL, LDA*N + N ) + LDA*N ) THEN -* -* WORK(IU) is LDA by N, WORK(IR) is LDA by N -* - LDWRKU = LDA - LDWRKR = LDA - ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N + N ) + N*N ) THEN -* -* WORK(IU) is LDA by N, WORK(IR) is N by N -* - LDWRKU = LDA - LDWRKR = N - ELSE -* -* WORK(IU) is LDWRKU by N, WORK(IR) is N by N -* - LDWRKU = ( LWORK-N*N-N ) / N - LDWRKR = N - END IF - ITAU = IR + LDWRKR*N - IWORK = ITAU + N -* -* Compute A=Q*R -* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R to WORK(IR) and zero out below it -* - CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR ) - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ), - $ LDWRKR ) -* -* Generate Q in A -* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) -* - CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in WORK(IR) -* (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB) -* - CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Generate left vectors bidiagonalizing R -* (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB) -* - CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of R in WORK(IR) -* (Workspace: need N*N + BDSPAC) -* - CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM, 1, - $ WORK( IR ), LDWRKR, DUM, 1, - $ WORK( IWORK ), INFO ) - IU = IE + N -* -* Multiply Q in A by left singular vectors of R in -* WORK(IR), storing result in WORK(IU) and copying to A -* (Workspace: need N*N + 2*N, prefer N*N + M*N + N) -* - DO 10 I = 1, M, LDWRKU - CHUNK = MIN( M-I+1, LDWRKU ) - CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ), - $ LDA, WORK( IR ), LDWRKR, ZERO, - $ WORK( IU ), LDWRKU ) - CALL DLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU, - $ A( I, 1 ), LDA ) - 10 CONTINUE -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - IE = 1 - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize A -* (Workspace: need 3*N + M, prefer 3*N + (M + N)*NB) -* - CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Generate left vectors bidiagonalizing A -* (Workspace: need 4*N, prefer 3*N + N*NB) -* - CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in A -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM, 1, - $ A, LDA, DUM, 1, WORK( IWORK ), INFO ) -* - END IF -* - ELSE IF( WNTUO .AND. WNTVAS ) THEN -* -* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or 'A') -* N left singular vectors to be overwritten on A and -* N right singular vectors to be computed in VT -* - IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IR = 1 - IF( LWORK.GE.MAX( WRKBL, LDA*N + N ) + LDA*N ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is LDA by N -* - LDWRKU = LDA - LDWRKR = LDA - ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N + N ) + N*N ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is N by N -* - LDWRKU = LDA - LDWRKR = N - ELSE -* -* WORK(IU) is LDWRKU by N and WORK(IR) is N by N -* - LDWRKU = ( LWORK-N*N-N ) / N - LDWRKR = N - END IF - ITAU = IR + LDWRKR*N - IWORK = ITAU + N -* -* Compute A=Q*R -* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R to VT, zeroing out below it -* - CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) - IF( N.GT.1 ) - $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ VT( 2, 1 ), LDVT ) -* -* Generate Q in A -* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) -* - CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in VT, copying result to WORK(IR) -* (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB) -* - CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'L', N, N, VT, LDVT, WORK( IR ), LDWRKR ) -* -* Generate left vectors bidiagonalizing R in WORK(IR) -* (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB) -* - CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right vectors bidiagonalizing R in VT -* (Workspace: need N*N + 4*N-1, prefer N*N + 3*N + (N-1)*NB) -* - CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of R in WORK(IR) and computing right -* singular vectors of R in VT -* (Workspace: need N*N + BDSPAC) -* - CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT, LDVT, - $ WORK( IR ), LDWRKR, DUM, 1, - $ WORK( IWORK ), INFO ) - IU = IE + N -* -* Multiply Q in A by left singular vectors of R in -* WORK(IR), storing result in WORK(IU) and copying to A -* (Workspace: need N*N + 2*N, prefer N*N + M*N + N) -* - DO 20 I = 1, M, LDWRKU - CHUNK = MIN( M-I+1, LDWRKU ) - CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ), - $ LDA, WORK( IR ), LDWRKR, ZERO, - $ WORK( IU ), LDWRKU ) - CALL DLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU, - $ A( I, 1 ), LDA ) - 20 CONTINUE -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + N -* -* Compute A=Q*R -* (Workspace: need 2*N, prefer N + N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R to VT, zeroing out below it -* - CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) - IF( N.GT.1 ) - $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ VT( 2, 1 ), LDVT ) -* -* Generate Q in A -* (Workspace: need 2*N, prefer N + N*NB) -* - CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in VT -* (Workspace: need 4*N, prefer 3*N + 2*N*NB) -* - CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply Q in A by left vectors bidiagonalizing R -* (Workspace: need 3*N + M, prefer 3*N + M*NB) -* - CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, - $ WORK( ITAUQ ), A, LDA, WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right vectors bidiagonalizing R in VT -* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) -* - CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in A and computing right -* singular vectors of A in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT, LDVT, - $ A, LDA, DUM, 1, WORK( IWORK ), INFO ) -* - END IF -* - ELSE IF( WNTUS ) THEN -* - IF( WNTVN ) THEN -* -* Path 4 (M much larger than N, JOBU='S', JOBVT='N') -* N left singular vectors to be computed in U and -* no right singular vectors to be computed -* - IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IR = 1 - IF( LWORK.GE.WRKBL+LDA*N ) THEN -* -* WORK(IR) is LDA by N -* - LDWRKR = LDA - ELSE -* -* WORK(IR) is N by N -* - LDWRKR = N - END IF - ITAU = IR + LDWRKR*N - IWORK = ITAU + N -* -* Compute A=Q*R -* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R to WORK(IR), zeroing out below it -* - CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), - $ LDWRKR ) - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ WORK( IR+1 ), LDWRKR ) -* -* Generate Q in A -* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) -* - CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in WORK(IR) -* (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB) -* - CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, - $ WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate left vectors bidiagonalizing R in WORK(IR) -* (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB) -* - CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of R in WORK(IR) -* (Workspace: need N*N + BDSPAC) -* - CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM, - $ 1, WORK( IR ), LDWRKR, DUM, 1, - $ WORK( IWORK ), INFO ) -* -* Multiply Q in A by left singular vectors of R in -* WORK(IR), storing result in U -* (Workspace: need N*N) -* - CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA, - $ WORK( IR ), LDWRKR, ZERO, U, LDU ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (Workspace: need 2*N, prefer N + N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) -* -* Generate Q in U -* (Workspace: need 2*N, prefer N + N*NB) -* - CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Zero out below R in A -* - IF( N .GT. 1 ) THEN - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ A( 2, 1 ), LDA ) - END IF -* -* Bidiagonalize R in A -* (Workspace: need 4*N, prefer 3*N + 2*N*NB) -* - CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply Q in U by left vectors bidiagonalizing R -* (Workspace: need 3*N + M, prefer 3*N + M*NB) -* - CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA, - $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM, - $ 1, U, LDU, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - ELSE IF( WNTVO ) THEN -* -* Path 5 (M much larger than N, JOBU='S', JOBVT='O') -* N left singular vectors to be computed in U and -* N right singular vectors to be overwritten on A -* - IF( LWORK.GE.2*N*N+MAX( 4*N, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IU = 1 - IF( LWORK.GE.WRKBL+2*LDA*N ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is LDA by N -* - LDWRKU = LDA - IR = IU + LDWRKU*N - LDWRKR = LDA - ELSE IF( LWORK.GE.WRKBL+( LDA + N )*N ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is N by N -* - LDWRKU = LDA - IR = IU + LDWRKU*N - LDWRKR = N - ELSE -* -* WORK(IU) is N by N and WORK(IR) is N by N -* - LDWRKU = N - IR = IU + LDWRKU*N - LDWRKR = N - END IF - ITAU = IR + LDWRKR*N - IWORK = ITAU + N -* -* Compute A=Q*R -* (Workspace: need 2*N*N + 2*N, prefer 2*N*N + N + N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R to WORK(IU), zeroing out below it -* - CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ), - $ LDWRKU ) - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ WORK( IU+1 ), LDWRKU ) -* -* Generate Q in A -* (Workspace: need 2*N*N + 2*N, prefer 2*N*N + N + N*NB) -* - CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in WORK(IU), copying result to -* WORK(IR) -* (Workspace: need 2*N*N + 4*N, -* prefer 2*N*N+3*N+2*N*NB) -* - CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S, - $ WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU, - $ WORK( IR ), LDWRKR ) -* -* Generate left bidiagonalizing vectors in WORK(IU) -* (Workspace: need 2*N*N + 4*N, prefer 2*N*N + 3*N + N*NB) -* - CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right bidiagonalizing vectors in WORK(IR) -* (Workspace: need 2*N*N + 4*N-1, -* prefer 2*N*N+3*N+(N-1)*NB) -* - CALL DORGBR( 'P', N, N, N, WORK( IR ), LDWRKR, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of R in WORK(IU) and computing -* right singular vectors of R in WORK(IR) -* (Workspace: need 2*N*N + BDSPAC) -* - CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), - $ WORK( IR ), LDWRKR, WORK( IU ), - $ LDWRKU, DUM, 1, WORK( IWORK ), INFO ) -* -* Multiply Q in A by left singular vectors of R in -* WORK(IU), storing result in U -* (Workspace: need N*N) -* - CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA, - $ WORK( IU ), LDWRKU, ZERO, U, LDU ) -* -* Copy right singular vectors of R to A -* (Workspace: need N*N) -* - CALL DLACPY( 'F', N, N, WORK( IR ), LDWRKR, A, - $ LDA ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (Workspace: need 2*N, prefer N + N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) -* -* Generate Q in U -* (Workspace: need 2*N, prefer N + N*NB) -* - CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Zero out below R in A -* - IF( N .GT. 1 ) THEN - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ A( 2, 1 ), LDA ) - END IF -* -* Bidiagonalize R in A -* (Workspace: need 4*N, prefer 3*N + 2*N*NB) -* - CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply Q in U by left vectors bidiagonalizing R -* (Workspace: need 3*N + M, prefer 3*N + M*NB) -* - CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA, - $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right vectors bidiagonalizing R in A -* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) -* - CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U and computing right -* singular vectors of A in A -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), A, - $ LDA, U, LDU, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - ELSE IF( WNTVAS ) THEN -* -* Path 6 (M much larger than N, JOBU='S', JOBVT='S' -* or 'A') -* N left singular vectors to be computed in U and -* N right singular vectors to be computed in VT -* - IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IU = 1 - IF( LWORK.GE.WRKBL+LDA*N ) THEN -* -* WORK(IU) is LDA by N -* - LDWRKU = LDA - ELSE -* -* WORK(IU) is N by N -* - LDWRKU = N - END IF - ITAU = IU + LDWRKU*N - IWORK = ITAU + N -* -* Compute A=Q*R -* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R to WORK(IU), zeroing out below it -* - CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ), - $ LDWRKU ) - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ WORK( IU+1 ), LDWRKU ) -* -* Generate Q in A -* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) -* - CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in WORK(IU), copying result to VT -* (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB) -* - CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S, - $ WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT, - $ LDVT ) -* -* Generate left bidiagonalizing vectors in WORK(IU) -* (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB) -* - CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right bidiagonalizing vectors in VT -* (Workspace: need N*N + 4*N-1, -* prefer N*N+3*N+(N-1)*NB) -* - CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of R in WORK(IU) and computing -* right singular vectors of R in VT -* (Workspace: need N*N + BDSPAC) -* - CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT, - $ LDVT, WORK( IU ), LDWRKU, DUM, 1, - $ WORK( IWORK ), INFO ) -* -* Multiply Q in A by left singular vectors of R in -* WORK(IU), storing result in U -* (Workspace: need N*N) -* - CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA, - $ WORK( IU ), LDWRKU, ZERO, U, LDU ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (Workspace: need 2*N, prefer N + N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) -* -* Generate Q in U -* (Workspace: need 2*N, prefer N + N*NB) -* - CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R to VT, zeroing out below it -* - CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) - IF( N.GT.1 ) - $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ VT( 2, 1 ), LDVT ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in VT -* (Workspace: need 4*N, prefer 3*N + 2*N*NB) -* - CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply Q in U by left bidiagonalizing vectors -* in VT -* (Workspace: need 3*N + M, prefer 3*N + M*NB) -* - CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, - $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right bidiagonalizing vectors in VT -* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) -* - CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U and computing right -* singular vectors of A in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT, - $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - END IF -* - ELSE IF( WNTUA ) THEN -* - IF( WNTVN ) THEN -* -* Path 7 (M much larger than N, JOBU='A', JOBVT='N') -* M left singular vectors to be computed in U and -* no right singular vectors to be computed -* - IF( LWORK.GE.N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IR = 1 - IF( LWORK.GE.WRKBL+LDA*N ) THEN -* -* WORK(IR) is LDA by N -* - LDWRKR = LDA - ELSE -* -* WORK(IR) is N by N -* - LDWRKR = N - END IF - ITAU = IR + LDWRKR*N - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) -* -* Copy R to WORK(IR), zeroing out below it -* - CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), - $ LDWRKR ) - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ WORK( IR+1 ), LDWRKR ) -* -* Generate Q in U -* (Workspace: need N*N + N + M, prefer N*N + N + M*NB) -* - CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in WORK(IR) -* (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB) -* - CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, - $ WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate left bidiagonalizing vectors in WORK(IR) -* (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB) -* - CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of R in WORK(IR) -* (Workspace: need N*N + BDSPAC) -* - CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM, - $ 1, WORK( IR ), LDWRKR, DUM, 1, - $ WORK( IWORK ), INFO ) -* -* Multiply Q in U by left singular vectors of R in -* WORK(IR), storing result in A -* (Workspace: need N*N) -* - CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU, - $ WORK( IR ), LDWRKR, ZERO, A, LDA ) -* -* Copy left singular vectors of A from A to U -* - CALL DLACPY( 'F', M, N, A, LDA, U, LDU ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (Workspace: need 2*N, prefer N + N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) -* -* Generate Q in U -* (Workspace: need N + M, prefer N + M*NB) -* - CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Zero out below R in A -* - IF( N .GT. 1 ) THEN - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ A( 2, 1 ), LDA ) - END IF -* -* Bidiagonalize R in A -* (Workspace: need 4*N, prefer 3*N + 2*N*NB) -* - CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply Q in U by left bidiagonalizing vectors -* in A -* (Workspace: need 3*N + M, prefer 3*N + M*NB) -* - CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA, - $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM, - $ 1, U, LDU, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - ELSE IF( WNTVO ) THEN -* -* Path 8 (M much larger than N, JOBU='A', JOBVT='O') -* M left singular vectors to be computed in U and -* N right singular vectors to be overwritten on A -* - IF( LWORK.GE.2*N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IU = 1 - IF( LWORK.GE.WRKBL+2*LDA*N ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is LDA by N -* - LDWRKU = LDA - IR = IU + LDWRKU*N - LDWRKR = LDA - ELSE IF( LWORK.GE.WRKBL+( LDA + N )*N ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is N by N -* - LDWRKU = LDA - IR = IU + LDWRKU*N - LDWRKR = N - ELSE -* -* WORK(IU) is N by N and WORK(IR) is N by N -* - LDWRKU = N - IR = IU + LDWRKU*N - LDWRKR = N - END IF - ITAU = IR + LDWRKR*N - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (Workspace: need 2*N*N + 2*N, prefer 2*N*N + N + N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) -* -* Generate Q in U -* (Workspace: need 2*N*N + N + M, prefer 2*N*N + N + M*NB) -* - CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R to WORK(IU), zeroing out below it -* - CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ), - $ LDWRKU ) - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ WORK( IU+1 ), LDWRKU ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in WORK(IU), copying result to -* WORK(IR) -* (Workspace: need 2*N*N + 4*N, -* prefer 2*N*N+3*N+2*N*NB) -* - CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S, - $ WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU, - $ WORK( IR ), LDWRKR ) -* -* Generate left bidiagonalizing vectors in WORK(IU) -* (Workspace: need 2*N*N + 4*N, prefer 2*N*N + 3*N + N*NB) -* - CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right bidiagonalizing vectors in WORK(IR) -* (Workspace: need 2*N*N + 4*N-1, -* prefer 2*N*N+3*N+(N-1)*NB) -* - CALL DORGBR( 'P', N, N, N, WORK( IR ), LDWRKR, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of R in WORK(IU) and computing -* right singular vectors of R in WORK(IR) -* (Workspace: need 2*N*N + BDSPAC) -* - CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), - $ WORK( IR ), LDWRKR, WORK( IU ), - $ LDWRKU, DUM, 1, WORK( IWORK ), INFO ) -* -* Multiply Q in U by left singular vectors of R in -* WORK(IU), storing result in A -* (Workspace: need N*N) -* - CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU, - $ WORK( IU ), LDWRKU, ZERO, A, LDA ) -* -* Copy left singular vectors of A from A to U -* - CALL DLACPY( 'F', M, N, A, LDA, U, LDU ) -* -* Copy right singular vectors of R from WORK(IR) to A -* - CALL DLACPY( 'F', N, N, WORK( IR ), LDWRKR, A, - $ LDA ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (Workspace: need 2*N, prefer N + N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) -* -* Generate Q in U -* (Workspace: need N + M, prefer N + M*NB) -* - CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Zero out below R in A -* - IF( N .GT. 1 ) THEN - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ A( 2, 1 ), LDA ) - END IF -* -* Bidiagonalize R in A -* (Workspace: need 4*N, prefer 3*N + 2*N*NB) -* - CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply Q in U by left bidiagonalizing vectors -* in A -* (Workspace: need 3*N + M, prefer 3*N + M*NB) -* - CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA, - $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right bidiagonalizing vectors in A -* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) -* - CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U and computing right -* singular vectors of A in A -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), A, - $ LDA, U, LDU, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - ELSE IF( WNTVAS ) THEN -* -* Path 9 (M much larger than N, JOBU='A', JOBVT='S' -* or 'A') -* M left singular vectors to be computed in U and -* N right singular vectors to be computed in VT -* - IF( LWORK.GE.N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IU = 1 - IF( LWORK.GE.WRKBL+LDA*N ) THEN -* -* WORK(IU) is LDA by N -* - LDWRKU = LDA - ELSE -* -* WORK(IU) is N by N -* - LDWRKU = N - END IF - ITAU = IU + LDWRKU*N - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) -* -* Generate Q in U -* (Workspace: need N*N + N + M, prefer N*N + N + M*NB) -* - CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R to WORK(IU), zeroing out below it -* - CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ), - $ LDWRKU ) - CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ WORK( IU+1 ), LDWRKU ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in WORK(IU), copying result to VT -* (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB) -* - CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S, - $ WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT, - $ LDVT ) -* -* Generate left bidiagonalizing vectors in WORK(IU) -* (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB) -* - CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right bidiagonalizing vectors in VT -* (Workspace: need N*N + 4*N-1, -* prefer N*N+3*N+(N-1)*NB) -* - CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of R in WORK(IU) and computing -* right singular vectors of R in VT -* (Workspace: need N*N + BDSPAC) -* - CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT, - $ LDVT, WORK( IU ), LDWRKU, DUM, 1, - $ WORK( IWORK ), INFO ) -* -* Multiply Q in U by left singular vectors of R in -* WORK(IU), storing result in A -* (Workspace: need N*N) -* - CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU, - $ WORK( IU ), LDWRKU, ZERO, A, LDA ) -* -* Copy left singular vectors of A from A to U -* - CALL DLACPY( 'F', M, N, A, LDA, U, LDU ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + N -* -* Compute A=Q*R, copying result to U -* (Workspace: need 2*N, prefer N + N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) -* -* Generate Q in U -* (Workspace: need N + M, prefer N + M*NB) -* - CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy R from A to VT, zeroing out below it -* - CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) - IF( N.GT.1 ) - $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, - $ VT( 2, 1 ), LDVT ) - IE = ITAU - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in VT -* (Workspace: need 4*N, prefer 3*N + 2*N*NB) -* - CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply Q in U by left bidiagonalizing vectors -* in VT -* (Workspace: need 3*N + M, prefer 3*N + M*NB) -* - CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, - $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right bidiagonalizing vectors in VT -* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) -* - CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U and computing right -* singular vectors of A in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT, - $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - END IF -* - END IF -* - ELSE -* -* M .LT. MNTHR -* -* Path 10 (M at least N, but not much larger) -* Reduce to bidiagonal form without QR decomposition -* - IE = 1 - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize A -* (Workspace: need 3*N + M, prefer 3*N + (M + N)*NB) -* - CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, - $ IERR ) - IF( WNTUAS ) THEN -* -* If left singular vectors desired in U, copy result to U -* and generate left bidiagonalizing vectors in U -* (Workspace: need 3*N + NCU, prefer 3*N + NCU*NB) -* - CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) - IF( WNTUS ) - $ NCU = N - IF( WNTUA ) - $ NCU = M - CALL DORGBR( 'Q', M, NCU, N, U, LDU, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - END IF - IF( WNTVAS ) THEN -* -* If right singular vectors desired in VT, copy result to -* VT and generate right bidiagonalizing vectors in VT -* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) -* - CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) - CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - END IF - IF( WNTUO ) THEN -* -* If left singular vectors desired in A, generate left -* bidiagonalizing vectors in A -* (Workspace: need 4*N, prefer 3*N + N*NB) -* - CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - END IF - IF( WNTVO ) THEN -* -* If right singular vectors desired in A, generate right -* bidiagonalizing vectors in A -* (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) -* - CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - END IF - IWORK = IE + N - IF( WNTUAS .OR. WNTUO ) - $ NRU = M - IF( WNTUN ) - $ NRU = 0 - IF( WNTVAS .OR. WNTVO ) - $ NCVT = N - IF( WNTVN ) - $ NCVT = 0 - IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN -* -* Perform bidiagonal QR iteration, if desired, computing -* left singular vectors in U and computing right singular -* vectors in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), VT, - $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), INFO ) - ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN -* -* Perform bidiagonal QR iteration, if desired, computing -* left singular vectors in U and computing right singular -* vectors in A -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), A, LDA, - $ U, LDU, DUM, 1, WORK( IWORK ), INFO ) - ELSE -* -* Perform bidiagonal QR iteration, if desired, computing -* left singular vectors in A and computing right singular -* vectors in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), VT, - $ LDVT, A, LDA, DUM, 1, WORK( IWORK ), INFO ) - END IF -* - END IF -* - ELSE -* -* A has more columns than rows. If A has sufficiently more -* columns than rows, first reduce using the LQ decomposition (if -* sufficient workspace available) -* - IF( N.GE.MNTHR ) THEN -* - IF( WNTVN ) THEN -* -* Path 1t(N much larger than M, JOBVT='N') -* No right singular vectors to be computed -* - ITAU = 1 - IWORK = ITAU + M -* -* Compute A=L*Q -* (Workspace: need 2*M, prefer M + M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Zero out above L -* - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA ) - IE = 1 - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in A -* (Workspace: need 4*M, prefer 3*M + 2*M*NB) -* - CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, - $ IERR ) - IF( WNTUO .OR. WNTUAS ) THEN -* -* If left singular vectors desired, generate Q -* (Workspace: need 4*M, prefer 3*M + M*NB) -* - CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - END IF - IWORK = IE + M - NRU = 0 - IF( WNTUO .OR. WNTUAS ) - $ NRU = M -* -* Perform bidiagonal QR iteration, computing left singular -* vectors of A in A if desired -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', M, 0, NRU, 0, S, WORK( IE ), DUM, 1, A, - $ LDA, DUM, 1, WORK( IWORK ), INFO ) -* -* If left singular vectors desired in U, copy them there -* - IF( WNTUAS ) - $ CALL DLACPY( 'F', M, M, A, LDA, U, LDU ) -* - ELSE IF( WNTVO .AND. WNTUN ) THEN -* -* Path 2t(N much larger than M, JOBU='N', JOBVT='O') -* M right singular vectors to be overwritten on A and -* no left singular vectors to be computed -* - IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IR = 1 - IF( LWORK.GE.MAX( WRKBL, LDA*N + M ) + LDA*M ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is LDA by M -* - LDWRKU = LDA - CHUNK = N - LDWRKR = LDA - ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N + M ) + M*M ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is M by M -* - LDWRKU = LDA - CHUNK = N - LDWRKR = M - ELSE -* -* WORK(IU) is M by CHUNK and WORK(IR) is M by M -* - LDWRKU = M - CHUNK = ( LWORK-M*M-M ) / M - LDWRKR = M - END IF - ITAU = IR + LDWRKR*M - IWORK = ITAU + M -* -* Compute A=L*Q -* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to WORK(IR) and zero out above it -* - CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ), LDWRKR ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, - $ WORK( IR+LDWRKR ), LDWRKR ) -* -* Generate Q in A -* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) -* - CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in WORK(IR) -* (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB) -* - CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Generate right vectors bidiagonalizing L -* (Workspace: need M*M + 4*M-1, prefer M*M + 3*M + (M-1)*NB) -* - CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing right -* singular vectors of L in WORK(IR) -* (Workspace: need M*M + BDSPAC) -* - CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ), - $ WORK( IR ), LDWRKR, DUM, 1, DUM, 1, - $ WORK( IWORK ), INFO ) - IU = IE + M -* -* Multiply right singular vectors of L in WORK(IR) by Q -* in A, storing result in WORK(IU) and copying to A -* (Workspace: need M*M + 2*M, prefer M*M + M*N + M) -* - DO 30 I = 1, N, CHUNK - BLK = MIN( N-I+1, CHUNK ) - CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IR ), - $ LDWRKR, A( 1, I ), LDA, ZERO, - $ WORK( IU ), LDWRKU ) - CALL DLACPY( 'F', M, BLK, WORK( IU ), LDWRKU, - $ A( 1, I ), LDA ) - 30 CONTINUE -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - IE = 1 - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize A -* (Workspace: need 3*M + N, prefer 3*M + (M + N)*NB) -* - CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Generate right vectors bidiagonalizing A -* (Workspace: need 4*M, prefer 3*M + M*NB) -* - CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing right -* singular vectors of A in A -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'L', M, N, 0, 0, S, WORK( IE ), A, LDA, - $ DUM, 1, DUM, 1, WORK( IWORK ), INFO ) -* - END IF -* - ELSE IF( WNTVO .AND. WNTUAS ) THEN -* -* Path 3t(N much larger than M, JOBU='S' or 'A', JOBVT='O') -* M right singular vectors to be overwritten on A and -* M left singular vectors to be computed in U -* - IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IR = 1 - IF( LWORK.GE.MAX( WRKBL, LDA*N + M ) + LDA*M ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is LDA by M -* - LDWRKU = LDA - CHUNK = N - LDWRKR = LDA - ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N + M ) + M*M ) THEN -* -* WORK(IU) is LDA by N and WORK(IR) is M by M -* - LDWRKU = LDA - CHUNK = N - LDWRKR = M - ELSE -* -* WORK(IU) is M by CHUNK and WORK(IR) is M by M -* - LDWRKU = M - CHUNK = ( LWORK-M*M-M ) / M - LDWRKR = M - END IF - ITAU = IR + LDWRKR*M - IWORK = ITAU + M -* -* Compute A=L*Q -* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to U, zeroing about above it -* - CALL DLACPY( 'L', M, M, A, LDA, U, LDU ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ), - $ LDU ) -* -* Generate Q in A -* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) -* - CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in U, copying result to WORK(IR) -* (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB) -* - CALL DGEBRD( M, M, U, LDU, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'U', M, M, U, LDU, WORK( IR ), LDWRKR ) -* -* Generate right vectors bidiagonalizing L in WORK(IR) -* (Workspace: need M*M + 4*M-1, prefer M*M + 3*M + (M-1)*NB) -* - CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate left vectors bidiagonalizing L in U -* (Workspace: need M*M + 4*M, prefer M*M + 3*M + M*NB) -* - CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of L in U, and computing right -* singular vectors of L in WORK(IR) -* (Workspace: need M*M + BDSPAC) -* - CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), - $ WORK( IR ), LDWRKR, U, LDU, DUM, 1, - $ WORK( IWORK ), INFO ) - IU = IE + M -* -* Multiply right singular vectors of L in WORK(IR) by Q -* in A, storing result in WORK(IU) and copying to A -* (Workspace: need M*M + 2*M, prefer M*M + M*N + M)) -* - DO 40 I = 1, N, CHUNK - BLK = MIN( N-I+1, CHUNK ) - CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IR ), - $ LDWRKR, A( 1, I ), LDA, ZERO, - $ WORK( IU ), LDWRKU ) - CALL DLACPY( 'F', M, BLK, WORK( IU ), LDWRKU, - $ A( 1, I ), LDA ) - 40 CONTINUE -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + M -* -* Compute A=L*Q -* (Workspace: need 2*M, prefer M + M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to U, zeroing out above it -* - CALL DLACPY( 'L', M, M, A, LDA, U, LDU ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ), - $ LDU ) -* -* Generate Q in A -* (Workspace: need 2*M, prefer M + M*NB) -* - CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in U -* (Workspace: need 4*M, prefer 3*M + 2*M*NB) -* - CALL DGEBRD( M, M, U, LDU, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply right vectors bidiagonalizing L by Q in A -* (Workspace: need 3*M + N, prefer 3*M + N*NB) -* - CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU, - $ WORK( ITAUP ), A, LDA, WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate left vectors bidiagonalizing L in U -* (Workspace: need 4*M, prefer 3*M + M*NB) -* - CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U and computing right -* singular vectors of A in A -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), A, LDA, - $ U, LDU, DUM, 1, WORK( IWORK ), INFO ) -* - END IF -* - ELSE IF( WNTVS ) THEN -* - IF( WNTUN ) THEN -* -* Path 4t(N much larger than M, JOBU='N', JOBVT='S') -* M right singular vectors to be computed in VT and -* no left singular vectors to be computed -* - IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IR = 1 - IF( LWORK.GE.WRKBL+LDA*M ) THEN -* -* WORK(IR) is LDA by M -* - LDWRKR = LDA - ELSE -* -* WORK(IR) is M by M -* - LDWRKR = M - END IF - ITAU = IR + LDWRKR*M - IWORK = ITAU + M -* -* Compute A=L*Q -* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to WORK(IR), zeroing out above it -* - CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ), - $ LDWRKR ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, - $ WORK( IR+LDWRKR ), LDWRKR ) -* -* Generate Q in A -* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) -* - CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in WORK(IR) -* (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB) -* - CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S, - $ WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right vectors bidiagonalizing L in -* WORK(IR) -* (Workspace: need M*M + 4*M, prefer M*M + 3*M + (M-1)*NB) -* - CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing right -* singular vectors of L in WORK(IR) -* (Workspace: need M*M + BDSPAC) -* - CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ), - $ WORK( IR ), LDWRKR, DUM, 1, DUM, 1, - $ WORK( IWORK ), INFO ) -* -* Multiply right singular vectors of L in WORK(IR) by -* Q in A, storing result in VT -* (Workspace: need M*M) -* - CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IR ), - $ LDWRKR, A, LDA, ZERO, VT, LDVT ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + M -* -* Compute A=L*Q -* (Workspace: need 2*M, prefer M + M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy result to VT -* - CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) -* -* Generate Q in VT -* (Workspace: need 2*M, prefer M + M*NB) -* - CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Zero out above L in A -* - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), - $ LDA ) -* -* Bidiagonalize L in A -* (Workspace: need 4*M, prefer 3*M + 2*M*NB) -* - CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply right vectors bidiagonalizing L by Q in VT -* (Workspace: need 3*M + N, prefer 3*M + N*NB) -* - CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA, - $ WORK( ITAUP ), VT, LDVT, - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing right -* singular vectors of A in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', M, N, 0, 0, S, WORK( IE ), VT, - $ LDVT, DUM, 1, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - ELSE IF( WNTUO ) THEN -* -* Path 5t(N much larger than M, JOBU='O', JOBVT='S') -* M right singular vectors to be computed in VT and -* M left singular vectors to be overwritten on A -* - IF( LWORK.GE.2*M*M+MAX( 4*M, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IU = 1 - IF( LWORK.GE.WRKBL+2*LDA*M ) THEN -* -* WORK(IU) is LDA by M and WORK(IR) is LDA by M -* - LDWRKU = LDA - IR = IU + LDWRKU*M - LDWRKR = LDA - ELSE IF( LWORK.GE.WRKBL+( LDA + M )*M ) THEN -* -* WORK(IU) is LDA by M and WORK(IR) is M by M -* - LDWRKU = LDA - IR = IU + LDWRKU*M - LDWRKR = M - ELSE -* -* WORK(IU) is M by M and WORK(IR) is M by M -* - LDWRKU = M - IR = IU + LDWRKU*M - LDWRKR = M - END IF - ITAU = IR + LDWRKR*M - IWORK = ITAU + M -* -* Compute A=L*Q -* (Workspace: need 2*M*M + 2*M, prefer 2*M*M + M + M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to WORK(IU), zeroing out below it -* - CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ), - $ LDWRKU ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, - $ WORK( IU+LDWRKU ), LDWRKU ) -* -* Generate Q in A -* (Workspace: need 2*M*M + 2*M, prefer 2*M*M + M + M*NB) -* - CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in WORK(IU), copying result to -* WORK(IR) -* (Workspace: need 2*M*M + 4*M, -* prefer 2*M*M+3*M+2*M*NB) -* - CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S, - $ WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU, - $ WORK( IR ), LDWRKR ) -* -* Generate right bidiagonalizing vectors in WORK(IU) -* (Workspace: need 2*M*M + 4*M-1, -* prefer 2*M*M+3*M+(M-1)*NB) -* - CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate left bidiagonalizing vectors in WORK(IR) -* (Workspace: need 2*M*M + 4*M, prefer 2*M*M + 3*M + M*NB) -* - CALL DORGBR( 'Q', M, M, M, WORK( IR ), LDWRKR, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of L in WORK(IR) and computing -* right singular vectors of L in WORK(IU) -* (Workspace: need 2*M*M + BDSPAC) -* - CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), - $ WORK( IU ), LDWRKU, WORK( IR ), - $ LDWRKR, DUM, 1, WORK( IWORK ), INFO ) -* -* Multiply right singular vectors of L in WORK(IU) by -* Q in A, storing result in VT -* (Workspace: need M*M) -* - CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ), - $ LDWRKU, A, LDA, ZERO, VT, LDVT ) -* -* Copy left singular vectors of L to A -* (Workspace: need M*M) -* - CALL DLACPY( 'F', M, M, WORK( IR ), LDWRKR, A, - $ LDA ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + M -* -* Compute A=L*Q, copying result to VT -* (Workspace: need 2*M, prefer M + M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) -* -* Generate Q in VT -* (Workspace: need 2*M, prefer M + M*NB) -* - CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Zero out above L in A -* - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), - $ LDA ) -* -* Bidiagonalize L in A -* (Workspace: need 4*M, prefer 3*M + 2*M*NB) -* - CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply right vectors bidiagonalizing L by Q in VT -* (Workspace: need 3*M + N, prefer 3*M + N*NB) -* - CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA, - $ WORK( ITAUP ), VT, LDVT, - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Generate left bidiagonalizing vectors of L in A -* (Workspace: need 4*M, prefer 3*M + M*NB) -* - CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, compute left -* singular vectors of A in A and compute right -* singular vectors of A in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT, - $ LDVT, A, LDA, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - ELSE IF( WNTUAS ) THEN -* -* Path 6t(N much larger than M, JOBU='S' or 'A', -* JOBVT='S') -* M right singular vectors to be computed in VT and -* M left singular vectors to be computed in U -* - IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IU = 1 - IF( LWORK.GE.WRKBL+LDA*M ) THEN -* -* WORK(IU) is LDA by N -* - LDWRKU = LDA - ELSE -* -* WORK(IU) is LDA by M -* - LDWRKU = M - END IF - ITAU = IU + LDWRKU*M - IWORK = ITAU + M -* -* Compute A=L*Q -* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to WORK(IU), zeroing out above it -* - CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ), - $ LDWRKU ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, - $ WORK( IU+LDWRKU ), LDWRKU ) -* -* Generate Q in A -* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) -* - CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in WORK(IU), copying result to U -* (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB) -* - CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S, - $ WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU, U, - $ LDU ) -* -* Generate right bidiagonalizing vectors in WORK(IU) -* (Workspace: need M*M + 4*M-1, -* prefer M*M+3*M+(M-1)*NB) -* - CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate left bidiagonalizing vectors in U -* (Workspace: need M*M + 4*M, prefer M*M + 3*M + M*NB) -* - CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of L in U and computing right -* singular vectors of L in WORK(IU) -* (Workspace: need M*M + BDSPAC) -* - CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), - $ WORK( IU ), LDWRKU, U, LDU, DUM, 1, - $ WORK( IWORK ), INFO ) -* -* Multiply right singular vectors of L in WORK(IU) by -* Q in A, storing result in VT -* (Workspace: need M*M) -* - CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ), - $ LDWRKU, A, LDA, ZERO, VT, LDVT ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + M -* -* Compute A=L*Q, copying result to VT -* (Workspace: need 2*M, prefer M + M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) -* -* Generate Q in VT -* (Workspace: need 2*M, prefer M + M*NB) -* - CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to U, zeroing out above it -* - CALL DLACPY( 'L', M, M, A, LDA, U, LDU ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ), - $ LDU ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in U -* (Workspace: need 4*M, prefer 3*M + 2*M*NB) -* - CALL DGEBRD( M, M, U, LDU, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply right bidiagonalizing vectors in U by Q -* in VT -* (Workspace: need 3*M + N, prefer 3*M + N*NB) -* - CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU, - $ WORK( ITAUP ), VT, LDVT, - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Generate left bidiagonalizing vectors in U -* (Workspace: need 4*M, prefer 3*M + M*NB) -* - CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U and computing right -* singular vectors of A in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT, - $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - END IF -* - ELSE IF( WNTVA ) THEN -* - IF( WNTUN ) THEN -* -* Path 7t(N much larger than M, JOBU='N', JOBVT='A') -* N right singular vectors to be computed in VT and -* no left singular vectors to be computed -* - IF( LWORK.GE.M*M+MAX( N + M, 4*M, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IR = 1 - IF( LWORK.GE.WRKBL+LDA*M ) THEN -* -* WORK(IR) is LDA by M -* - LDWRKR = LDA - ELSE -* -* WORK(IR) is M by M -* - LDWRKR = M - END IF - ITAU = IR + LDWRKR*M - IWORK = ITAU + M -* -* Compute A=L*Q, copying result to VT -* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) -* -* Copy L to WORK(IR), zeroing out above it -* - CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ), - $ LDWRKR ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, - $ WORK( IR+LDWRKR ), LDWRKR ) -* -* Generate Q in VT -* (Workspace: need M*M + M + N, prefer M*M + M + N*NB) -* - CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in WORK(IR) -* (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB) -* - CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S, - $ WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate right bidiagonalizing vectors in WORK(IR) -* (Workspace: need M*M + 4*M-1, -* prefer M*M+3*M+(M-1)*NB) -* - CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing right -* singular vectors of L in WORK(IR) -* (Workspace: need M*M + BDSPAC) -* - CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ), - $ WORK( IR ), LDWRKR, DUM, 1, DUM, 1, - $ WORK( IWORK ), INFO ) -* -* Multiply right singular vectors of L in WORK(IR) by -* Q in VT, storing result in A -* (Workspace: need M*M) -* - CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IR ), - $ LDWRKR, VT, LDVT, ZERO, A, LDA ) -* -* Copy right singular vectors of A from A to VT -* - CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + M -* -* Compute A=L*Q, copying result to VT -* (Workspace: need 2*M, prefer M + M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) -* -* Generate Q in VT -* (Workspace: need M + N, prefer M + N*NB) -* - CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Zero out above L in A -* - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), - $ LDA ) -* -* Bidiagonalize L in A -* (Workspace: need 4*M, prefer 3*M + 2*M*NB) -* - CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply right bidiagonalizing vectors in A by Q -* in VT -* (Workspace: need 3*M + N, prefer 3*M + N*NB) -* - CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA, - $ WORK( ITAUP ), VT, LDVT, - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing right -* singular vectors of A in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', M, N, 0, 0, S, WORK( IE ), VT, - $ LDVT, DUM, 1, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - ELSE IF( WNTUO ) THEN -* -* Path 8t(N much larger than M, JOBU='O', JOBVT='A') -* N right singular vectors to be computed in VT and -* M left singular vectors to be overwritten on A -* - IF( LWORK.GE.2*M*M+MAX( N + M, 4*M, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IU = 1 - IF( LWORK.GE.WRKBL+2*LDA*M ) THEN -* -* WORK(IU) is LDA by M and WORK(IR) is LDA by M -* - LDWRKU = LDA - IR = IU + LDWRKU*M - LDWRKR = LDA - ELSE IF( LWORK.GE.WRKBL+( LDA + M )*M ) THEN -* -* WORK(IU) is LDA by M and WORK(IR) is M by M -* - LDWRKU = LDA - IR = IU + LDWRKU*M - LDWRKR = M - ELSE -* -* WORK(IU) is M by M and WORK(IR) is M by M -* - LDWRKU = M - IR = IU + LDWRKU*M - LDWRKR = M - END IF - ITAU = IR + LDWRKR*M - IWORK = ITAU + M -* -* Compute A=L*Q, copying result to VT -* (Workspace: need 2*M*M + 2*M, prefer 2*M*M + M + M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) -* -* Generate Q in VT -* (Workspace: need 2*M*M + M + N, prefer 2*M*M + M + N*NB) -* - CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to WORK(IU), zeroing out above it -* - CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ), - $ LDWRKU ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, - $ WORK( IU+LDWRKU ), LDWRKU ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in WORK(IU), copying result to -* WORK(IR) -* (Workspace: need 2*M*M + 4*M, -* prefer 2*M*M+3*M+2*M*NB) -* - CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S, - $ WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU, - $ WORK( IR ), LDWRKR ) -* -* Generate right bidiagonalizing vectors in WORK(IU) -* (Workspace: need 2*M*M + 4*M-1, -* prefer 2*M*M+3*M+(M-1)*NB) -* - CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate left bidiagonalizing vectors in WORK(IR) -* (Workspace: need 2*M*M + 4*M, prefer 2*M*M + 3*M + M*NB) -* - CALL DORGBR( 'Q', M, M, M, WORK( IR ), LDWRKR, - $ WORK( ITAUQ ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of L in WORK(IR) and computing -* right singular vectors of L in WORK(IU) -* (Workspace: need 2*M*M + BDSPAC) -* - CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), - $ WORK( IU ), LDWRKU, WORK( IR ), - $ LDWRKR, DUM, 1, WORK( IWORK ), INFO ) -* -* Multiply right singular vectors of L in WORK(IU) by -* Q in VT, storing result in A -* (Workspace: need M*M) -* - CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ), - $ LDWRKU, VT, LDVT, ZERO, A, LDA ) -* -* Copy right singular vectors of A from A to VT -* - CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT ) -* -* Copy left singular vectors of A from WORK(IR) to A -* - CALL DLACPY( 'F', M, M, WORK( IR ), LDWRKR, A, - $ LDA ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + M -* -* Compute A=L*Q, copying result to VT -* (Workspace: need 2*M, prefer M + M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) -* -* Generate Q in VT -* (Workspace: need M + N, prefer M + N*NB) -* - CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Zero out above L in A -* - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), - $ LDA ) -* -* Bidiagonalize L in A -* (Workspace: need 4*M, prefer 3*M + 2*M*NB) -* - CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply right bidiagonalizing vectors in A by Q -* in VT -* (Workspace: need 3*M + N, prefer 3*M + N*NB) -* - CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA, - $ WORK( ITAUP ), VT, LDVT, - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Generate left bidiagonalizing vectors in A -* (Workspace: need 4*M, prefer 3*M + M*NB) -* - CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in A and computing right -* singular vectors of A in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT, - $ LDVT, A, LDA, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - ELSE IF( WNTUAS ) THEN -* -* Path 9t(N much larger than M, JOBU='S' or 'A', -* JOBVT='A') -* N right singular vectors to be computed in VT and -* M left singular vectors to be computed in U -* - IF( LWORK.GE.M*M+MAX( N + M, 4*M, BDSPAC ) ) THEN -* -* Sufficient workspace for a fast algorithm -* - IU = 1 - IF( LWORK.GE.WRKBL+LDA*M ) THEN -* -* WORK(IU) is LDA by M -* - LDWRKU = LDA - ELSE -* -* WORK(IU) is M by M -* - LDWRKU = M - END IF - ITAU = IU + LDWRKU*M - IWORK = ITAU + M -* -* Compute A=L*Q, copying result to VT -* (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) -* -* Generate Q in VT -* (Workspace: need M*M + M + N, prefer M*M + M + N*NB) -* - CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to WORK(IU), zeroing out above it -* - CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ), - $ LDWRKU ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, - $ WORK( IU+LDWRKU ), LDWRKU ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in WORK(IU), copying result to U -* (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB) -* - CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S, - $ WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) - CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU, U, - $ LDU ) -* -* Generate right bidiagonalizing vectors in WORK(IU) -* (Workspace: need M*M + 4*M, prefer M*M + 3*M + (M-1)*NB) -* - CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU, - $ WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, IERR ) -* -* Generate left bidiagonalizing vectors in U -* (Workspace: need M*M + 4*M, prefer M*M + 3*M + M*NB) -* - CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of L in U and computing right -* singular vectors of L in WORK(IU) -* (Workspace: need M*M + BDSPAC) -* - CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), - $ WORK( IU ), LDWRKU, U, LDU, DUM, 1, - $ WORK( IWORK ), INFO ) -* -* Multiply right singular vectors of L in WORK(IU) by -* Q in VT, storing result in A -* (Workspace: need M*M) -* - CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ), - $ LDWRKU, VT, LDVT, ZERO, A, LDA ) -* -* Copy right singular vectors of A from A to VT -* - CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT ) -* - ELSE -* -* Insufficient workspace for a fast algorithm -* - ITAU = 1 - IWORK = ITAU + M -* -* Compute A=L*Q, copying result to VT -* (Workspace: need 2*M, prefer M + M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) -* -* Generate Q in VT -* (Workspace: need M + N, prefer M + N*NB) -* - CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Copy L to U, zeroing out above it -* - CALL DLACPY( 'L', M, M, A, LDA, U, LDU ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ), - $ LDU ) - IE = ITAU - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in U -* (Workspace: need 4*M, prefer 3*M + 2*M*NB) -* - CALL DGEBRD( M, M, U, LDU, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Multiply right bidiagonalizing vectors in U by Q -* in VT -* (Workspace: need 3*M + N, prefer 3*M + N*NB) -* - CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU, - $ WORK( ITAUP ), VT, LDVT, - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) -* -* Generate left bidiagonalizing vectors in U -* (Workspace: need 4*M, prefer 3*M + M*NB) -* - CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, computing left -* singular vectors of A in U and computing right -* singular vectors of A in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT, - $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), - $ INFO ) -* - END IF -* - END IF -* - END IF -* - ELSE -* -* N .LT. MNTHR -* -* Path 10t(N greater than M, but not much larger) -* Reduce to bidiagonal form without LQ decomposition -* - IE = 1 - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize A -* (Workspace: need 3*M + N, prefer 3*M + (M + N)*NB) -* - CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, - $ IERR ) - IF( WNTUAS ) THEN -* -* If left singular vectors desired in U, copy result to U -* and generate left bidiagonalizing vectors in U -* (Workspace: need 4*M-1, prefer 3*M + (M-1)*NB) -* - CALL DLACPY( 'L', M, M, A, LDA, U, LDU ) - CALL DORGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - END IF - IF( WNTVAS ) THEN -* -* If right singular vectors desired in VT, copy result to -* VT and generate right bidiagonalizing vectors in VT -* (Workspace: need 3*M + NRVT, prefer 3*M + NRVT*NB) -* - CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) - IF( WNTVA ) - $ NRVT = N - IF( WNTVS ) - $ NRVT = M - CALL DORGBR( 'P', NRVT, N, M, VT, LDVT, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - END IF - IF( WNTUO ) THEN -* -* If left singular vectors desired in A, generate left -* bidiagonalizing vectors in A -* (Workspace: need 4*M-1, prefer 3*M + (M-1)*NB) -* - CALL DORGBR( 'Q', M, M, N, A, LDA, WORK( ITAUQ ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - END IF - IF( WNTVO ) THEN -* -* If right singular vectors desired in A, generate right -* bidiagonalizing vectors in A -* (Workspace: need 4*M, prefer 3*M + M*NB) -* - CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, IERR ) - END IF - IWORK = IE + M - IF( WNTUAS .OR. WNTUO ) - $ NRU = M - IF( WNTUN ) - $ NRU = 0 - IF( WNTVAS .OR. WNTVO ) - $ NCVT = N - IF( WNTVN ) - $ NCVT = 0 - IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN -* -* Perform bidiagonal QR iteration, if desired, computing -* left singular vectors in U and computing right singular -* vectors in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), VT, - $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), INFO ) - ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN -* -* Perform bidiagonal QR iteration, if desired, computing -* left singular vectors in U and computing right singular -* vectors in A -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), A, LDA, - $ U, LDU, DUM, 1, WORK( IWORK ), INFO ) - ELSE -* -* Perform bidiagonal QR iteration, if desired, computing -* left singular vectors in A and computing right singular -* vectors in VT -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), VT, - $ LDVT, A, LDA, DUM, 1, WORK( IWORK ), INFO ) - END IF -* - END IF -* - END IF -* -* If DBDSQR failed to converge, copy unconverged superdiagonals -* to WORK( 2:MINMN ) -* - IF( INFO.NE.0 ) THEN - IF( IE.GT.2 ) THEN - DO 50 I = 1, MINMN - 1 - WORK( I+1 ) = WORK( I+IE-1 ) - 50 CONTINUE - END IF - IF( IE.LT.2 ) THEN - DO 60 I = MINMN - 1, 1, -1 - WORK( I+1 ) = WORK( I+IE-1 ) - 60 CONTINUE - END IF - END IF -* -* Undo scaling if necessary -* - IF( ISCL.EQ.1 ) THEN - IF( ANRM.GT.BIGNUM ) - $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN, - $ IERR ) - IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM ) - $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN-1, 1, WORK( 2 ), - $ MINMN, IERR ) - IF( ANRM.LT.SMLNUM ) - $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN, - $ IERR ) - IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM ) - $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN-1, 1, WORK( 2 ), - $ MINMN, IERR ) - END IF -* -* Return optimal workspace in WORK(1) -* - WORK( 1 ) = MAXWRK -* - RETURN -* -* End of DGESVD -* - END diff --git a/lib/linalg/dgetf2.cpp b/lib/linalg/dgetf2.cpp new file mode 100644 index 0000000000..debebd53a0 --- /dev/null +++ b/lib/linalg/dgetf2.cpp @@ -0,0 +1,76 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +static doublereal c_b8 = -1.; +int dgetf2_(integer *m, integer *n, doublereal *a, integer *lda, integer *ipiv, integer *info) +{ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublereal d__1; + integer i__, j, jp; + extern int dger_(integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, integer *), + dscal_(integer *, doublereal *, doublereal *, integer *); + doublereal sfmin; + extern int dswap_(integer *, doublereal *, integer *, doublereal *, integer *); + extern doublereal dlamch_(char *, ftnlen); + extern integer idamax_(integer *, doublereal *, integer *); + extern int xerbla_(char *, integer *, ftnlen); + 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 *)"DGETF2", &i__1, (ftnlen)6); + return 0; + } + if (*m == 0 || *n == 0) { + return 0; + } + sfmin = dlamch_((char *)"S", (ftnlen)1); + i__1 = min(*m, *n); + for (j = 1; j <= i__1; ++j) { + i__2 = *m - j + 1; + jp = j - 1 + idamax_(&i__2, &a[j + j * a_dim1], &c__1); + ipiv[j] = jp; + if (a[jp + j * a_dim1] != 0.) { + if (jp != j) { + dswap_(n, &a[j + a_dim1], lda, &a[jp + a_dim1], lda); + } + if (j < *m) { + if ((d__1 = a[j + j * a_dim1], abs(d__1)) >= sfmin) { + i__2 = *m - j; + d__1 = 1. / a[j + j * a_dim1]; + dscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1); + } else { + i__2 = *m - j; + for (i__ = 1; i__ <= i__2; ++i__) { + a[j + i__ + j * a_dim1] /= a[j + j * a_dim1]; + } + } + } + } else if (*info == 0) { + *info = j; + } + if (j < min(*m, *n)) { + i__2 = *m - j; + i__3 = *n - j; + dger_(&i__2, &i__3, &c_b8, &a[j + 1 + j * a_dim1], &c__1, &a[j + (j + 1) * a_dim1], lda, + &a[j + 1 + (j + 1) * a_dim1], lda); + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dgetf2.f b/lib/linalg/dgetf2.f deleted file mode 100644 index fc1587842e..0000000000 --- a/lib/linalg/dgetf2.f +++ /dev/null @@ -1,210 +0,0 @@ -*> \brief \b DGETF2 computes the LU factorization of a general m-by-n matrix using partial pivoting with row interchanges (unblocked algorithm). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGETF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* DOUBLE PRECISION A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGETF2 computes an LU factorization of a general m-by-n matrix A -*> using partial pivoting with row interchanges. -*> -*> The factorization has the form -*> A = P * L * U -*> where P is a permutation matrix, L is lower triangular with unit -*> diagonal elements (lower trapezoidal if m > n), and U is upper -*> triangular (upper trapezoidal if m < n). -*> -*> This is the right-looking Level 2 BLAS version of the algorithm. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the m by n matrix to be factored. -*> On exit, the factors L and U from the factorization -*> A = P*L*U; the unit diagonal elements of L are not stored. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[out] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (min(M,N)) -*> The pivot indices; for 1 <= i <= min(M,N), row i of the -*> matrix was interchanged with row IPIV(i). -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -k, the k-th argument had an illegal value -*> > 0: if INFO = k, U(k,k) is exactly zero. The factorization -*> has been completed, but the factor U is exactly -*> singular, and division by zero will occur if it is used -*> to solve a system of equations. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleGEcomputational -* -* ===================================================================== - SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION SFMIN - INTEGER I, J, JP -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - INTEGER IDAMAX - EXTERNAL DLAMCH, IDAMAX -* .. -* .. External Subroutines .. - EXTERNAL DGER, DSCAL, DSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Compute machine safe minimum -* - SFMIN = DLAMCH('S') -* - DO 10 J = 1, MIN( M, N ) -* -* Find pivot and test for singularity. -* - JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 ) - IPIV( J ) = JP - IF( A( JP, J ).NE.ZERO ) THEN -* -* Apply the interchange to columns 1:N. -* - IF( JP.NE.J ) - $ CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) -* -* Compute elements J+1:M of J-th column. -* - IF( J.LT.M ) THEN - IF( ABS(A( J, J )) .GE. SFMIN ) THEN - CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) - ELSE - DO 20 I = 1, M-J - A( J+I, J ) = A( J+I, J ) / A( J, J ) - 20 CONTINUE - END IF - END IF -* - ELSE IF( INFO.EQ.0 ) THEN -* - INFO = J - END IF -* - IF( J.LT.MIN( M, N ) ) THEN -* -* Update trailing submatrix. -* - CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA, - $ A( J+1, J+1 ), LDA ) - END IF - 10 CONTINUE - RETURN -* -* End of DGETF2 -* - END diff --git a/lib/linalg/dgetrf.cpp b/lib/linalg/dgetrf.cpp new file mode 100644 index 0000000000..a41a6ae69f --- /dev/null +++ b/lib/linalg/dgetrf.cpp @@ -0,0 +1,90 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +static integer c_n1 = -1; +static doublereal c_b16 = 1.; +static doublereal c_b19 = -1.; +int dgetrf_(integer *m, integer *n, doublereal *a, integer *lda, integer *ipiv, integer *info) +{ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + integer i__, j, jb, nb; + extern int dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, + ftnlen, ftnlen); + integer iinfo; + extern int dtrsm_(char *, char *, char *, char *, integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, + ftnlen), + xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, + ftnlen, ftnlen); + extern int dlaswp_(integer *, doublereal *, integer *, integer *, integer *, integer *, + integer *), + dgetrf2_(integer *, integer *, doublereal *, 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 *)"DGETRF", &i__1, (ftnlen)6); + return 0; + } + if (*m == 0 || *n == 0) { + return 0; + } + nb = ilaenv_(&c__1, (char *)"DGETRF", (char *)" ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); + if (nb <= 1 || nb >= min(*m, *n)) { + dgetrf2_(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; + dgetrf2_(&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; + dlaswp_(&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; + dlaswp_(&i__3, &a[(j + jb) * a_dim1 + 1], lda, &j, &i__4, &ipiv[1], &c__1); + i__3 = *n - j - jb + 1; + dtrsm_((char *)"Left", (char *)"Lower", (char *)"No transpose", (char *)"Unit", &jb, &i__3, &c_b16, + &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; + dgemm_((char *)"No transpose", (char *)"No transpose", &i__3, &i__4, &jb, &c_b19, + &a[j + jb + j * a_dim1], lda, &a[j + (j + jb) * a_dim1], lda, &c_b16, + &a[j + jb + (j + jb) * a_dim1], lda, (ftnlen)12, (ftnlen)12); + } + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dgetrf.f b/lib/linalg/dgetrf.f deleted file mode 100644 index 73d0f3601a..0000000000 --- a/lib/linalg/dgetrf.f +++ /dev/null @@ -1,222 +0,0 @@ -*> \brief \b DGETRF -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGETRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* DOUBLE PRECISION A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGETRF computes an LU factorization of a general M-by-N matrix A -*> using partial pivoting with row interchanges. -*> -*> The factorization has the form -*> A = P * L * U -*> where P is a permutation matrix, L is lower triangular with unit -*> diagonal elements (lower trapezoidal if m > n), and U is upper -*> triangular (upper trapezoidal if m < n). -*> -*> This is the right-looking Level 3 BLAS version of the algorithm. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the M-by-N matrix to be factored. -*> On exit, the factors L and U from the factorization -*> A = P*L*U; the unit diagonal elements of L are not stored. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[out] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (min(M,N)) -*> The pivot indices; for 1 <= i <= min(M,N), row i of the -*> matrix was interchanged with row IPIV(i). -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> > 0: if INFO = i, U(i,i) is exactly zero. The factorization -*> has been completed, but the factor U is exactly -*> singular, and division by zero will occur if it is used -*> to solve a system of equations. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleGEcomputational -* -* ===================================================================== - SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, IINFO, J, JB, NB -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DGETRF2, DLASWP, DTRSM, XERBLA -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 ) - IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN -* -* Use unblocked code. -* - CALL DGETRF2( M, N, A, LDA, IPIV, INFO ) - ELSE -* -* Use blocked code. -* - DO 20 J = 1, MIN( M, N ), NB - JB = MIN( MIN( M, N )-J+1, NB ) -* -* Factor diagonal and subdiagonal blocks and test for exact -* singularity. -* - CALL DGETRF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) -* -* Adjust INFO and the pivot indices. -* - IF( INFO.EQ.0 .AND. IINFO.GT.0 ) - $ INFO = IINFO + J - 1 - DO 10 I = J, MIN( M, J+JB-1 ) - IPIV( I ) = J - 1 + IPIV( I ) - 10 CONTINUE -* -* Apply interchanges to columns 1:J-1. -* - CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) -* - IF( J+JB.LE.N ) THEN -* -* Apply interchanges to columns J+JB:N. -* - CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, - $ IPIV, 1 ) -* -* Compute block row of U. -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, - $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), - $ LDA ) - IF( J+JB.LE.M ) THEN -* -* Update trailing submatrix. -* - CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1, - $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, - $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), - $ LDA ) - END IF - END IF - 20 CONTINUE - END IF - RETURN -* -* End of DGETRF -* - END diff --git a/lib/linalg/dgetrf2.cpp b/lib/linalg/dgetrf2.cpp new file mode 100644 index 0000000000..e3f6b1c48d --- /dev/null +++ b/lib/linalg/dgetrf2.cpp @@ -0,0 +1,106 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +static doublereal c_b13 = 1.; +static doublereal c_b16 = -1.; +int dgetrf2_(integer *m, integer *n, doublereal *a, integer *lda, integer *ipiv, integer *info) +{ + integer a_dim1, a_offset, i__1, i__2; + doublereal d__1; + integer i__, n1, n2; + doublereal temp; + extern int dscal_(integer *, doublereal *, doublereal *, integer *), + dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, ftnlen, + ftnlen); + integer iinfo; + doublereal sfmin; + extern int dtrsm_(char *, char *, char *, char *, integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, + ftnlen); + extern doublereal dlamch_(char *, ftnlen); + extern integer idamax_(integer *, doublereal *, integer *); + extern int xerbla_(char *, integer *, ftnlen), + dlaswp_(integer *, doublereal *, 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 *)"DGETRF2", &i__1, (ftnlen)7); + return 0; + } + if (*m == 0 || *n == 0) { + return 0; + } + if (*m == 1) { + ipiv[1] = 1; + if (a[a_dim1 + 1] == 0.) { + *info = 1; + } + } else if (*n == 1) { + sfmin = dlamch_((char *)"S", (ftnlen)1); + i__ = idamax_(m, &a[a_dim1 + 1], &c__1); + ipiv[1] = i__; + if (a[i__ + a_dim1] != 0.) { + if (i__ != 1) { + temp = a[a_dim1 + 1]; + a[a_dim1 + 1] = a[i__ + a_dim1]; + a[i__ + a_dim1] = temp; + } + if ((d__1 = a[a_dim1 + 1], abs(d__1)) >= sfmin) { + i__1 = *m - 1; + d__1 = 1. / a[a_dim1 + 1]; + dscal_(&i__1, &d__1, &a[a_dim1 + 2], &c__1); + } else { + i__1 = *m - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + a[i__ + 1 + a_dim1] /= a[a_dim1 + 1]; + } + } + } else { + *info = 1; + } + } else { + n1 = min(*m, *n) / 2; + n2 = *n - n1; + dgetrf2_(m, &n1, &a[a_offset], lda, &ipiv[1], &iinfo); + if (*info == 0 && iinfo > 0) { + *info = iinfo; + } + dlaswp_(&n2, &a[(n1 + 1) * a_dim1 + 1], lda, &c__1, &n1, &ipiv[1], &c__1); + dtrsm_((char *)"L", (char *)"L", (char *)"N", (char *)"U", &n1, &n2, &c_b13, &a[a_offset], lda, &a[(n1 + 1) * a_dim1 + 1], + lda, (ftnlen)1, (ftnlen)1, (ftnlen)1, (ftnlen)1); + i__1 = *m - n1; + dgemm_((char *)"N", (char *)"N", &i__1, &n2, &n1, &c_b16, &a[n1 + 1 + a_dim1], lda, + &a[(n1 + 1) * a_dim1 + 1], lda, &c_b13, &a[n1 + 1 + (n1 + 1) * a_dim1], lda, + (ftnlen)1, (ftnlen)1); + i__1 = *m - n1; + dgetrf2_(&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); + dlaswp_(&n1, &a[a_dim1 + 1], lda, &i__1, &i__2, &ipiv[1], &c__1); + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dgetrf2.f b/lib/linalg/dgetrf2.f deleted file mode 100644 index 40af0793dd..0000000000 --- a/lib/linalg/dgetrf2.f +++ /dev/null @@ -1,269 +0,0 @@ -*> \brief \b DGETRF2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* RECURSIVE SUBROUTINE DGETRF2( M, N, A, LDA, IPIV, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* DOUBLE PRECISION A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGETRF2 computes an LU factorization of a general M-by-N matrix A -*> using partial pivoting with row interchanges. -*> -*> The factorization has the form -*> A = P * L * U -*> where P is a permutation matrix, L is lower triangular with unit -*> diagonal elements (lower trapezoidal if m > n), and U is upper -*> triangular (upper trapezoidal if m < n). -*> -*> This is the recursive version of the algorithm. It divides -*> the matrix into four submatrices: -*> -*> [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2 -*> A = [ -----|----- ] with n1 = min(m,n)/2 -*> [ A21 | A22 ] n2 = n-n1 -*> -*> [ A11 ] -*> The subroutine calls itself to factor [ --- ], -*> [ A12 ] -*> [ A12 ] -*> do the swaps on [ --- ], solve A12, update A22, -*> [ A22 ] -*> -*> then calls itself to factor A22 and do the swaps on A21. -*> -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the M-by-N matrix to be factored. -*> On exit, the factors L and U from the factorization -*> A = P*L*U; the unit diagonal elements of L are not stored. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[out] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (min(M,N)) -*> The pivot indices; for 1 <= i <= min(M,N), row i of the -*> matrix was interchanged with row IPIV(i). -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> > 0: if INFO = i, U(i,i) is exactly zero. The factorization -*> has been completed, but the factor U is exactly -*> singular, and division by zero will occur if it is used -*> to solve a system of equations. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleGEcomputational -* -* ===================================================================== - RECURSIVE SUBROUTINE DGETRF2( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION SFMIN, TEMP - INTEGER I, IINFO, N1, N2 -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - INTEGER IDAMAX - EXTERNAL DLAMCH, IDAMAX -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DSCAL, DLASWP, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETRF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN - - IF ( M.EQ.1 ) THEN -* -* Use unblocked code for one row case -* Just need to handle IPIV and INFO -* - IPIV( 1 ) = 1 - IF ( A(1,1).EQ.ZERO ) - $ INFO = 1 -* - ELSE IF( N.EQ.1 ) THEN -* -* Use unblocked code for one column case -* -* -* Compute machine safe minimum -* - SFMIN = DLAMCH('S') -* -* Find pivot and test for singularity -* - I = IDAMAX( M, A( 1, 1 ), 1 ) - IPIV( 1 ) = I - IF( A( I, 1 ).NE.ZERO ) THEN -* -* Apply the interchange -* - IF( I.NE.1 ) THEN - TEMP = A( 1, 1 ) - A( 1, 1 ) = A( I, 1 ) - A( I, 1 ) = TEMP - END IF -* -* Compute elements 2:M of the column -* - IF( ABS(A( 1, 1 )) .GE. SFMIN ) THEN - CALL DSCAL( M-1, ONE / A( 1, 1 ), A( 2, 1 ), 1 ) - ELSE - DO 10 I = 1, M-1 - A( 1+I, 1 ) = A( 1+I, 1 ) / A( 1, 1 ) - 10 CONTINUE - END IF -* - ELSE - INFO = 1 - END IF -* - ELSE -* -* Use recursive code -* - N1 = MIN( M, N ) / 2 - N2 = N-N1 -* -* [ A11 ] -* Factor [ --- ] -* [ A21 ] -* - CALL DGETRF2( M, N1, A, LDA, IPIV, IINFO ) - - IF ( INFO.EQ.0 .AND. IINFO.GT.0 ) - $ INFO = IINFO -* -* [ A12 ] -* Apply interchanges to [ --- ] -* [ A22 ] -* - CALL DLASWP( N2, A( 1, N1+1 ), LDA, 1, N1, IPIV, 1 ) -* -* Solve A12 -* - CALL DTRSM( 'L', 'L', 'N', 'U', N1, N2, ONE, A, LDA, - $ A( 1, N1+1 ), LDA ) -* -* Update A22 -* - CALL DGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( N1+1, 1 ), LDA, - $ A( 1, N1+1 ), LDA, ONE, A( N1+1, N1+1 ), LDA ) -* -* Factor A22 -* - CALL DGETRF2( M-N1, N2, A( N1+1, N1+1 ), LDA, IPIV( N1+1 ), - $ IINFO ) -* -* Adjust INFO and the pivot indices -* - IF ( INFO.EQ.0 .AND. IINFO.GT.0 ) - $ INFO = IINFO + N1 - DO 20 I = N1+1, MIN( M, N ) - IPIV( I ) = IPIV( I ) + N1 - 20 CONTINUE -* -* Apply interchanges to A21 -* - CALL DLASWP( N1, A( 1, 1 ), LDA, N1+1, MIN( M, N), IPIV, 1 ) -* - END IF - RETURN -* -* End of DGETRF2 -* - END diff --git a/lib/linalg/dgetri.cpp b/lib/linalg/dgetri.cpp new file mode 100644 index 0000000000..9e522bff50 --- /dev/null +++ b/lib/linalg/dgetri.cpp @@ -0,0 +1,125 @@ +#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_b20 = -1.; +static doublereal c_b22 = 1.; +int dgetri_(integer *n, doublereal *a, integer *lda, integer *ipiv, doublereal *work, + integer *lwork, integer *info) +{ + integer a_dim1, a_offset, i__1, i__2, i__3; + integer i__, j, jb, nb, jj, jp, nn, iws; + extern int 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); + integer nbmin; + extern int dswap_(integer *, doublereal *, integer *, doublereal *, integer *), + dtrsm_(char *, char *, char *, char *, integer *, integer *, doublereal *, 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; + extern int dtrtri_(char *, char *, integer *, doublereal *, integer *, integer *, ftnlen, + ftnlen); + integer lwkopt; + logical lquery; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ipiv; + --work; + *info = 0; + nb = ilaenv_(&c__1, (char *)"DGETRI", (char *)" ", n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); + lwkopt = *n * nb; + work[1] = (doublereal)lwkopt; + 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 *)"DGETRI", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + if (*n == 0) { + return 0; + } + dtrtri_((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 *)"DGETRI", (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__) { + work[i__] = a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = 0.; + } + if (j < *n) { + i__1 = *n - j; + dgemv_((char *)"No transpose", n, &i__1, &c_b20, &a[(j + 1) * a_dim1 + 1], lda, + &work[j + 1], &c__1, &c_b22, &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__) { + work[i__ + (jj - j) * ldwork] = a[i__ + jj * a_dim1]; + a[i__ + jj * a_dim1] = 0.; + } + } + if (j + jb <= *n) { + i__2 = *n - j - jb + 1; + dgemm_((char *)"No transpose", (char *)"No transpose", n, &jb, &i__2, &c_b20, + &a[(j + jb) * a_dim1 + 1], lda, &work[j + jb], &ldwork, &c_b22, + &a[j * a_dim1 + 1], lda, (ftnlen)12, (ftnlen)12); + } + dtrsm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", n, &jb, &c_b22, &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) { + dswap_(n, &a[j * a_dim1 + 1], &c__1, &a[jp * a_dim1 + 1], &c__1); + } + } + work[1] = (doublereal)iws; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dgetri.f b/lib/linalg/dgetri.f deleted file mode 100644 index 92ef90c186..0000000000 --- a/lib/linalg/dgetri.f +++ /dev/null @@ -1,258 +0,0 @@ -*> \brief \b DGETRI -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGETRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* DOUBLE PRECISION A( LDA, * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGETRI computes the inverse of a matrix using the LU factorization -*> computed by DGETRF. -*> -*> This method inverts U and then computes inv(A) by solving the system -*> inv(A)*L = inv(U) for inv(A). -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the factors L and U from the factorization -*> A = P*L*U as computed by DGETRF. -*> On exit, if INFO = 0, the inverse of the original matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (N) -*> The pivot indices from DGETRF; for 1<=i<=N, row i of the -*> matrix was interchanged with row IPIV(i). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -*> On exit, if INFO=0, then WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. LWORK >= max(1,N). -*> For optimal performance LWORK >= N*NB, where NB is -*> the optimal blocksize returned by ILAENV. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal size of the WORK array, returns -*> this value as the first entry of the WORK array, and no error -*> message related to LWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> > 0: if INFO = i, U(i,i) is exactly zero; the matrix is -*> singular and its inverse could not be computed. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleGEcomputational -* -* ===================================================================== - SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB, - $ NBMIN, NN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DGEMV, DSWAP, DTRSM, DTRTRI, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - NB = ILAENV( 1, 'DGETRI', ' ', N, -1, -1, -1 ) - LWKOPT = N*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -3 - ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETRI', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Form inv(U). If INFO > 0 from DTRTRI, then U is singular, -* and the inverse is not computed. -* - CALL DTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO ) - IF( INFO.GT.0 ) - $ RETURN -* - NBMIN = 2 - LDWORK = N - IF( NB.GT.1 .AND. NB.LT.N ) THEN - IWS = MAX( LDWORK*NB, 1 ) - IF( LWORK.LT.IWS ) THEN - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DGETRI', ' ', N, -1, -1, -1 ) ) - END IF - ELSE - IWS = N - END IF -* -* Solve the equation inv(A)*L = inv(U) for inv(A). -* - IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN -* -* Use unblocked code. -* - DO 20 J = N, 1, -1 -* -* Copy current column of L to WORK and replace with zeros. -* - DO 10 I = J + 1, N - WORK( I ) = A( I, J ) - A( I, J ) = ZERO - 10 CONTINUE -* -* Compute current column of inv(A). -* - IF( J.LT.N ) - $ CALL DGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ), - $ LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 ) - 20 CONTINUE - ELSE -* -* Use blocked code. -* - NN = ( ( N-1 ) / NB )*NB + 1 - DO 50 J = NN, 1, -NB - JB = MIN( NB, N-J+1 ) -* -* Copy current block column of L to WORK and replace with -* zeros. -* - DO 40 JJ = J, J + JB - 1 - DO 30 I = JJ + 1, N - WORK( I+( JJ-J )*LDWORK ) = A( I, JJ ) - A( I, JJ ) = ZERO - 30 CONTINUE - 40 CONTINUE -* -* Compute current block column of inv(A). -* - IF( J+JB.LE.N ) - $ CALL DGEMM( 'No transpose', 'No transpose', N, JB, - $ N-J-JB+1, -ONE, A( 1, J+JB ), LDA, - $ WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA ) - CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB, - $ ONE, WORK( J ), LDWORK, A( 1, J ), LDA ) - 50 CONTINUE - END IF -* -* Apply column interchanges. -* - DO 60 J = N - 1, 1, -1 - JP = IPIV( J ) - IF( JP.NE.J ) - $ CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 ) - 60 CONTINUE -* - WORK( 1 ) = IWS - RETURN -* -* End of DGETRI -* - END diff --git a/lib/linalg/dgetrs.cpp b/lib/linalg/dgetrs.cpp new file mode 100644 index 0000000000..c45250cc95 --- /dev/null +++ b/lib/linalg/dgetrs.cpp @@ -0,0 +1,65 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +static doublereal c_b12 = 1.; +static integer c_n1 = -1; +int dgetrs_(char *trans, integer *n, integer *nrhs, doublereal *a, integer *lda, integer *ipiv, + doublereal *b, integer *ldb, integer *info, ftnlen trans_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), + dlaswp_(integer *, doublereal *, integer *, integer *, integer *, integer *, integer *); + logical notran; + 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; + notran = lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1); + if (!notran && !lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1) && + !lsame_(trans, (char *)"C", (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 *)"DGETRS", &i__1, (ftnlen)6); + return 0; + } + if (*n == 0 || *nrhs == 0) { + return 0; + } + if (notran) { + dlaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c__1); + dtrsm_((char *)"Left", (char *)"Lower", (char *)"No transpose", (char *)"Unit", n, nrhs, &c_b12, &a[a_offset], lda, + &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, (ftnlen)12, (ftnlen)4); + dtrsm_((char *)"Left", (char *)"Upper", (char *)"No transpose", (char *)"Non-unit", n, nrhs, &c_b12, &a[a_offset], lda, + &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, (ftnlen)12, (ftnlen)8); + } else { + dtrsm_((char *)"Left", (char *)"Upper", (char *)"Transpose", (char *)"Non-unit", n, nrhs, &c_b12, &a[a_offset], lda, + &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, (ftnlen)9, (ftnlen)8); + dtrsm_((char *)"Left", (char *)"Lower", (char *)"Transpose", (char *)"Unit", n, nrhs, &c_b12, &a[a_offset], lda, + &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, (ftnlen)9, (ftnlen)4); + dlaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c_n1); + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dgetrs.f b/lib/linalg/dgetrs.f deleted file mode 100644 index d3464f685a..0000000000 --- a/lib/linalg/dgetrs.f +++ /dev/null @@ -1,222 +0,0 @@ -*> \brief \b DGETRS -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DGETRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER TRANS -* INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGETRS solves a system of linear equations -*> A * X = B or A**T * X = B -*> with a general N-by-N matrix A using the LU factorization computed -*> by DGETRF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> Specifies the form of the system of equations: -*> = 'N': A * X = B (No transpose) -*> = 'T': A**T* X = B (Transpose) -*> = 'C': A**T* X = B (Conjugate transpose = Transpose) -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in] NRHS -*> \verbatim -*> NRHS is INTEGER -*> The number of right hand sides, i.e., the number of columns -*> of the matrix B. NRHS >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> The factors L and U from the factorization A = P*L*U -*> as computed by DGETRF. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (N) -*> The pivot indices from DGETRF; for 1<=i<=N, row i of the -*> matrix was interchanged with row IPIV(i). -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) -*> On entry, the right hand side matrix B. -*> On exit, the solution matrix X. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >= max(1,N). -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleGEcomputational -* -* ===================================================================== - SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOTRAN -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLASWP, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - NOTRAN = LSAME( TRANS, 'N' ) - IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -* - IF( NOTRAN ) THEN -* -* Solve A * X = B. -* -* Apply row interchanges to the right hand sides. -* - CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) -* -* Solve L*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve U*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, - $ NRHS, ONE, A, LDA, B, LDB ) - ELSE -* -* Solve A**T * X = B. -* -* Solve U**T *X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve L**T *X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE, - $ A, LDA, B, LDB ) -* -* Apply row interchanges to the solution vectors. -* - CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) - END IF -* - RETURN -* -* End of DGETRS -* - END diff --git a/lib/linalg/disnan.cpp b/lib/linalg/disnan.cpp new file mode 100644 index 0000000000..dcdaad77e1 --- /dev/null +++ b/lib/linalg/disnan.cpp @@ -0,0 +1,14 @@ + +#include + +extern "C" { + +#include "lmp_f2c.h" + +logical disnan_(const doublereal *din) +{ + if (!din) return TRUE_; + + return std::isnan(*din) ? TRUE_ : FALSE_; +} +} diff --git a/lib/linalg/disnan.f b/lib/linalg/disnan.f deleted file mode 100644 index e621b2589c..0000000000 --- a/lib/linalg/disnan.f +++ /dev/null @@ -1,77 +0,0 @@ -*> \brief \b DISNAN tests input for NaN. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DISNAN + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* LOGICAL FUNCTION DISNAN( DIN ) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION, INTENT(IN) :: DIN -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DISNAN returns .TRUE. if its argument is NaN, and .FALSE. -*> otherwise. To be replaced by the Fortran 2003 intrinsic in the -*> future. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] DIN -*> \verbatim -*> DIN is DOUBLE PRECISION -*> Input to test for NaN. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - LOGICAL FUNCTION DISNAN( DIN ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION, INTENT(IN) :: DIN -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL DLAISNAN - EXTERNAL DLAISNAN -* .. -* .. Executable Statements .. - DISNAN = DLAISNAN(DIN,DIN) - RETURN - END diff --git a/lib/linalg/dlabad.cpp b/lib/linalg/dlabad.cpp new file mode 100644 index 0000000000..790163be3c --- /dev/null +++ b/lib/linalg/dlabad.cpp @@ -0,0 +1,16 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dlabad_(doublereal *small, doublereal *large) +{ + double d_lmp_lg10(doublereal *), sqrt(doublereal); + if (d_lmp_lg10(large) > 2e3) { + *small = sqrt(*small); + *large = sqrt(*large); + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlabad.f b/lib/linalg/dlabad.f deleted file mode 100644 index 95b35e53b8..0000000000 --- a/lib/linalg/dlabad.f +++ /dev/null @@ -1,102 +0,0 @@ -*> \brief \b DLABAD -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLABAD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLABAD( SMALL, LARGE ) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION LARGE, SMALL -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLABAD takes as input the values computed by DLAMCH for underflow and -*> overflow, and returns the square root of each of these values if the -*> log of LARGE is sufficiently large. This subroutine is intended to -*> identify machines with a large exponent range, such as the Crays, and -*> redefine the underflow and overflow limits to be the square roots of -*> the values computed by DLAMCH. This subroutine is needed because -*> DLAMCH does not compensate for poor arithmetic in the upper half of -*> the exponent range, as is found on a Cray. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in,out] SMALL -*> \verbatim -*> SMALL is DOUBLE PRECISION -*> On entry, the underflow threshold as computed by DLAMCH. -*> On exit, if LOG10(LARGE) is sufficiently large, the square -*> root of SMALL, otherwise unchanged. -*> \endverbatim -*> -*> \param[in,out] LARGE -*> \verbatim -*> LARGE is DOUBLE PRECISION -*> On entry, the overflow threshold as computed by DLAMCH. -*> On exit, if LOG10(LARGE) is sufficiently large, the square -*> root of LARGE, otherwise unchanged. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLABAD( SMALL, LARGE ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION LARGE, SMALL -* .. -* -* ===================================================================== -* -* .. Intrinsic Functions .. - INTRINSIC LOG10, SQRT -* .. -* .. Executable Statements .. -* -* If it looks like we're on a Cray, take the square root of -* SMALL and LARGE to avoid overflow and underflow problems. -* - IF( LOG10( LARGE ).GT.2000.D0 ) THEN - SMALL = SQRT( SMALL ) - LARGE = SQRT( LARGE ) - END IF -* - RETURN -* -* End of DLABAD -* - END diff --git a/lib/linalg/dlabrd.cpp b/lib/linalg/dlabrd.cpp new file mode 100644 index 0000000000..d58ebe9a39 --- /dev/null +++ b/lib/linalg/dlabrd.cpp @@ -0,0 +1,210 @@ +#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_b16 = 0.; +int dlabrd_(integer *m, integer *n, integer *nb, doublereal *a, integer *lda, doublereal *d__, + doublereal *e, doublereal *tauq, doublereal *taup, doublereal *x, integer *ldx, + doublereal *y, integer *ldy) +{ + integer a_dim1, a_offset, x_dim1, x_offset, y_dim1, y_offset, i__1, i__2, i__3; + integer i__; + extern int dscal_(integer *, doublereal *, doublereal *, integer *), + dgemv_(char *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, ftnlen), + dlarfg_(integer *, doublereal *, doublereal *, integer *, doublereal *); + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --d__; + --e; + --tauq; + --taup; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + y_dim1 = *ldy; + y_offset = 1 + y_dim1; + y -= y_offset; + if (*m <= 0 || *n <= 0) { + return 0; + } + if (*m >= *n) { + i__1 = *nb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *m - i__ + 1; + i__3 = i__ - 1; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &a[i__ + a_dim1], lda, &y[i__ + y_dim1], + ldy, &c_b5, &a[i__ + i__ * a_dim1], &c__1, (ftnlen)12); + i__2 = *m - i__ + 1; + i__3 = i__ - 1; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &x[i__ + x_dim1], ldx, &a[i__ * a_dim1 + 1], + &c__1, &c_b5, &a[i__ + i__ * a_dim1], &c__1, (ftnlen)12); + i__2 = *m - i__ + 1; + i__3 = i__ + 1; + dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3, *m) + i__ * a_dim1], &c__1, + &tauq[i__]); + d__[i__] = a[i__ + i__ * a_dim1]; + if (i__ < *n) { + a[i__ + i__ * a_dim1] = 1.; + i__2 = *m - i__ + 1; + i__3 = *n - i__; + dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &a[i__ + (i__ + 1) * a_dim1], lda, + &a[i__ + i__ * a_dim1], &c__1, &c_b16, &y[i__ + 1 + i__ * y_dim1], &c__1, + (ftnlen)9); + i__2 = *m - i__ + 1; + i__3 = i__ - 1; + dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &a[i__ + a_dim1], lda, + &a[i__ + i__ * a_dim1], &c__1, &c_b16, &y[i__ * y_dim1 + 1], &c__1, + (ftnlen)9); + i__2 = *n - i__; + i__3 = i__ - 1; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &y[i__ + 1 + y_dim1], ldy, + &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[i__ + 1 + i__ * y_dim1], &c__1, + (ftnlen)12); + i__2 = *m - i__ + 1; + i__3 = i__ - 1; + dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &x[i__ + x_dim1], ldx, + &a[i__ + i__ * a_dim1], &c__1, &c_b16, &y[i__ * y_dim1 + 1], &c__1, + (ftnlen)9); + i__2 = i__ - 1; + i__3 = *n - i__; + dgemv_((char *)"Transpose", &i__2, &i__3, &c_b4, &a[(i__ + 1) * a_dim1 + 1], lda, + &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[i__ + 1 + i__ * y_dim1], &c__1, + (ftnlen)9); + i__2 = *n - i__; + dscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1); + i__2 = *n - i__; + dgemv_((char *)"No transpose", &i__2, &i__, &c_b4, &y[i__ + 1 + y_dim1], ldy, + &a[i__ + a_dim1], lda, &c_b5, &a[i__ + (i__ + 1) * a_dim1], lda, (ftnlen)12); + i__2 = i__ - 1; + i__3 = *n - i__; + dgemv_((char *)"Transpose", &i__2, &i__3, &c_b4, &a[(i__ + 1) * a_dim1 + 1], lda, + &x[i__ + x_dim1], ldx, &c_b5, &a[i__ + (i__ + 1) * a_dim1], lda, (ftnlen)9); + i__2 = *n - i__; + i__3 = i__ + 2; + dlarfg_(&i__2, &a[i__ + (i__ + 1) * a_dim1], &a[i__ + min(i__3, *n) * a_dim1], lda, + &taup[i__]); + e[i__] = a[i__ + (i__ + 1) * a_dim1]; + a[i__ + (i__ + 1) * a_dim1] = 1.; + i__2 = *m - i__; + i__3 = *n - i__; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + (i__ + 1) * a_dim1], lda, + &a[i__ + (i__ + 1) * a_dim1], lda, &c_b16, &x[i__ + 1 + i__ * x_dim1], &c__1, + (ftnlen)12); + i__2 = *n - i__; + dgemv_((char *)"Transpose", &i__2, &i__, &c_b5, &y[i__ + 1 + y_dim1], ldy, + &a[i__ + (i__ + 1) * a_dim1], lda, &c_b16, &x[i__ * x_dim1 + 1], &c__1, + (ftnlen)9); + i__2 = *m - i__; + dgemv_((char *)"No transpose", &i__2, &i__, &c_b4, &a[i__ + 1 + a_dim1], lda, + &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[i__ + 1 + i__ * x_dim1], &c__1, + (ftnlen)12); + i__2 = i__ - 1; + i__3 = *n - i__; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[(i__ + 1) * a_dim1 + 1], lda, + &a[i__ + (i__ + 1) * a_dim1], lda, &c_b16, &x[i__ * x_dim1 + 1], &c__1, + (ftnlen)12); + i__2 = *m - i__; + i__3 = i__ - 1; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &x[i__ + 1 + x_dim1], ldx, + &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[i__ + 1 + i__ * x_dim1], &c__1, + (ftnlen)12); + i__2 = *m - i__; + dscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1); + } + } + } else { + i__1 = *nb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n - i__ + 1; + i__3 = i__ - 1; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &y[i__ + y_dim1], ldy, &a[i__ + a_dim1], + lda, &c_b5, &a[i__ + i__ * a_dim1], lda, (ftnlen)12); + i__2 = i__ - 1; + i__3 = *n - i__ + 1; + dgemv_((char *)"Transpose", &i__2, &i__3, &c_b4, &a[i__ * a_dim1 + 1], lda, &x[i__ + x_dim1], + ldx, &c_b5, &a[i__ + i__ * a_dim1], lda, (ftnlen)9); + i__2 = *n - i__ + 1; + i__3 = i__ + 1; + dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3, *n) * a_dim1], lda, + &taup[i__]); + d__[i__] = a[i__ + i__ * a_dim1]; + if (i__ < *m) { + a[i__ + i__ * a_dim1] = 1.; + i__2 = *m - i__; + i__3 = *n - i__ + 1; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + i__ * a_dim1], lda, + &a[i__ + i__ * a_dim1], lda, &c_b16, &x[i__ + 1 + i__ * x_dim1], &c__1, + (ftnlen)12); + i__2 = *n - i__ + 1; + i__3 = i__ - 1; + dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &y[i__ + y_dim1], ldy, + &a[i__ + i__ * a_dim1], lda, &c_b16, &x[i__ * x_dim1 + 1], &c__1, (ftnlen)9); + i__2 = *m - i__; + i__3 = i__ - 1; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &a[i__ + 1 + a_dim1], lda, + &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[i__ + 1 + i__ * x_dim1], &c__1, + (ftnlen)12); + i__2 = i__ - 1; + i__3 = *n - i__ + 1; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[i__ * a_dim1 + 1], lda, + &a[i__ + i__ * a_dim1], lda, &c_b16, &x[i__ * x_dim1 + 1], &c__1, + (ftnlen)12); + i__2 = *m - i__; + i__3 = i__ - 1; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &x[i__ + 1 + x_dim1], ldx, + &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[i__ + 1 + i__ * x_dim1], &c__1, + (ftnlen)12); + i__2 = *m - i__; + dscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1); + i__2 = *m - i__; + i__3 = i__ - 1; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &a[i__ + 1 + a_dim1], lda, + &y[i__ + y_dim1], ldy, &c_b5, &a[i__ + 1 + i__ * a_dim1], &c__1, (ftnlen)12); + i__2 = *m - i__; + dgemv_((char *)"No transpose", &i__2, &i__, &c_b4, &x[i__ + 1 + x_dim1], ldx, + &a[i__ * a_dim1 + 1], &c__1, &c_b5, &a[i__ + 1 + i__ * a_dim1], &c__1, + (ftnlen)12); + i__2 = *m - i__; + i__3 = i__ + 2; + dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3, *m) + i__ * a_dim1], &c__1, + &tauq[i__]); + e[i__] = a[i__ + 1 + i__ * a_dim1]; + a[i__ + 1 + i__ * a_dim1] = 1.; + i__2 = *m - i__; + i__3 = *n - i__; + dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + (i__ + 1) * a_dim1], lda, + &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &y[i__ + 1 + i__ * y_dim1], &c__1, + (ftnlen)9); + i__2 = *m - i__; + i__3 = i__ - 1; + dgemv_((char *)"Transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + a_dim1], lda, + &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &y[i__ * y_dim1 + 1], &c__1, + (ftnlen)9); + i__2 = *n - i__; + i__3 = i__ - 1; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b4, &y[i__ + 1 + y_dim1], ldy, + &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[i__ + 1 + i__ * y_dim1], &c__1, + (ftnlen)12); + i__2 = *m - i__; + dgemv_((char *)"Transpose", &i__2, &i__, &c_b5, &x[i__ + 1 + x_dim1], ldx, + &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &y[i__ * y_dim1 + 1], &c__1, + (ftnlen)9); + i__2 = *n - i__; + dgemv_((char *)"Transpose", &i__, &i__2, &c_b4, &a[(i__ + 1) * a_dim1 + 1], lda, + &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[i__ + 1 + i__ * y_dim1], &c__1, + (ftnlen)9); + i__2 = *n - i__; + dscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1); + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlabrd.f b/lib/linalg/dlabrd.f deleted file mode 100644 index 86dfc10c7c..0000000000 --- a/lib/linalg/dlabrd.f +++ /dev/null @@ -1,378 +0,0 @@ -*> \brief \b DLABRD reduces the first nb rows and columns of a general matrix to a bidiagonal form. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLABRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, -* LDY ) -* -* .. Scalar Arguments .. -* INTEGER LDA, LDX, LDY, M, N, NB -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), -* $ TAUQ( * ), X( LDX, * ), Y( LDY, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLABRD reduces the first NB rows and columns of a real general -*> m by n matrix A to upper or lower bidiagonal form by an orthogonal -*> transformation Q**T * A * P, and returns the matrices X and Y which -*> are needed to apply the transformation to the unreduced part of A. -*> -*> If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower -*> bidiagonal form. -*> -*> This is an auxiliary routine called by DGEBRD -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows in the matrix A. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns in the matrix A. -*> \endverbatim -*> -*> \param[in] NB -*> \verbatim -*> NB is INTEGER -*> The number of leading rows and columns of A to be reduced. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the m by n general matrix to be reduced. -*> On exit, the first NB rows and columns of the matrix are -*> overwritten; the rest of the array is unchanged. -*> If m >= n, elements on and below the diagonal in the first NB -*> columns, with the array TAUQ, represent the orthogonal -*> matrix Q as a product of elementary reflectors; and -*> elements above the diagonal in the first NB rows, with the -*> array TAUP, represent the orthogonal matrix P as a product -*> of elementary reflectors. -*> If m < n, elements below the diagonal in the first NB -*> columns, with the array TAUQ, represent the orthogonal -*> matrix Q as a product of elementary reflectors, and -*> elements on and above the diagonal in the first NB rows, -*> with the array TAUP, represent the orthogonal matrix P as -*> a product of elementary reflectors. -*> See Further Details. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (NB) -*> The diagonal elements of the first NB rows and columns of -*> the reduced matrix. D(i) = A(i,i). -*> \endverbatim -*> -*> \param[out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (NB) -*> The off-diagonal elements of the first NB rows and columns of -*> the reduced matrix. -*> \endverbatim -*> -*> \param[out] TAUQ -*> \verbatim -*> TAUQ is DOUBLE PRECISION array, dimension (NB) -*> The scalar factors of the elementary reflectors which -*> represent the orthogonal matrix Q. See Further Details. -*> \endverbatim -*> -*> \param[out] TAUP -*> \verbatim -*> TAUP is DOUBLE PRECISION array, dimension (NB) -*> The scalar factors of the elementary reflectors which -*> represent the orthogonal matrix P. See Further Details. -*> \endverbatim -*> -*> \param[out] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension (LDX,NB) -*> The m-by-nb matrix X required to update the unreduced part -*> of A. -*> \endverbatim -*> -*> \param[in] LDX -*> \verbatim -*> LDX is INTEGER -*> The leading dimension of the array X. LDX >= max(1,M). -*> \endverbatim -*> -*> \param[out] Y -*> \verbatim -*> Y is DOUBLE PRECISION array, dimension (LDY,NB) -*> The n-by-nb matrix Y required to update the unreduced part -*> of A. -*> \endverbatim -*> -*> \param[in] LDY -*> \verbatim -*> LDY is INTEGER -*> The leading dimension of the array Y. LDY >= max(1,N). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The matrices Q and P are represented as products of elementary -*> reflectors: -*> -*> Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb) -*> -*> Each H(i) and G(i) has the form: -*> -*> H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T -*> -*> where tauq and taup are real scalars, and v and u are real vectors. -*> -*> If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in -*> A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in -*> A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). -*> -*> If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in -*> A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in -*> A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). -*> -*> The elements of the vectors v and u together form the m-by-nb matrix -*> V and the nb-by-n matrix U**T which are needed, with X and Y, to apply -*> the transformation to the unreduced part of the matrix, using a block -*> update of the form: A := A - V*Y**T - X*U**T. -*> -*> The contents of A on exit are illustrated by the following examples -*> with nb = 2: -*> -*> m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): -*> -*> ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 ) -*> ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 ) -*> ( v1 v2 a a a ) ( v1 1 a a a a ) -*> ( v1 v2 a a a ) ( v1 v2 a a a a ) -*> ( v1 v2 a a a ) ( v1 v2 a a a a ) -*> ( v1 v2 a a a ) -*> -*> where a denotes an element of the original matrix which is unchanged, -*> vi denotes an element of the vector defining H(i), and ui an element -*> of the vector defining G(i). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, - $ LDY ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER LDA, LDX, LDY, M, N, NB -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), - $ TAUQ( * ), X( LDX, * ), Y( LDY, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - INTEGER I -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DLARFG, DSCAL -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( M.LE.0 .OR. N.LE.0 ) - $ RETURN -* - IF( M.GE.N ) THEN -* -* Reduce to upper bidiagonal form -* - DO 10 I = 1, NB -* -* Update A(i:m,i) -* - CALL DGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ), - $ LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 ) - CALL DGEMV( 'No transpose', M-I+1, I-1, -ONE, X( I, 1 ), - $ LDX, A( 1, I ), 1, ONE, A( I, I ), 1 ) -* -* Generate reflection Q(i) to annihilate A(i+1:m,i) -* - CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, - $ TAUQ( I ) ) - D( I ) = A( I, I ) - IF( I.LT.N ) THEN - A( I, I ) = ONE -* -* Compute Y(i+1:n,i) -* - CALL DGEMV( 'Transpose', M-I+1, N-I, ONE, A( I, I+1 ), - $ LDA, A( I, I ), 1, ZERO, Y( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', M-I+1, I-1, ONE, A( I, 1 ), LDA, - $ A( I, I ), 1, ZERO, Y( 1, I ), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), - $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', M-I+1, I-1, ONE, X( I, 1 ), LDX, - $ A( I, I ), 1, ZERO, Y( 1, I ), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ), - $ LDA, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) - CALL DSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 ) -* -* Update A(i,i+1:n) -* - CALL DGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ), - $ LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA ) - CALL DGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ), - $ LDA, X( I, 1 ), LDX, ONE, A( I, I+1 ), LDA ) -* -* Generate reflection P(i) to annihilate A(i,i+2:n) -* - CALL DLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ), - $ LDA, TAUP( I ) ) - E( I ) = A( I, I+1 ) - A( I, I+1 ) = ONE -* -* Compute X(i+1:m,i) -* - CALL DGEMV( 'No transpose', M-I, N-I, ONE, A( I+1, I+1 ), - $ LDA, A( I, I+1 ), LDA, ZERO, X( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, Y( I+1, 1 ), LDY, - $ A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 ) - CALL DGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ), - $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), - $ LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 ) - CALL DGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), - $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) - CALL DSCAL( M-I, TAUP( I ), X( I+1, I ), 1 ) - END IF - 10 CONTINUE - ELSE -* -* Reduce to lower bidiagonal form -* - DO 20 I = 1, NB -* -* Update A(i,i:n) -* - CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ), - $ LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA ) - CALL DGEMV( 'Transpose', I-1, N-I+1, -ONE, A( 1, I ), LDA, - $ X( I, 1 ), LDX, ONE, A( I, I ), LDA ) -* -* Generate reflection P(i) to annihilate A(i,i+1:n) -* - CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, - $ TAUP( I ) ) - D( I ) = A( I, I ) - IF( I.LT.M ) THEN - A( I, I ) = ONE -* -* Compute X(i+1:m,i) -* - CALL DGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ), - $ LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Y( I, 1 ), LDY, - $ A( I, I ), LDA, ZERO, X( 1, I ), 1 ) - CALL DGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), - $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ), - $ LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 ) - CALL DGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), - $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) - CALL DSCAL( M-I, TAUP( I ), X( I+1, I ), 1 ) -* -* Update A(i+1:m,i) -* - CALL DGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), - $ LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 ) - CALL DGEMV( 'No transpose', M-I, I, -ONE, X( I+1, 1 ), - $ LDX, A( 1, I ), 1, ONE, A( I+1, I ), 1 ) -* -* Generate reflection Q(i) to annihilate A(i+2:m,i) -* - CALL DLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1, - $ TAUQ( I ) ) - E( I ) = A( I+1, I ) - A( I+1, I ) = ONE -* -* Compute Y(i+1:n,i) -* - CALL DGEMV( 'Transpose', M-I, N-I, ONE, A( I+1, I+1 ), - $ LDA, A( I+1, I ), 1, ZERO, Y( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', M-I, I-1, ONE, A( I+1, 1 ), LDA, - $ A( I+1, I ), 1, ZERO, Y( 1, I ), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), - $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', M-I, I, ONE, X( I+1, 1 ), LDX, - $ A( I+1, I ), 1, ZERO, Y( 1, I ), 1 ) - CALL DGEMV( 'Transpose', I, N-I, -ONE, A( 1, I+1 ), LDA, - $ Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) - CALL DSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 ) - END IF - 20 CONTINUE - END IF - RETURN -* -* End of DLABRD -* - END diff --git a/lib/linalg/dlacn2.cpp b/lib/linalg/dlacn2.cpp new file mode 100644 index 0000000000..3f9bea59d8 --- /dev/null +++ b/lib/linalg/dlacn2.cpp @@ -0,0 +1,136 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +int dlacn2_(integer *n, doublereal *v, doublereal *x, integer *isgn, doublereal *est, integer *kase, + integer *isave) +{ + integer i__1; + doublereal d__1; + integer i_lmp_dnnt(doublereal *); + integer i__; + doublereal xs, temp; + extern doublereal dasum_(integer *, doublereal *, integer *); + integer jlast; + extern int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *); + extern integer idamax_(integer *, doublereal *, integer *); + doublereal altsgn, estold; + --isave; + --isgn; + --x; + --v; + if (*kase == 0) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + x[i__] = 1. / (doublereal)(*n); + } + *kase = 1; + isave[1] = 1; + return 0; + } + switch (isave[1]) { + case 1: + goto L20; + case 2: + goto L40; + case 3: + goto L70; + case 4: + goto L110; + case 5: + goto L140; + } +L20: + if (*n == 1) { + v[1] = x[1]; + *est = abs(v[1]); + goto L150; + } + *est = dasum_(n, &x[1], &c__1); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (x[i__] >= 0.) { + x[i__] = 1.; + } else { + x[i__] = -1.; + } + isgn[i__] = i_lmp_dnnt(&x[i__]); + } + *kase = 2; + isave[1] = 2; + return 0; +L40: + isave[2] = idamax_(n, &x[1], &c__1); + isave[3] = 2; +L50: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + x[i__] = 0.; + } + x[isave[2]] = 1.; + *kase = 1; + isave[1] = 3; + return 0; +L70: + dcopy_(n, &x[1], &c__1, &v[1], &c__1); + estold = *est; + *est = dasum_(n, &v[1], &c__1); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (x[i__] >= 0.) { + xs = 1.; + } else { + xs = -1.; + } + if (i_lmp_dnnt(&xs) != isgn[i__]) { + goto L90; + } + } + goto L120; +L90: + if (*est <= estold) { + goto L120; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (x[i__] >= 0.) { + x[i__] = 1.; + } else { + x[i__] = -1.; + } + isgn[i__] = i_lmp_dnnt(&x[i__]); + } + *kase = 2; + isave[1] = 4; + return 0; +L110: + jlast = isave[2]; + isave[2] = idamax_(n, &x[1], &c__1); + if (x[jlast] != (d__1 = x[isave[2]], abs(d__1)) && isave[3] < 5) { + ++isave[3]; + goto L50; + } +L120: + altsgn = 1.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + x[i__] = altsgn * ((doublereal)(i__ - 1) / (doublereal)(*n - 1) + 1.); + altsgn = -altsgn; + } + *kase = 1; + isave[1] = 5; + return 0; +L140: + temp = dasum_(n, &x[1], &c__1) / (doublereal)(*n * 3) * 2.; + if (temp > *est) { + dcopy_(n, &x[1], &c__1, &v[1], &c__1); + *est = temp; + } +L150: + *kase = 0; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlacn2.f b/lib/linalg/dlacn2.f deleted file mode 100644 index ee2e7ca266..0000000000 --- a/lib/linalg/dlacn2.f +++ /dev/null @@ -1,304 +0,0 @@ -*> \brief \b DLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vector products. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLACN2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE ) -* -* .. Scalar Arguments .. -* INTEGER KASE, N -* DOUBLE PRECISION EST -* .. -* .. Array Arguments .. -* INTEGER ISGN( * ), ISAVE( 3 ) -* DOUBLE PRECISION V( * ), X( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLACN2 estimates the 1-norm of a square, real matrix A. -*> Reverse communication is used for evaluating matrix-vector products. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix. N >= 1. -*> \endverbatim -*> -*> \param[out] V -*> \verbatim -*> V is DOUBLE PRECISION array, dimension (N) -*> On the final return, V = A*W, where EST = norm(V)/norm(W) -*> (W is not returned). -*> \endverbatim -*> -*> \param[in,out] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension (N) -*> On an intermediate return, X should be overwritten by -*> A * X, if KASE=1, -*> A**T * X, if KASE=2, -*> and DLACN2 must be re-called with all the other parameters -*> unchanged. -*> \endverbatim -*> -*> \param[out] ISGN -*> \verbatim -*> ISGN is INTEGER array, dimension (N) -*> \endverbatim -*> -*> \param[in,out] EST -*> \verbatim -*> EST is DOUBLE PRECISION -*> On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be -*> unchanged from the previous call to DLACN2. -*> On exit, EST is an estimate (a lower bound) for norm(A). -*> \endverbatim -*> -*> \param[in,out] KASE -*> \verbatim -*> KASE is INTEGER -*> On the initial call to DLACN2, KASE should be 0. -*> On an intermediate return, KASE will be 1 or 2, indicating -*> whether X should be overwritten by A * X or A**T * X. -*> On the final return from DLACN2, KASE will again be 0. -*> \endverbatim -*> -*> \param[in,out] ISAVE -*> \verbatim -*> ISAVE is INTEGER array, dimension (3) -*> ISAVE is used to save variables between calls to DLACN2 -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Originally named SONEST, dated March 16, 1988. -*> -*> This is a thread safe version of DLACON, which uses the array ISAVE -*> in place of a SAVE statement, as follows: -*> -*> DLACON DLACN2 -*> JUMP ISAVE(1) -*> J ISAVE(2) -*> ITER ISAVE(3) -*> \endverbatim -* -*> \par Contributors: -* ================== -*> -*> Nick Higham, University of Manchester -* -*> \par References: -* ================ -*> -*> N.J. Higham, "FORTRAN codes for estimating the one-norm of -*> a real or complex matrix, with applications to condition estimation", -*> ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. -*> -* ===================================================================== - SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER KASE, N - DOUBLE PRECISION EST -* .. -* .. Array Arguments .. - INTEGER ISGN( * ), ISAVE( 3 ) - DOUBLE PRECISION V( * ), X( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - INTEGER ITMAX - PARAMETER ( ITMAX = 5 ) - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, JLAST - DOUBLE PRECISION ALTSGN, ESTOLD, TEMP, XS -* .. -* .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DASUM - EXTERNAL IDAMAX, DASUM -* .. -* .. External Subroutines .. - EXTERNAL DCOPY -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, NINT -* .. -* .. Executable Statements .. -* - IF( KASE.EQ.0 ) THEN - DO 10 I = 1, N - X( I ) = ONE / DBLE( N ) - 10 CONTINUE - KASE = 1 - ISAVE( 1 ) = 1 - RETURN - END IF -* - GO TO ( 20, 40, 70, 110, 140 )ISAVE( 1 ) -* -* ................ ENTRY (ISAVE( 1 ) = 1) -* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. -* - 20 CONTINUE - IF( N.EQ.1 ) THEN - V( 1 ) = X( 1 ) - EST = ABS( V( 1 ) ) -* ... QUIT - GO TO 150 - END IF - EST = DASUM( N, X, 1 ) -* - DO 30 I = 1, N - IF( X(I).GE.ZERO ) THEN - X(I) = ONE - ELSE - X(I) = -ONE - END IF - ISGN( I ) = NINT( X( I ) ) - 30 CONTINUE - KASE = 2 - ISAVE( 1 ) = 2 - RETURN -* -* ................ ENTRY (ISAVE( 1 ) = 2) -* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. -* - 40 CONTINUE - ISAVE( 2 ) = IDAMAX( N, X, 1 ) - ISAVE( 3 ) = 2 -* -* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. -* - 50 CONTINUE - DO 60 I = 1, N - X( I ) = ZERO - 60 CONTINUE - X( ISAVE( 2 ) ) = ONE - KASE = 1 - ISAVE( 1 ) = 3 - RETURN -* -* ................ ENTRY (ISAVE( 1 ) = 3) -* X HAS BEEN OVERWRITTEN BY A*X. -* - 70 CONTINUE - CALL DCOPY( N, X, 1, V, 1 ) - ESTOLD = EST - EST = DASUM( N, V, 1 ) - DO 80 I = 1, N - IF( X(I).GE.ZERO ) THEN - XS = ONE - ELSE - XS = -ONE - END IF - IF( NINT( XS ).NE.ISGN( I ) ) - $ GO TO 90 - 80 CONTINUE -* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. - GO TO 120 -* - 90 CONTINUE -* TEST FOR CYCLING. - IF( EST.LE.ESTOLD ) - $ GO TO 120 -* - DO 100 I = 1, N - IF( X(I).GE.ZERO ) THEN - X(I) = ONE - ELSE - X(I) = -ONE - END IF - ISGN( I ) = NINT( X( I ) ) - 100 CONTINUE - KASE = 2 - ISAVE( 1 ) = 4 - RETURN -* -* ................ ENTRY (ISAVE( 1 ) = 4) -* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. -* - 110 CONTINUE - JLAST = ISAVE( 2 ) - ISAVE( 2 ) = IDAMAX( N, X, 1 ) - IF( ( X( JLAST ).NE.ABS( X( ISAVE( 2 ) ) ) ) .AND. - $ ( ISAVE( 3 ).LT.ITMAX ) ) THEN - ISAVE( 3 ) = ISAVE( 3 ) + 1 - GO TO 50 - END IF -* -* ITERATION COMPLETE. FINAL STAGE. -* - 120 CONTINUE - ALTSGN = ONE - DO 130 I = 1, N - X( I ) = ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) ) - ALTSGN = -ALTSGN - 130 CONTINUE - KASE = 1 - ISAVE( 1 ) = 5 - RETURN -* -* ................ ENTRY (ISAVE( 1 ) = 5) -* X HAS BEEN OVERWRITTEN BY A*X. -* - 140 CONTINUE - TEMP = TWO*( DASUM( N, X, 1 ) / DBLE( 3*N ) ) - IF( TEMP.GT.EST ) THEN - CALL DCOPY( N, X, 1, V, 1 ) - EST = TEMP - END IF -* - 150 CONTINUE - KASE = 0 - RETURN -* -* End of DLACN2 -* - END diff --git a/lib/linalg/dlacpy.cpp b/lib/linalg/dlacpy.cpp new file mode 100644 index 0000000000..361ee09b9e --- /dev/null +++ b/lib/linalg/dlacpy.cpp @@ -0,0 +1,46 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dlacpy_(char *uplo, integer *m, integer *n, doublereal *a, integer *lda, doublereal *b, + integer *ldb, ftnlen uplo_len) +{ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; + integer i__, j; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = min(j, *m); + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = a[i__ + j * a_dim1]; + } + } + } else if (lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = a[i__ + j * a_dim1]; + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = a[i__ + j * a_dim1]; + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlacpy.f b/lib/linalg/dlacpy.f deleted file mode 100644 index 917aa1e2a2..0000000000 --- a/lib/linalg/dlacpy.f +++ /dev/null @@ -1,153 +0,0 @@ -*> \brief \b DLACPY copies all or part of one two-dimensional array to another. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLACPY + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER LDA, LDB, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLACPY copies all or part of a two-dimensional matrix A to another -*> matrix B. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> Specifies the part of the matrix A to be copied to B. -*> = 'U': Upper triangular part -*> = 'L': Lower triangular part -*> Otherwise: All of the matrix A -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> The m by n matrix A. If UPLO = 'U', only the upper triangle -*> or trapezoid is accessed; if UPLO = 'L', only the lower -*> triangle or trapezoid is accessed. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[out] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB,N) -*> On exit, B = A in the locations specified by UPLO. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >= max(1,M). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, LDB, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, J -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* - IF( LSAME( UPLO, 'U' ) ) THEN - DO 20 J = 1, N - DO 10 I = 1, MIN( J, M ) - B( I, J ) = A( I, J ) - 10 CONTINUE - 20 CONTINUE - ELSE IF( LSAME( UPLO, 'L' ) ) THEN - DO 40 J = 1, N - DO 30 I = J, M - B( I, J ) = A( I, J ) - 30 CONTINUE - 40 CONTINUE - ELSE - DO 60 J = 1, N - DO 50 I = 1, M - B( I, J ) = A( I, J ) - 50 CONTINUE - 60 CONTINUE - END IF - RETURN -* -* End of DLACPY -* - END diff --git a/lib/linalg/dladiv.cpp b/lib/linalg/dladiv.cpp new file mode 100644 index 0000000000..52f48222b0 --- /dev/null +++ b/lib/linalg/dladiv.cpp @@ -0,0 +1,88 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dladiv_(doublereal *a, doublereal *b, doublereal *c__, doublereal *d__, doublereal *p, + doublereal *q) +{ + doublereal d__1, d__2; + doublereal s, aa, ab, bb, cc, cd, dd, be, un, ov, eps; + extern doublereal dlamch_(char *, ftnlen); + extern int dladiv1_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *); + aa = *a; + bb = *b; + cc = *c__; + dd = *d__; + d__1 = abs(*a), d__2 = abs(*b); + ab = max(d__1, d__2); + d__1 = abs(*c__), d__2 = abs(*d__); + cd = max(d__1, d__2); + s = 1.; + ov = dlamch_((char *)"Overflow threshold", (ftnlen)18); + un = dlamch_((char *)"Safe minimum", (ftnlen)12); + eps = dlamch_((char *)"Epsilon", (ftnlen)7); + be = 2. / (eps * eps); + if (ab >= ov * .5) { + aa *= .5; + bb *= .5; + s *= 2.; + } + if (cd >= ov * .5) { + cc *= .5; + dd *= .5; + s *= .5; + } + if (ab <= un * 2. / eps) { + aa *= be; + bb *= be; + s /= be; + } + if (cd <= un * 2. / eps) { + cc *= be; + dd *= be; + s *= be; + } + if (abs(*d__) <= abs(*c__)) { + dladiv1_(&aa, &bb, &cc, &dd, p, q); + } else { + dladiv1_(&bb, &aa, &dd, &cc, p, q); + *q = -(*q); + } + *p *= s; + *q *= s; + return 0; +} +int dladiv1_(doublereal *a, doublereal *b, doublereal *c__, doublereal *d__, doublereal *p, + doublereal *q) +{ + doublereal r__, t; + extern doublereal dladiv2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *); + r__ = *d__ / *c__; + t = 1. / (*c__ + *d__ * r__); + *p = dladiv2_(a, b, c__, d__, &r__, &t); + *a = -(*a); + *q = dladiv2_(b, a, c__, d__, &r__, &t); + return 0; +} +doublereal dladiv2_(doublereal *a, doublereal *b, doublereal *c__, doublereal *d__, doublereal *r__, + doublereal *t) +{ + doublereal ret_val; + doublereal br; + if (*r__ != 0.) { + br = *b * *r__; + if (br != 0.) { + ret_val = (*a + br) * *t; + } else { + ret_val = *a * *t + *b * *t * *r__; + } + } else { + ret_val = (*a + *d__ * (*b / *c__)) * *t; + } + return ret_val; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dladiv.f b/lib/linalg/dladiv.f deleted file mode 100644 index 4265618fed..0000000000 --- a/lib/linalg/dladiv.f +++ /dev/null @@ -1,251 +0,0 @@ -*> \brief \b DLADIV performs complex division in real arithmetic, avoiding unnecessary overflow. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLADIV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLADIV( A, B, C, D, P, Q ) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION A, B, C, D, P, Q -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLADIV performs complex division in real arithmetic -*> -*> a + i*b -*> p + i*q = --------- -*> c + i*d -*> -*> The algorithm is due to Michael Baudin and Robert L. Smith -*> and can be found in the paper -*> "A Robust Complex Division in Scilab" -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in] B -*> \verbatim -*> B is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in] C -*> \verbatim -*> C is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in] D -*> \verbatim -*> D is DOUBLE PRECISION -*> The scalars a, b, c, and d in the above expression. -*> \endverbatim -*> -*> \param[out] P -*> \verbatim -*> P is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[out] Q -*> \verbatim -*> Q is DOUBLE PRECISION -*> The scalars p and q in the above expression. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLADIV( A, B, C, D, P, Q ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION A, B, C, D, P, Q -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION BS - PARAMETER ( BS = 2.0D0 ) - DOUBLE PRECISION HALF - PARAMETER ( HALF = 0.5D0 ) - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.0D0 ) -* -* .. Local Scalars .. - DOUBLE PRECISION AA, BB, CC, DD, AB, CD, S, OV, UN, BE, EPS -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DLADIV1 -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. -* .. Executable Statements .. -* - AA = A - BB = B - CC = C - DD = D - AB = MAX( ABS(A), ABS(B) ) - CD = MAX( ABS(C), ABS(D) ) - S = 1.0D0 - - OV = DLAMCH( 'Overflow threshold' ) - UN = DLAMCH( 'Safe minimum' ) - EPS = DLAMCH( 'Epsilon' ) - BE = BS / (EPS*EPS) - - IF( AB >= HALF*OV ) THEN - AA = HALF * AA - BB = HALF * BB - S = TWO * S - END IF - IF( CD >= HALF*OV ) THEN - CC = HALF * CC - DD = HALF * DD - S = HALF * S - END IF - IF( AB <= UN*BS/EPS ) THEN - AA = AA * BE - BB = BB * BE - S = S / BE - END IF - IF( CD <= UN*BS/EPS ) THEN - CC = CC * BE - DD = DD * BE - S = S * BE - END IF - IF( ABS( D ).LE.ABS( C ) ) THEN - CALL DLADIV1(AA, BB, CC, DD, P, Q) - ELSE - CALL DLADIV1(BB, AA, DD, CC, P, Q) - Q = -Q - END IF - P = P * S - Q = Q * S -* - RETURN -* -* End of DLADIV -* - END - -*> \ingroup doubleOTHERauxiliary - - - SUBROUTINE DLADIV1( A, B, C, D, P, Q ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION A, B, C, D, P, Q -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -* -* .. Local Scalars .. - DOUBLE PRECISION R, T -* .. -* .. External Functions .. - DOUBLE PRECISION DLADIV2 - EXTERNAL DLADIV2 -* .. -* .. Executable Statements .. -* - R = D / C - T = ONE / (C + D * R) - P = DLADIV2(A, B, C, D, R, T) - A = -A - Q = DLADIV2(B, A, C, D, R, T) -* - RETURN -* -* End of DLADIV1 -* - END - -*> \ingroup doubleOTHERauxiliary - - DOUBLE PRECISION FUNCTION DLADIV2( A, B, C, D, R, T ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION A, B, C, D, R, T -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -* -* .. Local Scalars .. - DOUBLE PRECISION BR -* .. -* .. Executable Statements .. -* - IF( R.NE.ZERO ) THEN - BR = B * R - IF( BR.NE.ZERO ) THEN - DLADIV2 = (A + BR) * T - ELSE - DLADIV2 = A * T + (B * T) * R - END IF - ELSE - DLADIV2 = (A + D * (B / C)) * T - END IF -* - RETURN -* -* End of DLADIV2 -* - END diff --git a/lib/linalg/dlae2.cpp b/lib/linalg/dlae2.cpp new file mode 100644 index 0000000000..985e03a608 --- /dev/null +++ b/lib/linalg/dlae2.cpp @@ -0,0 +1,45 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dlae2_(doublereal *a, doublereal *b, doublereal *c__, doublereal *rt1, doublereal *rt2) +{ + doublereal d__1; + double sqrt(doublereal); + doublereal ab, df, tb, sm, rt, adf, acmn, acmx; + sm = *a + *c__; + df = *a - *c__; + adf = abs(df); + tb = *b + *b; + ab = abs(tb); + if (abs(*a) > abs(*c__)) { + acmx = *a; + acmn = *c__; + } else { + acmx = *c__; + acmn = *a; + } + if (adf > ab) { + d__1 = ab / adf; + rt = adf * sqrt(d__1 * d__1 + 1.); + } else if (adf < ab) { + d__1 = adf / ab; + rt = ab * sqrt(d__1 * d__1 + 1.); + } else { + rt = ab * sqrt(2.); + } + if (sm < 0.) { + *rt1 = (sm - rt) * .5; + *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; + } else if (sm > 0.) { + *rt1 = (sm + rt) * .5; + *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; + } else { + *rt1 = rt * .5; + *rt2 = rt * -.5; + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlae2.f b/lib/linalg/dlae2.f deleted file mode 100644 index a0e3971b41..0000000000 --- a/lib/linalg/dlae2.f +++ /dev/null @@ -1,182 +0,0 @@ -*> \brief \b DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAE2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION A, B, C, RT1, RT2 -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix -*> [ A B ] -*> [ B C ]. -*> On return, RT1 is the eigenvalue of larger absolute value, and RT2 -*> is the eigenvalue of smaller absolute value. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION -*> The (1,1) element of the 2-by-2 matrix. -*> \endverbatim -*> -*> \param[in] B -*> \verbatim -*> B is DOUBLE PRECISION -*> The (1,2) and (2,1) elements of the 2-by-2 matrix. -*> \endverbatim -*> -*> \param[in] C -*> \verbatim -*> C is DOUBLE PRECISION -*> The (2,2) element of the 2-by-2 matrix. -*> \endverbatim -*> -*> \param[out] RT1 -*> \verbatim -*> RT1 is DOUBLE PRECISION -*> The eigenvalue of larger absolute value. -*> \endverbatim -*> -*> \param[out] RT2 -*> \verbatim -*> RT2 is DOUBLE PRECISION -*> The eigenvalue of smaller absolute value. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> RT1 is accurate to a few ulps barring over/underflow. -*> -*> RT2 may be inaccurate if there is massive cancellation in the -*> determinant A*C-B*B; higher precision or correctly rounded or -*> correctly truncated arithmetic would be needed to compute RT2 -*> accurately in all cases. -*> -*> Overflow is possible only if RT1 is within a factor of 5 of overflow. -*> Underflow is harmless if the input data is 0 or exceeds -*> underflow_threshold / macheps. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION A, B, C, RT1, RT2 -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.0D0 ) - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION HALF - PARAMETER ( HALF = 0.5D0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION AB, ACMN, ACMX, ADF, DF, RT, SM, TB -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -* .. -* .. Executable Statements .. -* -* Compute the eigenvalues -* - SM = A + C - DF = A - C - ADF = ABS( DF ) - TB = B + B - AB = ABS( TB ) - IF( ABS( A ).GT.ABS( C ) ) THEN - ACMX = A - ACMN = C - ELSE - ACMX = C - ACMN = A - END IF - IF( ADF.GT.AB ) THEN - RT = ADF*SQRT( ONE+( AB / ADF )**2 ) - ELSE IF( ADF.LT.AB ) THEN - RT = AB*SQRT( ONE+( ADF / AB )**2 ) - ELSE -* -* Includes case AB=ADF=0 -* - RT = AB*SQRT( TWO ) - END IF - IF( SM.LT.ZERO ) THEN - RT1 = HALF*( SM-RT ) -* -* Order of execution important. -* To get fully accurate smaller eigenvalue, -* next line needs to be executed in higher precision. -* - RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B - ELSE IF( SM.GT.ZERO ) THEN - RT1 = HALF*( SM+RT ) -* -* Order of execution important. -* To get fully accurate smaller eigenvalue, -* next line needs to be executed in higher precision. -* - RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B - ELSE -* -* Includes case RT1 = RT2 = 0 -* - RT1 = HALF*RT - RT2 = -HALF*RT - END IF - RETURN -* -* End of DLAE2 -* - END diff --git a/lib/linalg/dlaed0.cpp b/lib/linalg/dlaed0.cpp new file mode 100644 index 0000000000..b1a243175b --- /dev/null +++ b/lib/linalg/dlaed0.cpp @@ -0,0 +1,236 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__9 = 9; +static integer c__0 = 0; +static integer c__2 = 2; +static doublereal c_b23 = 1.; +static doublereal c_b24 = 0.; +static integer c__1 = 1; +int dlaed0_(integer *icompq, integer *qsiz, integer *n, doublereal *d__, doublereal *e, + doublereal *q, integer *ldq, doublereal *qstore, integer *ldqs, doublereal *work, + integer *iwork, integer *info) +{ + integer q_dim1, q_offset, qstore_dim1, qstore_offset, i__1, i__2; + doublereal d__1; + double log(doublereal); + integer pow_lmp_ii(integer *, integer *); + integer i__, j, k, iq, lgn, msd2, smm1, spm1, spm2; + doublereal temp; + integer curr; + extern int dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, + ftnlen, ftnlen); + integer iperm; + extern int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *); + integer indxq, iwrem; + extern int dlaed1_(integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, doublereal *, integer *, integer *); + integer iqptr; + extern int dlaed7_(integer *, integer *, integer *, integer *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, + doublereal *, integer *, integer *, integer *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *); + integer tlvls; + extern int dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, + integer *, ftnlen); + integer igivcl; + extern int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, + ftnlen, ftnlen); + integer igivnm, submat, curprb, subpbs, igivpt; + extern int dsteqr_(char *, integer *, doublereal *, doublereal *, doublereal *, integer *, + doublereal *, integer *, ftnlen); + integer curlvl, matsiz, iprmpt, smlsiz; + --d__; + --e; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + qstore_dim1 = *ldqs; + qstore_offset = 1 + qstore_dim1; + qstore -= qstore_offset; + --work; + --iwork; + *info = 0; + if (*icompq < 0 || *icompq > 2) { + *info = -1; + } else if (*icompq == 1 && *qsiz < max(0, *n)) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ldq < max(1, *n)) { + *info = -7; + } else if (*ldqs < max(1, *n)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DLAED0", &i__1, (ftnlen)6); + return 0; + } + if (*n == 0) { + return 0; + } + smlsiz = ilaenv_(&c__9, (char *)"DLAED0", (char *)" ", &c__0, &c__0, &c__0, &c__0, (ftnlen)6, (ftnlen)1); + iwork[1] = *n; + subpbs = 1; + tlvls = 0; +L10: + if (iwork[subpbs] > smlsiz) { + for (j = subpbs; j >= 1; --j) { + iwork[j * 2] = (iwork[j] + 1) / 2; + iwork[(j << 1) - 1] = iwork[j] / 2; + } + ++tlvls; + subpbs <<= 1; + goto L10; + } + i__1 = subpbs; + for (j = 2; j <= i__1; ++j) { + iwork[j] += iwork[j - 1]; + } + spm1 = subpbs - 1; + i__1 = spm1; + for (i__ = 1; i__ <= i__1; ++i__) { + submat = iwork[i__] + 1; + smm1 = submat - 1; + d__[smm1] -= (d__1 = e[smm1], abs(d__1)); + d__[submat] -= (d__1 = e[smm1], abs(d__1)); + } + indxq = (*n << 2) + 3; + if (*icompq != 2) { + temp = log((doublereal)(*n)) / log(2.); + lgn = (integer)temp; + if (pow_lmp_ii(&c__2, &lgn) < *n) { + ++lgn; + } + if (pow_lmp_ii(&c__2, &lgn) < *n) { + ++lgn; + } + iprmpt = indxq + *n + 1; + iperm = iprmpt + *n * lgn; + iqptr = iperm + *n * lgn; + igivpt = iqptr + *n + 2; + igivcl = igivpt + *n * lgn; + igivnm = 1; + iq = igivnm + (*n << 1) * lgn; + i__1 = *n; + iwrem = iq + i__1 * i__1 + 1; + i__1 = subpbs; + for (i__ = 0; i__ <= i__1; ++i__) { + iwork[iprmpt + i__] = 1; + iwork[igivpt + i__] = 1; + } + iwork[iqptr] = 1; + } + curr = 0; + i__1 = spm1; + for (i__ = 0; i__ <= i__1; ++i__) { + if (i__ == 0) { + submat = 1; + matsiz = iwork[1]; + } else { + submat = iwork[i__] + 1; + matsiz = iwork[i__ + 1] - iwork[i__]; + } + if (*icompq == 2) { + dsteqr_((char *)"I", &matsiz, &d__[submat], &e[submat], &q[submat + submat * q_dim1], ldq, + &work[1], info, (ftnlen)1); + if (*info != 0) { + goto L130; + } + } else { + dsteqr_((char *)"I", &matsiz, &d__[submat], &e[submat], &work[iq - 1 + iwork[iqptr + curr]], + &matsiz, &work[1], info, (ftnlen)1); + if (*info != 0) { + goto L130; + } + if (*icompq == 1) { + dgemm_((char *)"N", (char *)"N", qsiz, &matsiz, &matsiz, &c_b23, &q[submat * q_dim1 + 1], ldq, + &work[iq - 1 + iwork[iqptr + curr]], &matsiz, &c_b24, + &qstore[submat * qstore_dim1 + 1], ldqs, (ftnlen)1, (ftnlen)1); + } + i__2 = matsiz; + iwork[iqptr + curr + 1] = iwork[iqptr + curr] + i__2 * i__2; + ++curr; + } + k = 1; + i__2 = iwork[i__ + 1]; + for (j = submat; j <= i__2; ++j) { + iwork[indxq + j] = k; + ++k; + } + } + curlvl = 1; +L80: + if (subpbs > 1) { + spm2 = subpbs - 2; + i__1 = spm2; + for (i__ = 0; i__ <= i__1; i__ += 2) { + if (i__ == 0) { + submat = 1; + matsiz = iwork[2]; + msd2 = iwork[1]; + curprb = 0; + } else { + submat = iwork[i__] + 1; + matsiz = iwork[i__ + 2] - iwork[i__]; + msd2 = matsiz / 2; + ++curprb; + } + if (*icompq == 2) { + dlaed1_(&matsiz, &d__[submat], &q[submat + submat * q_dim1], ldq, + &iwork[indxq + submat], &e[submat + msd2 - 1], &msd2, &work[1], + &iwork[subpbs + 1], info); + } else { + dlaed7_(icompq, &matsiz, qsiz, &tlvls, &curlvl, &curprb, &d__[submat], + &qstore[submat * qstore_dim1 + 1], ldqs, &iwork[indxq + submat], + &e[submat + msd2 - 1], &msd2, &work[iq], &iwork[iqptr], &iwork[iprmpt], + &iwork[iperm], &iwork[igivpt], &iwork[igivcl], &work[igivnm], &work[iwrem], + &iwork[subpbs + 1], info); + } + if (*info != 0) { + goto L130; + } + iwork[i__ / 2 + 1] = iwork[i__ + 2]; + } + subpbs /= 2; + ++curlvl; + goto L80; + } + if (*icompq == 1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + j = iwork[indxq + i__]; + work[i__] = d__[j]; + dcopy_(qsiz, &qstore[j * qstore_dim1 + 1], &c__1, &q[i__ * q_dim1 + 1], &c__1); + } + dcopy_(n, &work[1], &c__1, &d__[1], &c__1); + } else if (*icompq == 2) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + j = iwork[indxq + i__]; + work[i__] = d__[j]; + dcopy_(n, &q[j * q_dim1 + 1], &c__1, &work[*n * i__ + 1], &c__1); + } + dcopy_(n, &work[1], &c__1, &d__[1], &c__1); + dlacpy_((char *)"A", n, n, &work[*n + 1], n, &q[q_offset], ldq, (ftnlen)1); + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + j = iwork[indxq + i__]; + work[i__] = d__[j]; + } + dcopy_(n, &work[1], &c__1, &d__[1], &c__1); + } + goto L140; +L130: + *info = submat * (*n + 1) + submat + matsiz - 1; +L140: + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlaed0.f b/lib/linalg/dlaed0.f deleted file mode 100644 index fe3b6249e9..0000000000 --- a/lib/linalg/dlaed0.f +++ /dev/null @@ -1,431 +0,0 @@ -*> \brief \b DLAED0 used by DSTEDC. Computes all eigenvalues and corresponding eigenvectors of an unreduced symmetric tridiagonal matrix using the divide and conquer method. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAED0 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, -* WORK, IWORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ -* .. -* .. Array Arguments .. -* INTEGER IWORK( * ) -* DOUBLE PRECISION D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ), -* $ WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAED0 computes all eigenvalues and corresponding eigenvectors of a -*> symmetric tridiagonal matrix using the divide and conquer method. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] ICOMPQ -*> \verbatim -*> ICOMPQ is INTEGER -*> = 0: Compute eigenvalues only. -*> = 1: Compute eigenvectors of original dense symmetric matrix -*> also. On entry, Q contains the orthogonal matrix used -*> to reduce the original matrix to tridiagonal form. -*> = 2: Compute eigenvalues and eigenvectors of tridiagonal -*> matrix. -*> \endverbatim -*> -*> \param[in] QSIZ -*> \verbatim -*> QSIZ is INTEGER -*> The dimension of the orthogonal matrix used to reduce -*> the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The dimension of the symmetric tridiagonal matrix. N >= 0. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, the main diagonal of the tridiagonal matrix. -*> On exit, its eigenvalues. -*> \endverbatim -*> -*> \param[in] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N-1) -*> The off-diagonal elements of the tridiagonal matrix. -*> On exit, E has been destroyed. -*> \endverbatim -*> -*> \param[in,out] Q -*> \verbatim -*> Q is DOUBLE PRECISION array, dimension (LDQ, N) -*> On entry, Q must contain an N-by-N orthogonal matrix. -*> If ICOMPQ = 0 Q is not referenced. -*> If ICOMPQ = 1 On entry, Q is a subset of the columns of the -*> orthogonal matrix used to reduce the full -*> matrix to tridiagonal form corresponding to -*> the subset of the full matrix which is being -*> decomposed at this time. -*> If ICOMPQ = 2 On entry, Q will be the identity matrix. -*> On exit, Q contains the eigenvectors of the -*> tridiagonal matrix. -*> \endverbatim -*> -*> \param[in] LDQ -*> \verbatim -*> LDQ is INTEGER -*> The leading dimension of the array Q. If eigenvectors are -*> desired, then LDQ >= max(1,N). In any case, LDQ >= 1. -*> \endverbatim -*> -*> \param[out] QSTORE -*> \verbatim -*> QSTORE is DOUBLE PRECISION array, dimension (LDQS, N) -*> Referenced only when ICOMPQ = 1. Used to store parts of -*> the eigenvector matrix when the updating matrix multiplies -*> take place. -*> \endverbatim -*> -*> \param[in] LDQS -*> \verbatim -*> LDQS is INTEGER -*> The leading dimension of the array QSTORE. If ICOMPQ = 1, -*> then LDQS >= max(1,N). In any case, LDQS >= 1. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, -*> If ICOMPQ = 0 or 1, the dimension of WORK must be at least -*> 1 + 3*N + 2*N*lg N + 3*N**2 -*> ( lg( N ) = smallest integer k -*> such that 2^k >= N ) -*> If ICOMPQ = 2, the dimension of WORK must be at least -*> 4*N + N**2. -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, -*> If ICOMPQ = 0 or 1, the dimension of IWORK must be at least -*> 6 + 6*N + 5*N*lg N. -*> ( lg( N ) = smallest integer k -*> such that 2^k >= N ) -*> If ICOMPQ = 2, the dimension of IWORK must be at least -*> 3 + 5*N. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit. -*> < 0: if INFO = -i, the i-th argument had an illegal value. -*> > 0: The algorithm failed to compute an eigenvalue while -*> working on the submatrix lying in rows and columns -*> INFO/(N+1) through mod(INFO,N+1). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -*> \par Contributors: -* ================== -*> -*> Jeff Rutter, Computer Science Division, University of California -*> at Berkeley, USA -* -* ===================================================================== - SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, - $ WORK, IWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ -* .. -* .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ), - $ WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.D0, ONE = 1.D0, TWO = 2.D0 ) -* .. -* .. Local Scalars .. - INTEGER CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM, - $ IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM, - $ J, K, LGN, MATSIZ, MSD2, SMLSIZ, SMM1, SPM1, - $ SPM2, SUBMAT, SUBPBS, TLVLS - DOUBLE PRECISION TEMP -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DLACPY, DLAED1, DLAED7, DSTEQR, - $ XERBLA -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, LOG, MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.2 ) THEN - INFO = -1 - ELSE IF( ( ICOMPQ.EQ.1 ) .AND. ( QSIZ.LT.MAX( 0, N ) ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDQS.LT.MAX( 1, N ) ) THEN - INFO = -9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLAED0', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - SMLSIZ = ILAENV( 9, 'DLAED0', ' ', 0, 0, 0, 0 ) -* -* Determine the size and placement of the submatrices, and save in -* the leading elements of IWORK. -* - IWORK( 1 ) = N - SUBPBS = 1 - TLVLS = 0 - 10 CONTINUE - IF( IWORK( SUBPBS ).GT.SMLSIZ ) THEN - DO 20 J = SUBPBS, 1, -1 - IWORK( 2*J ) = ( IWORK( J )+1 ) / 2 - IWORK( 2*J-1 ) = IWORK( J ) / 2 - 20 CONTINUE - TLVLS = TLVLS + 1 - SUBPBS = 2*SUBPBS - GO TO 10 - END IF - DO 30 J = 2, SUBPBS - IWORK( J ) = IWORK( J ) + IWORK( J-1 ) - 30 CONTINUE -* -* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1 -* using rank-1 modifications (cuts). -* - SPM1 = SUBPBS - 1 - DO 40 I = 1, SPM1 - SUBMAT = IWORK( I ) + 1 - SMM1 = SUBMAT - 1 - D( SMM1 ) = D( SMM1 ) - ABS( E( SMM1 ) ) - D( SUBMAT ) = D( SUBMAT ) - ABS( E( SMM1 ) ) - 40 CONTINUE -* - INDXQ = 4*N + 3 - IF( ICOMPQ.NE.2 ) THEN -* -* Set up workspaces for eigenvalues only/accumulate new vectors -* routine -* - TEMP = LOG( DBLE( N ) ) / LOG( TWO ) - LGN = INT( TEMP ) - IF( 2**LGN.LT.N ) - $ LGN = LGN + 1 - IF( 2**LGN.LT.N ) - $ LGN = LGN + 1 - IPRMPT = INDXQ + N + 1 - IPERM = IPRMPT + N*LGN - IQPTR = IPERM + N*LGN - IGIVPT = IQPTR + N + 2 - IGIVCL = IGIVPT + N*LGN -* - IGIVNM = 1 - IQ = IGIVNM + 2*N*LGN - IWREM = IQ + N**2 + 1 -* -* Initialize pointers -* - DO 50 I = 0, SUBPBS - IWORK( IPRMPT+I ) = 1 - IWORK( IGIVPT+I ) = 1 - 50 CONTINUE - IWORK( IQPTR ) = 1 - END IF -* -* Solve each submatrix eigenproblem at the bottom of the divide and -* conquer tree. -* - CURR = 0 - DO 70 I = 0, SPM1 - IF( I.EQ.0 ) THEN - SUBMAT = 1 - MATSIZ = IWORK( 1 ) - ELSE - SUBMAT = IWORK( I ) + 1 - MATSIZ = IWORK( I+1 ) - IWORK( I ) - END IF - IF( ICOMPQ.EQ.2 ) THEN - CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ), - $ Q( SUBMAT, SUBMAT ), LDQ, WORK, INFO ) - IF( INFO.NE.0 ) - $ GO TO 130 - ELSE - CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ), - $ WORK( IQ-1+IWORK( IQPTR+CURR ) ), MATSIZ, WORK, - $ INFO ) - IF( INFO.NE.0 ) - $ GO TO 130 - IF( ICOMPQ.EQ.1 ) THEN - CALL DGEMM( 'N', 'N', QSIZ, MATSIZ, MATSIZ, ONE, - $ Q( 1, SUBMAT ), LDQ, WORK( IQ-1+IWORK( IQPTR+ - $ CURR ) ), MATSIZ, ZERO, QSTORE( 1, SUBMAT ), - $ LDQS ) - END IF - IWORK( IQPTR+CURR+1 ) = IWORK( IQPTR+CURR ) + MATSIZ**2 - CURR = CURR + 1 - END IF - K = 1 - DO 60 J = SUBMAT, IWORK( I+1 ) - IWORK( INDXQ+J ) = K - K = K + 1 - 60 CONTINUE - 70 CONTINUE -* -* Successively merge eigensystems of adjacent submatrices -* into eigensystem for the corresponding larger matrix. -* -* while ( SUBPBS > 1 ) -* - CURLVL = 1 - 80 CONTINUE - IF( SUBPBS.GT.1 ) THEN - SPM2 = SUBPBS - 2 - DO 90 I = 0, SPM2, 2 - IF( I.EQ.0 ) THEN - SUBMAT = 1 - MATSIZ = IWORK( 2 ) - MSD2 = IWORK( 1 ) - CURPRB = 0 - ELSE - SUBMAT = IWORK( I ) + 1 - MATSIZ = IWORK( I+2 ) - IWORK( I ) - MSD2 = MATSIZ / 2 - CURPRB = CURPRB + 1 - END IF -* -* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2) -* into an eigensystem of size MATSIZ. -* DLAED1 is used only for the full eigensystem of a tridiagonal -* matrix. -* DLAED7 handles the cases in which eigenvalues only or eigenvalues -* and eigenvectors of a full symmetric matrix (which was reduced to -* tridiagonal form) are desired. -* - IF( ICOMPQ.EQ.2 ) THEN - CALL DLAED1( MATSIZ, D( SUBMAT ), Q( SUBMAT, SUBMAT ), - $ LDQ, IWORK( INDXQ+SUBMAT ), - $ E( SUBMAT+MSD2-1 ), MSD2, WORK, - $ IWORK( SUBPBS+1 ), INFO ) - ELSE - CALL DLAED7( ICOMPQ, MATSIZ, QSIZ, TLVLS, CURLVL, CURPRB, - $ D( SUBMAT ), QSTORE( 1, SUBMAT ), LDQS, - $ IWORK( INDXQ+SUBMAT ), E( SUBMAT+MSD2-1 ), - $ MSD2, WORK( IQ ), IWORK( IQPTR ), - $ IWORK( IPRMPT ), IWORK( IPERM ), - $ IWORK( IGIVPT ), IWORK( IGIVCL ), - $ WORK( IGIVNM ), WORK( IWREM ), - $ IWORK( SUBPBS+1 ), INFO ) - END IF - IF( INFO.NE.0 ) - $ GO TO 130 - IWORK( I / 2+1 ) = IWORK( I+2 ) - 90 CONTINUE - SUBPBS = SUBPBS / 2 - CURLVL = CURLVL + 1 - GO TO 80 - END IF -* -* end while -* -* Re-merge the eigenvalues/vectors which were deflated at the final -* merge step. -* - IF( ICOMPQ.EQ.1 ) THEN - DO 100 I = 1, N - J = IWORK( INDXQ+I ) - WORK( I ) = D( J ) - CALL DCOPY( QSIZ, QSTORE( 1, J ), 1, Q( 1, I ), 1 ) - 100 CONTINUE - CALL DCOPY( N, WORK, 1, D, 1 ) - ELSE IF( ICOMPQ.EQ.2 ) THEN - DO 110 I = 1, N - J = IWORK( INDXQ+I ) - WORK( I ) = D( J ) - CALL DCOPY( N, Q( 1, J ), 1, WORK( N*I+1 ), 1 ) - 110 CONTINUE - CALL DCOPY( N, WORK, 1, D, 1 ) - CALL DLACPY( 'A', N, N, WORK( N+1 ), N, Q, LDQ ) - ELSE - DO 120 I = 1, N - J = IWORK( INDXQ+I ) - WORK( I ) = D( J ) - 120 CONTINUE - CALL DCOPY( N, WORK, 1, D, 1 ) - END IF - GO TO 140 -* - 130 CONTINUE - INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1 -* - 140 CONTINUE - RETURN -* -* End of DLAED0 -* - END diff --git a/lib/linalg/dlaed1.cpp b/lib/linalg/dlaed1.cpp new file mode 100644 index 0000000000..2d40bdfcd8 --- /dev/null +++ b/lib/linalg/dlaed1.cpp @@ -0,0 +1,90 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +static integer c_n1 = -1; +int dlaed1_(integer *n, doublereal *d__, doublereal *q, integer *ldq, integer *indxq, + doublereal *rho, integer *cutpnt, doublereal *work, integer *iwork, integer *info) +{ + integer q_dim1, q_offset, i__1, i__2; + integer i__, k, n1, n2, is, iw, iz, iq2, zpp1, indx, indxc; + extern int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *); + integer indxp; + extern int dlaed2_(integer *, integer *, integer *, doublereal *, doublereal *, integer *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *, integer *, integer *, integer *, integer *), + dlaed3_(integer *, integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *, + doublereal *, integer *); + integer idlmda; + extern int dlamrg_(integer *, integer *, doublereal *, integer *, integer *, integer *), + xerbla_(char *, integer *, ftnlen); + integer coltyp; + --d__; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + --indxq; + --work; + --iwork; + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*ldq < max(1, *n)) { + *info = -4; + } else { + i__1 = 1, i__2 = *n / 2; + if (min(i__1, i__2) > *cutpnt || *n / 2 < *cutpnt) { + *info = -7; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DLAED1", &i__1, (ftnlen)6); + return 0; + } + if (*n == 0) { + return 0; + } + iz = 1; + idlmda = iz + *n; + iw = idlmda + *n; + iq2 = iw + *n; + indx = 1; + indxc = indx + *n; + coltyp = indxc + *n; + indxp = coltyp + *n; + dcopy_(cutpnt, &q[*cutpnt + q_dim1], ldq, &work[iz], &c__1); + zpp1 = *cutpnt + 1; + i__1 = *n - *cutpnt; + dcopy_(&i__1, &q[zpp1 + zpp1 * q_dim1], ldq, &work[iz + *cutpnt], &c__1); + dlaed2_(&k, n, cutpnt, &d__[1], &q[q_offset], ldq, &indxq[1], rho, &work[iz], &work[idlmda], + &work[iw], &work[iq2], &iwork[indx], &iwork[indxc], &iwork[indxp], &iwork[coltyp], + info); + if (*info != 0) { + goto L20; + } + if (k != 0) { + is = (iwork[coltyp] + iwork[coltyp + 1]) * *cutpnt + + (iwork[coltyp + 1] + iwork[coltyp + 2]) * (*n - *cutpnt) + iq2; + dlaed3_(&k, n, cutpnt, &d__[1], &q[q_offset], ldq, rho, &work[idlmda], &work[iq2], + &iwork[indxc], &iwork[coltyp], &work[iw], &work[is], info); + if (*info != 0) { + goto L20; + } + n1 = k; + n2 = *n - k; + dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]); + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + indxq[i__] = i__; + } + } +L20: + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlaed1.f b/lib/linalg/dlaed1.f deleted file mode 100644 index 3718139c14..0000000000 --- a/lib/linalg/dlaed1.f +++ /dev/null @@ -1,271 +0,0 @@ -*> \brief \b DLAED1 used by DSTEDC. Computes the updated eigensystem of a diagonal matrix after modification by a rank-one symmetric matrix. Used when the original matrix is tridiagonal. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAED1 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, -* INFO ) -* -* .. Scalar Arguments .. -* INTEGER CUTPNT, INFO, LDQ, N -* DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. -* INTEGER INDXQ( * ), IWORK( * ) -* DOUBLE PRECISION D( * ), Q( LDQ, * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAED1 computes the updated eigensystem of a diagonal -*> matrix after modification by a rank-one symmetric matrix. This -*> routine is used only for the eigenproblem which requires all -*> eigenvalues and eigenvectors of a tridiagonal matrix. DLAED7 handles -*> the case in which eigenvalues only or eigenvalues and eigenvectors -*> of a full symmetric matrix (which was reduced to tridiagonal form) -*> are desired. -*> -*> T = Q(in) ( D(in) + RHO * Z*Z**T ) Q**T(in) = Q(out) * D(out) * Q**T(out) -*> -*> where Z = Q**T*u, u is a vector of length N with ones in the -*> CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. -*> -*> The eigenvectors of the original matrix are stored in Q, and the -*> eigenvalues are in D. The algorithm consists of three stages: -*> -*> The first stage consists of deflating the size of the problem -*> when there are multiple eigenvalues or if there is a zero in -*> the Z vector. For each such occurrence the dimension of the -*> secular equation problem is reduced by one. This stage is -*> performed by the routine DLAED2. -*> -*> The second stage consists of calculating the updated -*> eigenvalues. This is done by finding the roots of the secular -*> equation via the routine DLAED4 (as called by DLAED3). -*> This routine also calculates the eigenvectors of the current -*> problem. -*> -*> The final stage consists of computing the updated eigenvectors -*> directly using the updated eigenvalues. The eigenvectors for -*> the current problem are multiplied with the eigenvectors from -*> the overall problem. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The dimension of the symmetric tridiagonal matrix. N >= 0. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, the eigenvalues of the rank-1-perturbed matrix. -*> On exit, the eigenvalues of the repaired matrix. -*> \endverbatim -*> -*> \param[in,out] Q -*> \verbatim -*> Q is DOUBLE PRECISION array, dimension (LDQ,N) -*> On entry, the eigenvectors of the rank-1-perturbed matrix. -*> On exit, the eigenvectors of the repaired tridiagonal matrix. -*> \endverbatim -*> -*> \param[in] LDQ -*> \verbatim -*> LDQ is INTEGER -*> The leading dimension of the array Q. LDQ >= max(1,N). -*> \endverbatim -*> -*> \param[in,out] INDXQ -*> \verbatim -*> INDXQ is INTEGER array, dimension (N) -*> On entry, the permutation which separately sorts the two -*> subproblems in D into ascending order. -*> On exit, the permutation which will reintegrate the -*> subproblems back into sorted order, -*> i.e. D( INDXQ( I = 1, N ) ) will be in ascending order. -*> \endverbatim -*> -*> \param[in] RHO -*> \verbatim -*> RHO is DOUBLE PRECISION -*> The subdiagonal entry used to create the rank-1 modification. -*> \endverbatim -*> -*> \param[in] CUTPNT -*> \verbatim -*> CUTPNT is INTEGER -*> The location of the last eigenvalue in the leading sub-matrix. -*> min(1,N) <= CUTPNT <= N/2. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (4*N + N**2) -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, dimension (4*N) -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit. -*> < 0: if INFO = -i, the i-th argument had an illegal value. -*> > 0: if INFO = 1, an eigenvalue did not converge -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -*> \par Contributors: -* ================== -*> -*> Jeff Rutter, Computer Science Division, University of California -*> at Berkeley, USA \n -*> Modified by Francoise Tisseur, University of Tennessee -*> -* ===================================================================== - SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, - $ INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER CUTPNT, INFO, LDQ, N - DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. - INTEGER INDXQ( * ), IWORK( * ) - DOUBLE PRECISION D( * ), Q( LDQ, * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER COLTYP, I, IDLMDA, INDX, INDXC, INDXP, IQ2, IS, - $ IW, IZ, K, N1, N2, ZPP1 -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DLAED2, DLAED3, DLAMRG, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( MIN( 1, N / 2 ).GT.CUTPNT .OR. ( N / 2 ).LT.CUTPNT ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLAED1', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* The following values are integer pointers which indicate -* the portion of the workspace -* used by a particular array in DLAED2 and DLAED3. -* - IZ = 1 - IDLMDA = IZ + N - IW = IDLMDA + N - IQ2 = IW + N -* - INDX = 1 - INDXC = INDX + N - COLTYP = INDXC + N - INDXP = COLTYP + N -* -* -* Form the z-vector which consists of the last row of Q_1 and the -* first row of Q_2. -* - CALL DCOPY( CUTPNT, Q( CUTPNT, 1 ), LDQ, WORK( IZ ), 1 ) - ZPP1 = CUTPNT + 1 - CALL DCOPY( N-CUTPNT, Q( ZPP1, ZPP1 ), LDQ, WORK( IZ+CUTPNT ), 1 ) -* -* Deflate eigenvalues. -* - CALL DLAED2( K, N, CUTPNT, D, Q, LDQ, INDXQ, RHO, WORK( IZ ), - $ WORK( IDLMDA ), WORK( IW ), WORK( IQ2 ), - $ IWORK( INDX ), IWORK( INDXC ), IWORK( INDXP ), - $ IWORK( COLTYP ), INFO ) -* - IF( INFO.NE.0 ) - $ GO TO 20 -* -* Solve Secular Equation. -* - IF( K.NE.0 ) THEN - IS = ( IWORK( COLTYP )+IWORK( COLTYP+1 ) )*CUTPNT + - $ ( IWORK( COLTYP+1 )+IWORK( COLTYP+2 ) )*( N-CUTPNT ) + IQ2 - CALL DLAED3( K, N, CUTPNT, D, Q, LDQ, RHO, WORK( IDLMDA ), - $ WORK( IQ2 ), IWORK( INDXC ), IWORK( COLTYP ), - $ WORK( IW ), WORK( IS ), INFO ) - IF( INFO.NE.0 ) - $ GO TO 20 -* -* Prepare the INDXQ sorting permutation. -* - N1 = K - N2 = N - K - CALL DLAMRG( N1, N2, D, 1, -1, INDXQ ) - ELSE - DO 10 I = 1, N - INDXQ( I ) = I - 10 CONTINUE - END IF -* - 20 CONTINUE - RETURN -* -* End of DLAED1 -* - END diff --git a/lib/linalg/dlaed2.cpp b/lib/linalg/dlaed2.cpp new file mode 100644 index 0000000000..4f0461bab9 --- /dev/null +++ b/lib/linalg/dlaed2.cpp @@ -0,0 +1,263 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static doublereal c_b3 = -1.; +static integer c__1 = 1; +int dlaed2_(integer *k, integer *n, integer *n1, doublereal *d__, doublereal *q, integer *ldq, + integer *indxq, doublereal *rho, doublereal *z__, doublereal *dlamda, doublereal *w, + doublereal *q2, integer *indx, integer *indxc, integer *indxp, integer *coltyp, + integer *info) +{ + integer q_dim1, q_offset, i__1, i__2; + doublereal d__1, d__2, d__3, d__4; + double sqrt(doublereal); + doublereal c__; + integer i__, j; + doublereal s, t; + integer k2, n2, ct, nj, pj, js, iq1, iq2, n1p1; + doublereal eps, tau, tol; + integer psm[4], imax, jmax; + extern int drot_(integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, + doublereal *); + integer ctot[4]; + extern int dscal_(integer *, doublereal *, doublereal *, integer *), + dcopy_(integer *, doublereal *, integer *, doublereal *, integer *); + extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, ftnlen); + extern integer idamax_(integer *, doublereal *, integer *); + extern int dlamrg_(integer *, integer *, doublereal *, integer *, integer *, integer *), + 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; + --indxq; + --z__; + --dlamda; + --w; + --q2; + --indx; + --indxc; + --indxp; + --coltyp; + *info = 0; + if (*n < 0) { + *info = -2; + } else if (*ldq < max(1, *n)) { + *info = -6; + } else { + i__1 = 1, i__2 = *n / 2; + if (min(i__1, i__2) > *n1 || *n / 2 < *n1) { + *info = -3; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DLAED2", &i__1, (ftnlen)6); + return 0; + } + if (*n == 0) { + return 0; + } + n2 = *n - *n1; + n1p1 = *n1 + 1; + if (*rho < 0.) { + dscal_(&n2, &c_b3, &z__[n1p1], &c__1); + } + t = 1. / sqrt(2.); + dscal_(n, &t, &z__[1], &c__1); + *rho = (d__1 = *rho * 2., abs(d__1)); + i__1 = *n; + for (i__ = n1p1; i__ <= i__1; ++i__) { + indxq[i__] += *n1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dlamda[i__] = d__[indxq[i__]]; + } + dlamrg_(n1, &n2, &dlamda[1], &c__1, &c__1, &indxc[1]); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + indx[i__] = indxq[indxc[i__]]; + } + imax = idamax_(n, &z__[1], &c__1); + jmax = idamax_(n, &d__[1], &c__1); + eps = dlamch_((char *)"Epsilon", (ftnlen)7); + d__3 = (d__1 = d__[jmax], abs(d__1)), d__4 = (d__2 = z__[imax], abs(d__2)); + tol = eps * 8. * max(d__3, d__4); + if (*rho * (d__1 = z__[imax], abs(d__1)) <= tol) { + *k = 0; + iq2 = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__ = indx[j]; + dcopy_(n, &q[i__ * q_dim1 + 1], &c__1, &q2[iq2], &c__1); + dlamda[j] = d__[i__]; + iq2 += *n; + } + dlacpy_((char *)"A", n, n, &q2[1], n, &q[q_offset], ldq, (ftnlen)1); + dcopy_(n, &dlamda[1], &c__1, &d__[1], &c__1); + goto L190; + } + i__1 = *n1; + for (i__ = 1; i__ <= i__1; ++i__) { + coltyp[i__] = 1; + } + i__1 = *n; + for (i__ = n1p1; i__ <= i__1; ++i__) { + coltyp[i__] = 3; + } + *k = 0; + k2 = *n + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + nj = indx[j]; + if (*rho * (d__1 = z__[nj], abs(d__1)) <= tol) { + --k2; + coltyp[nj] = 4; + indxp[k2] = nj; + if (j == *n) { + goto L100; + } + } else { + pj = nj; + goto L80; + } + } +L80: + ++j; + nj = indx[j]; + if (j > *n) { + goto L100; + } + if (*rho * (d__1 = z__[nj], abs(d__1)) <= tol) { + --k2; + coltyp[nj] = 4; + indxp[k2] = nj; + } else { + s = z__[pj]; + c__ = z__[nj]; + tau = dlapy2_(&c__, &s); + t = d__[nj] - d__[pj]; + c__ /= tau; + s = -s / tau; + if ((d__1 = t * c__ * s, abs(d__1)) <= tol) { + z__[nj] = tau; + z__[pj] = 0.; + if (coltyp[nj] != coltyp[pj]) { + coltyp[nj] = 2; + } + coltyp[pj] = 4; + drot_(n, &q[pj * q_dim1 + 1], &c__1, &q[nj * q_dim1 + 1], &c__1, &c__, &s); + d__1 = c__; + d__2 = s; + t = d__[pj] * (d__1 * d__1) + d__[nj] * (d__2 * d__2); + d__1 = s; + d__2 = c__; + d__[nj] = d__[pj] * (d__1 * d__1) + d__[nj] * (d__2 * d__2); + d__[pj] = t; + --k2; + i__ = 1; + L90: + if (k2 + i__ <= *n) { + if (d__[pj] < d__[indxp[k2 + i__]]) { + indxp[k2 + i__ - 1] = indxp[k2 + i__]; + indxp[k2 + i__] = pj; + ++i__; + goto L90; + } else { + indxp[k2 + i__ - 1] = pj; + } + } else { + indxp[k2 + i__ - 1] = pj; + } + pj = nj; + } else { + ++(*k); + dlamda[*k] = d__[pj]; + w[*k] = z__[pj]; + indxp[*k] = pj; + pj = nj; + } + } + goto L80; +L100: + ++(*k); + dlamda[*k] = d__[pj]; + w[*k] = z__[pj]; + indxp[*k] = pj; + for (j = 1; j <= 4; ++j) { + ctot[j - 1] = 0; + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + ct = coltyp[j]; + ++ctot[ct - 1]; + } + psm[0] = 1; + psm[1] = ctot[0] + 1; + psm[2] = psm[1] + ctot[1]; + psm[3] = psm[2] + ctot[2]; + *k = *n - ctot[3]; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + js = indxp[j]; + ct = coltyp[js]; + indx[psm[ct - 1]] = js; + indxc[psm[ct - 1]] = j; + ++psm[ct - 1]; + } + i__ = 1; + iq1 = 1; + iq2 = (ctot[0] + ctot[1]) * *n1 + 1; + i__1 = ctot[0]; + for (j = 1; j <= i__1; ++j) { + js = indx[i__]; + dcopy_(n1, &q[js * q_dim1 + 1], &c__1, &q2[iq1], &c__1); + z__[i__] = d__[js]; + ++i__; + iq1 += *n1; + } + i__1 = ctot[1]; + for (j = 1; j <= i__1; ++j) { + js = indx[i__]; + dcopy_(n1, &q[js * q_dim1 + 1], &c__1, &q2[iq1], &c__1); + dcopy_(&n2, &q[*n1 + 1 + js * q_dim1], &c__1, &q2[iq2], &c__1); + z__[i__] = d__[js]; + ++i__; + iq1 += *n1; + iq2 += n2; + } + i__1 = ctot[2]; + for (j = 1; j <= i__1; ++j) { + js = indx[i__]; + dcopy_(&n2, &q[*n1 + 1 + js * q_dim1], &c__1, &q2[iq2], &c__1); + z__[i__] = d__[js]; + ++i__; + iq2 += n2; + } + iq1 = iq2; + i__1 = ctot[3]; + for (j = 1; j <= i__1; ++j) { + js = indx[i__]; + dcopy_(n, &q[js * q_dim1 + 1], &c__1, &q2[iq2], &c__1); + iq2 += *n; + z__[i__] = d__[js]; + ++i__; + } + if (*k < *n) { + dlacpy_((char *)"A", n, &ctot[3], &q2[iq1], n, &q[(*k + 1) * q_dim1 + 1], ldq, (ftnlen)1); + i__1 = *n - *k; + dcopy_(&i__1, &z__[*k + 1], &c__1, &d__[*k + 1], &c__1); + } + for (j = 1; j <= 4; ++j) { + coltyp[j] = ctot[j - 1]; + } +L190: + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlaed2.f b/lib/linalg/dlaed2.f deleted file mode 100644 index 9b1f1e0930..0000000000 --- a/lib/linalg/dlaed2.f +++ /dev/null @@ -1,536 +0,0 @@ -*> \brief \b DLAED2 used by DSTEDC. Merges eigenvalues and deflates secular equation. Used when the original matrix is tridiagonal. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAED2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, -* Q2, INDX, INDXC, INDXP, COLTYP, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, K, LDQ, N, N1 -* DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. -* INTEGER COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ), -* $ INDXQ( * ) -* DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ), -* $ W( * ), Z( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAED2 merges the two sets of eigenvalues together into a single -*> sorted set. Then it tries to deflate the size of the problem. -*> There are two ways in which deflation can occur: when two or more -*> eigenvalues are close together or if there is a tiny entry in the -*> Z vector. For each such occurrence the order of the related secular -*> equation problem is reduced by one. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[out] K -*> \verbatim -*> K is INTEGER -*> The number of non-deflated eigenvalues, and the order of the -*> related secular equation. 0 <= K <=N. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The dimension of the symmetric tridiagonal matrix. N >= 0. -*> \endverbatim -*> -*> \param[in] N1 -*> \verbatim -*> N1 is INTEGER -*> The location of the last eigenvalue in the leading sub-matrix. -*> min(1,N) <= N1 <= N/2. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, D contains the eigenvalues of the two submatrices to -*> be combined. -*> On exit, D contains the trailing (N-K) updated eigenvalues -*> (those which were deflated) sorted into increasing order. -*> \endverbatim -*> -*> \param[in,out] Q -*> \verbatim -*> Q is DOUBLE PRECISION array, dimension (LDQ, N) -*> On entry, Q contains the eigenvectors of two submatrices in -*> the two square blocks with corners at (1,1), (N1,N1) -*> and (N1+1, N1+1), (N,N). -*> On exit, Q contains the trailing (N-K) updated eigenvectors -*> (those which were deflated) in its last N-K columns. -*> \endverbatim -*> -*> \param[in] LDQ -*> \verbatim -*> LDQ is INTEGER -*> The leading dimension of the array Q. LDQ >= max(1,N). -*> \endverbatim -*> -*> \param[in,out] INDXQ -*> \verbatim -*> INDXQ is INTEGER array, dimension (N) -*> The permutation which separately sorts the two sub-problems -*> in D into ascending order. Note that elements in the second -*> half of this permutation must first have N1 added to their -*> values. Destroyed on exit. -*> \endverbatim -*> -*> \param[in,out] RHO -*> \verbatim -*> RHO is DOUBLE PRECISION -*> On entry, the off-diagonal element associated with the rank-1 -*> cut which originally split the two submatrices which are now -*> being recombined. -*> On exit, RHO has been modified to the value required by -*> DLAED3. -*> \endverbatim -*> -*> \param[in] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension (N) -*> On entry, Z contains the updating vector (the last -*> row of the first sub-eigenvector matrix and the first row of -*> the second sub-eigenvector matrix). -*> On exit, the contents of Z have been destroyed by the updating -*> process. -*> \endverbatim -*> -*> \param[out] DLAMDA -*> \verbatim -*> DLAMDA is DOUBLE PRECISION array, dimension (N) -*> A copy of the first K eigenvalues which will be used by -*> DLAED3 to form the secular equation. -*> \endverbatim -*> -*> \param[out] W -*> \verbatim -*> W is DOUBLE PRECISION array, dimension (N) -*> The first k values of the final deflation-altered z-vector -*> which will be passed to DLAED3. -*> \endverbatim -*> -*> \param[out] Q2 -*> \verbatim -*> Q2 is DOUBLE PRECISION array, dimension (N1**2+(N-N1)**2) -*> A copy of the first K eigenvectors which will be used by -*> DLAED3 in a matrix multiply (DGEMM) to solve for the new -*> eigenvectors. -*> \endverbatim -*> -*> \param[out] INDX -*> \verbatim -*> INDX is INTEGER array, dimension (N) -*> The permutation used to sort the contents of DLAMDA into -*> ascending order. -*> \endverbatim -*> -*> \param[out] INDXC -*> \verbatim -*> INDXC is INTEGER array, dimension (N) -*> The permutation used to arrange the columns of the deflated -*> Q matrix into three groups: the first group contains non-zero -*> elements only at and above N1, the second contains -*> non-zero elements only below N1, and the third is dense. -*> \endverbatim -*> -*> \param[out] INDXP -*> \verbatim -*> INDXP is INTEGER array, dimension (N) -*> The permutation used to place deflated values of D at the end -*> of the array. INDXP(1:K) points to the nondeflated D-values -*> and INDXP(K+1:N) points to the deflated eigenvalues. -*> \endverbatim -*> -*> \param[out] COLTYP -*> \verbatim -*> COLTYP is INTEGER array, dimension (N) -*> During execution, a label which will indicate which of the -*> following types a column in the Q2 matrix is: -*> 1 : non-zero in the upper half only; -*> 2 : dense; -*> 3 : non-zero in the lower half only; -*> 4 : deflated. -*> On exit, COLTYP(i) is the number of columns of type i, -*> for i=1 to 4 only. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit. -*> < 0: if INFO = -i, the i-th argument had an illegal value. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -*> \par Contributors: -* ================== -*> -*> Jeff Rutter, Computer Science Division, University of California -*> at Berkeley, USA \n -*> Modified by Francoise Tisseur, University of Tennessee -*> -* ===================================================================== - SUBROUTINE DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, - $ Q2, INDX, INDXC, INDXP, COLTYP, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDQ, N, N1 - DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. - INTEGER COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ), - $ INDXQ( * ) - DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ), - $ W( * ), Z( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT - PARAMETER ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0, - $ TWO = 2.0D0, EIGHT = 8.0D0 ) -* .. -* .. Local Arrays .. - INTEGER CTOT( 4 ), PSM( 4 ) -* .. -* .. Local Scalars .. - INTEGER CT, I, IMAX, IQ1, IQ2, J, JMAX, JS, K2, N1P1, - $ N2, NJ, PJ - DOUBLE PRECISION C, EPS, S, T, TAU, TOL -* .. -* .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH, DLAPY2 - EXTERNAL IDAMAX, DLAMCH, DLAPY2 -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DLACPY, DLAMRG, DROT, DSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( MIN( 1, ( N / 2 ) ).GT.N1 .OR. ( N / 2 ).LT.N1 ) THEN - INFO = -3 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLAED2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - N2 = N - N1 - N1P1 = N1 + 1 -* - IF( RHO.LT.ZERO ) THEN - CALL DSCAL( N2, MONE, Z( N1P1 ), 1 ) - END IF -* -* Normalize z so that norm(z) = 1. Since z is the concatenation of -* two normalized vectors, norm2(z) = sqrt(2). -* - T = ONE / SQRT( TWO ) - CALL DSCAL( N, T, Z, 1 ) -* -* RHO = ABS( norm(z)**2 * RHO ) -* - RHO = ABS( TWO*RHO ) -* -* Sort the eigenvalues into increasing order -* - DO 10 I = N1P1, N - INDXQ( I ) = INDXQ( I ) + N1 - 10 CONTINUE -* -* re-integrate the deflated parts from the last pass -* - DO 20 I = 1, N - DLAMDA( I ) = D( INDXQ( I ) ) - 20 CONTINUE - CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDXC ) - DO 30 I = 1, N - INDX( I ) = INDXQ( INDXC( I ) ) - 30 CONTINUE -* -* Calculate the allowable deflation tolerance -* - IMAX = IDAMAX( N, Z, 1 ) - JMAX = IDAMAX( N, D, 1 ) - EPS = DLAMCH( 'Epsilon' ) - TOL = EIGHT*EPS*MAX( ABS( D( JMAX ) ), ABS( Z( IMAX ) ) ) -* -* If the rank-1 modifier is small enough, no more needs to be done -* except to reorganize Q so that its columns correspond with the -* elements in D. -* - IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN - K = 0 - IQ2 = 1 - DO 40 J = 1, N - I = INDX( J ) - CALL DCOPY( N, Q( 1, I ), 1, Q2( IQ2 ), 1 ) - DLAMDA( J ) = D( I ) - IQ2 = IQ2 + N - 40 CONTINUE - CALL DLACPY( 'A', N, N, Q2, N, Q, LDQ ) - CALL DCOPY( N, DLAMDA, 1, D, 1 ) - GO TO 190 - END IF -* -* If there are multiple eigenvalues then the problem deflates. Here -* the number of equal eigenvalues are found. As each equal -* eigenvalue is found, an elementary reflector is computed to rotate -* the corresponding eigensubspace so that the corresponding -* components of Z are zero in this new basis. -* - DO 50 I = 1, N1 - COLTYP( I ) = 1 - 50 CONTINUE - DO 60 I = N1P1, N - COLTYP( I ) = 3 - 60 CONTINUE -* -* - K = 0 - K2 = N + 1 - DO 70 J = 1, N - NJ = INDX( J ) - IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN -* -* Deflate due to small z component. -* - K2 = K2 - 1 - COLTYP( NJ ) = 4 - INDXP( K2 ) = NJ - IF( J.EQ.N ) - $ GO TO 100 - ELSE - PJ = NJ - GO TO 80 - END IF - 70 CONTINUE - 80 CONTINUE - J = J + 1 - NJ = INDX( J ) - IF( J.GT.N ) - $ GO TO 100 - IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN -* -* Deflate due to small z component. -* - K2 = K2 - 1 - COLTYP( NJ ) = 4 - INDXP( K2 ) = NJ - ELSE -* -* Check if eigenvalues are close enough to allow deflation. -* - S = Z( PJ ) - C = Z( NJ ) -* -* Find sqrt(a**2+b**2) without overflow or -* destructive underflow. -* - TAU = DLAPY2( C, S ) - T = D( NJ ) - D( PJ ) - C = C / TAU - S = -S / TAU - IF( ABS( T*C*S ).LE.TOL ) THEN -* -* Deflation is possible. -* - Z( NJ ) = TAU - Z( PJ ) = ZERO - IF( COLTYP( NJ ).NE.COLTYP( PJ ) ) - $ COLTYP( NJ ) = 2 - COLTYP( PJ ) = 4 - CALL DROT( N, Q( 1, PJ ), 1, Q( 1, NJ ), 1, C, S ) - T = D( PJ )*C**2 + D( NJ )*S**2 - D( NJ ) = D( PJ )*S**2 + D( NJ )*C**2 - D( PJ ) = T - K2 = K2 - 1 - I = 1 - 90 CONTINUE - IF( K2+I.LE.N ) THEN - IF( D( PJ ).LT.D( INDXP( K2+I ) ) ) THEN - INDXP( K2+I-1 ) = INDXP( K2+I ) - INDXP( K2+I ) = PJ - I = I + 1 - GO TO 90 - ELSE - INDXP( K2+I-1 ) = PJ - END IF - ELSE - INDXP( K2+I-1 ) = PJ - END IF - PJ = NJ - ELSE - K = K + 1 - DLAMDA( K ) = D( PJ ) - W( K ) = Z( PJ ) - INDXP( K ) = PJ - PJ = NJ - END IF - END IF - GO TO 80 - 100 CONTINUE -* -* Record the last eigenvalue. -* - K = K + 1 - DLAMDA( K ) = D( PJ ) - W( K ) = Z( PJ ) - INDXP( K ) = PJ -* -* Count up the total number of the various types of columns, then -* form a permutation which positions the four column types into -* four uniform groups (although one or more of these groups may be -* empty). -* - DO 110 J = 1, 4 - CTOT( J ) = 0 - 110 CONTINUE - DO 120 J = 1, N - CT = COLTYP( J ) - CTOT( CT ) = CTOT( CT ) + 1 - 120 CONTINUE -* -* PSM(*) = Position in SubMatrix (of types 1 through 4) -* - PSM( 1 ) = 1 - PSM( 2 ) = 1 + CTOT( 1 ) - PSM( 3 ) = PSM( 2 ) + CTOT( 2 ) - PSM( 4 ) = PSM( 3 ) + CTOT( 3 ) - K = N - CTOT( 4 ) -* -* Fill out the INDXC array so that the permutation which it induces -* will place all type-1 columns first, all type-2 columns next, -* then all type-3's, and finally all type-4's. -* - DO 130 J = 1, N - JS = INDXP( J ) - CT = COLTYP( JS ) - INDX( PSM( CT ) ) = JS - INDXC( PSM( CT ) ) = J - PSM( CT ) = PSM( CT ) + 1 - 130 CONTINUE -* -* Sort the eigenvalues and corresponding eigenvectors into DLAMDA -* and Q2 respectively. The eigenvalues/vectors which were not -* deflated go into the first K slots of DLAMDA and Q2 respectively, -* while those which were deflated go into the last N - K slots. -* - I = 1 - IQ1 = 1 - IQ2 = 1 + ( CTOT( 1 )+CTOT( 2 ) )*N1 - DO 140 J = 1, CTOT( 1 ) - JS = INDX( I ) - CALL DCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 ) - Z( I ) = D( JS ) - I = I + 1 - IQ1 = IQ1 + N1 - 140 CONTINUE -* - DO 150 J = 1, CTOT( 2 ) - JS = INDX( I ) - CALL DCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 ) - CALL DCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 ) - Z( I ) = D( JS ) - I = I + 1 - IQ1 = IQ1 + N1 - IQ2 = IQ2 + N2 - 150 CONTINUE -* - DO 160 J = 1, CTOT( 3 ) - JS = INDX( I ) - CALL DCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 ) - Z( I ) = D( JS ) - I = I + 1 - IQ2 = IQ2 + N2 - 160 CONTINUE -* - IQ1 = IQ2 - DO 170 J = 1, CTOT( 4 ) - JS = INDX( I ) - CALL DCOPY( N, Q( 1, JS ), 1, Q2( IQ2 ), 1 ) - IQ2 = IQ2 + N - Z( I ) = D( JS ) - I = I + 1 - 170 CONTINUE -* -* The deflated eigenvalues and their corresponding vectors go back -* into the last N - K slots of D and Q respectively. -* - IF( K.LT.N ) THEN - CALL DLACPY( 'A', N, CTOT( 4 ), Q2( IQ1 ), N, - $ Q( 1, K+1 ), LDQ ) - CALL DCOPY( N-K, Z( K+1 ), 1, D( K+1 ), 1 ) - END IF -* -* Copy CTOT into COLTYP for referencing in DLAED3. -* - DO 180 J = 1, 4 - COLTYP( J ) = CTOT( J ) - 180 CONTINUE -* - 190 CONTINUE - RETURN -* -* End of DLAED2 -* - END diff --git a/lib/linalg/dlaed3.cpp b/lib/linalg/dlaed3.cpp new file mode 100644 index 0000000000..926b0ecd7a --- /dev/null +++ b/lib/linalg/dlaed3.cpp @@ -0,0 +1,138 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +static doublereal c_b22 = 1.; +static doublereal c_b23 = 0.; +int dlaed3_(integer *k, integer *n, integer *n1, doublereal *d__, doublereal *q, integer *ldq, + doublereal *rho, doublereal *dlamda, doublereal *q2, integer *indx, integer *ctot, + doublereal *w, doublereal *s, integer *info) +{ + integer q_dim1, q_offset, i__1, i__2; + doublereal d__1; + double sqrt(doublereal), d_lmp_sign(doublereal *, doublereal *); + integer i__, j, n2, n12, ii, n23, iq2; + 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), + dcopy_(integer *, doublereal *, integer *, doublereal *, integer *), + dlaed4_(integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *); + extern doublereal dlamc3_(doublereal *, doublereal *); + extern int dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, + integer *, ftnlen), + dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, + ftnlen), + xerbla_(char *, integer *, ftnlen); + --d__; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + --dlamda; + --q2; + --indx; + --ctot; + --w; + --s; + *info = 0; + if (*k < 0) { + *info = -1; + } else if (*n < *k) { + *info = -2; + } else if (*ldq < max(1, *n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DLAED3", &i__1, (ftnlen)6); + return 0; + } + if (*k == 0) { + return 0; + } + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + dlamda[i__] = dlamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__]; + } + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dlaed4_(k, &j, &dlamda[1], &w[1], &q[j * q_dim1 + 1], rho, &d__[j], info); + if (*info != 0) { + goto L120; + } + } + if (*k == 1) { + goto L110; + } + if (*k == 2) { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + w[1] = q[j * q_dim1 + 1]; + w[2] = q[j * q_dim1 + 2]; + ii = indx[1]; + q[j * q_dim1 + 1] = w[ii]; + ii = indx[2]; + q[j * q_dim1 + 2] = w[ii]; + } + goto L110; + } + dcopy_(k, &w[1], &c__1, &s[1], &c__1); + i__1 = *ldq + 1; + dcopy_(k, &q[q_offset], &i__1, &w[1], &c__1); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]); + } + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]); + } + } + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + d__1 = sqrt(-w[i__]); + w[i__] = d_lmp_sign(&d__1, &s[i__]); + } + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + s[i__] = w[i__] / q[i__ + j * q_dim1]; + } + temp = dnrm2_(k, &s[1], &c__1); + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + ii = indx[i__]; + q[i__ + j * q_dim1] = s[ii] / temp; + } + } +L110: + n2 = *n - *n1; + n12 = ctot[1] + ctot[2]; + n23 = ctot[2] + ctot[3]; + dlacpy_((char *)"A", &n23, k, &q[ctot[1] + 1 + q_dim1], ldq, &s[1], &n23, (ftnlen)1); + iq2 = *n1 * n12 + 1; + if (n23 != 0) { + dgemm_((char *)"N", (char *)"N", &n2, k, &n23, &c_b22, &q2[iq2], &n2, &s[1], &n23, &c_b23, + &q[*n1 + 1 + q_dim1], ldq, (ftnlen)1, (ftnlen)1); + } else { + dlaset_((char *)"A", &n2, k, &c_b23, &c_b23, &q[*n1 + 1 + q_dim1], ldq, (ftnlen)1); + } + dlacpy_((char *)"A", &n12, k, &q[q_offset], ldq, &s[1], &n12, (ftnlen)1); + if (n12 != 0) { + dgemm_((char *)"N", (char *)"N", n1, k, &n12, &c_b22, &q2[1], n1, &s[1], &n12, &c_b23, &q[q_offset], ldq, + (ftnlen)1, (ftnlen)1); + } else { + dlaset_((char *)"A", n1, k, &c_b23, &c_b23, &q[q_dim1 + 1], ldq, (ftnlen)1); + } +L120: + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlaed3.f b/lib/linalg/dlaed3.f deleted file mode 100644 index c58944e604..0000000000 --- a/lib/linalg/dlaed3.f +++ /dev/null @@ -1,350 +0,0 @@ -*> \brief \b DLAED3 used by DSTEDC. Finds the roots of the secular equation and updates the eigenvectors. Used when the original matrix is tridiagonal. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAED3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX, -* CTOT, W, S, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, K, LDQ, N, N1 -* DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. -* INTEGER CTOT( * ), INDX( * ) -* DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ), -* $ S( * ), W( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAED3 finds the roots of the secular equation, as defined by the -*> values in D, W, and RHO, between 1 and K. It makes the -*> appropriate calls to DLAED4 and then updates the eigenvectors by -*> multiplying the matrix of eigenvectors of the pair of eigensystems -*> being combined by the matrix of eigenvectors of the K-by-K system -*> which is solved here. -*> -*> This code makes very mild assumptions about floating point -*> arithmetic. It will work on machines with a guard digit in -*> add/subtract, or on those binary machines without guard digits -*> which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. -*> It could conceivably fail on hexadecimal or decimal machines -*> without guard digits, but we know of none. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of terms in the rational function to be solved by -*> DLAED4. K >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of rows and columns in the Q matrix. -*> N >= K (deflation may result in N>K). -*> \endverbatim -*> -*> \param[in] N1 -*> \verbatim -*> N1 is INTEGER -*> The location of the last eigenvalue in the leading submatrix. -*> min(1,N) <= N1 <= N/2. -*> \endverbatim -*> -*> \param[out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> D(I) contains the updated eigenvalues for -*> 1 <= I <= K. -*> \endverbatim -*> -*> \param[out] Q -*> \verbatim -*> Q is DOUBLE PRECISION array, dimension (LDQ,N) -*> Initially the first K columns are used as workspace. -*> On output the columns 1 to K contain -*> the updated eigenvectors. -*> \endverbatim -*> -*> \param[in] LDQ -*> \verbatim -*> LDQ is INTEGER -*> The leading dimension of the array Q. LDQ >= max(1,N). -*> \endverbatim -*> -*> \param[in] RHO -*> \verbatim -*> RHO is DOUBLE PRECISION -*> The value of the parameter in the rank one update equation. -*> RHO >= 0 required. -*> \endverbatim -*> -*> \param[in,out] DLAMDA -*> \verbatim -*> DLAMDA is DOUBLE PRECISION array, dimension (K) -*> The first K elements of this array contain the old roots -*> of the deflated updating problem. These are the poles -*> of the secular equation. May be changed on output by -*> having lowest order bit set to zero on Cray X-MP, Cray Y-MP, -*> Cray-2, or Cray C-90, as described above. -*> \endverbatim -*> -*> \param[in] Q2 -*> \verbatim -*> Q2 is DOUBLE PRECISION array, dimension (LDQ2*N) -*> The first K columns of this matrix contain the non-deflated -*> eigenvectors for the split problem. -*> \endverbatim -*> -*> \param[in] INDX -*> \verbatim -*> INDX is INTEGER array, dimension (N) -*> The permutation used to arrange the columns of the deflated -*> Q matrix into three groups (see DLAED2). -*> The rows of the eigenvectors found by DLAED4 must be likewise -*> permuted before the matrix multiply can take place. -*> \endverbatim -*> -*> \param[in] CTOT -*> \verbatim -*> CTOT is INTEGER array, dimension (4) -*> A count of the total number of the various types of columns -*> in Q, as described in INDX. The fourth column type is any -*> column which has been deflated. -*> \endverbatim -*> -*> \param[in,out] W -*> \verbatim -*> W is DOUBLE PRECISION array, dimension (K) -*> The first K elements of this array contain the components -*> of the deflation-adjusted updating vector. Destroyed on -*> output. -*> \endverbatim -*> -*> \param[out] S -*> \verbatim -*> S is DOUBLE PRECISION array, dimension (N1 + 1)*K -*> Will contain the eigenvectors of the repaired matrix which -*> will be multiplied by the previously accumulated eigenvectors -*> to update the system. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit. -*> < 0: if INFO = -i, the i-th argument had an illegal value. -*> > 0: if INFO = 1, an eigenvalue did not converge -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -*> \par Contributors: -* ================== -*> -*> Jeff Rutter, Computer Science Division, University of California -*> at Berkeley, USA \n -*> Modified by Francoise Tisseur, University of Tennessee -*> -* ===================================================================== - SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX, - $ CTOT, W, S, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDQ, N, N1 - DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. - INTEGER CTOT( * ), INDX( * ) - DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ), - $ S( * ), W( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -* .. -* .. Local Scalars .. - INTEGER I, II, IQ2, J, N12, N2, N23 - DOUBLE PRECISION TEMP -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMC3, DNRM2 - EXTERNAL DLAMC3, DNRM2 -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DLACPY, DLAED4, DLASET, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, SIGN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( K.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.K ) THEN - INFO = -2 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLAED3', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( K.EQ.0 ) - $ RETURN -* -* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can -* be computed with high relative accuracy (barring over/underflow). -* This is a problem on machines without a guard digit in -* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). -* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), -* which on any of these machines zeros out the bottommost -* bit of DLAMDA(I) if it is 1; this makes the subsequent -* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation -* occurs. On binary machines with a guard digit (almost all -* machines) it does not change DLAMDA(I) at all. On hexadecimal -* and decimal machines with a guard digit, it slightly -* changes the bottommost bits of DLAMDA(I). It does not account -* for hexadecimal or decimal machines without guard digits -* (we know of none). We use a subroutine call to compute -* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating -* this code. -* - DO 10 I = 1, K - DLAMDA( I ) = DLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I ) - 10 CONTINUE -* - DO 20 J = 1, K - CALL DLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO ) -* -* If the zero finder fails, the computation is terminated. -* - IF( INFO.NE.0 ) - $ GO TO 120 - 20 CONTINUE -* - IF( K.EQ.1 ) - $ GO TO 110 - IF( K.EQ.2 ) THEN - DO 30 J = 1, K - W( 1 ) = Q( 1, J ) - W( 2 ) = Q( 2, J ) - II = INDX( 1 ) - Q( 1, J ) = W( II ) - II = INDX( 2 ) - Q( 2, J ) = W( II ) - 30 CONTINUE - GO TO 110 - END IF -* -* Compute updated W. -* - CALL DCOPY( K, W, 1, S, 1 ) -* -* Initialize W(I) = Q(I,I) -* - CALL DCOPY( K, Q, LDQ+1, W, 1 ) - DO 60 J = 1, K - DO 40 I = 1, J - 1 - W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) ) - 40 CONTINUE - DO 50 I = J + 1, K - W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) ) - 50 CONTINUE - 60 CONTINUE - DO 70 I = 1, K - W( I ) = SIGN( SQRT( -W( I ) ), S( I ) ) - 70 CONTINUE -* -* Compute eigenvectors of the modified rank-1 modification. -* - DO 100 J = 1, K - DO 80 I = 1, K - S( I ) = W( I ) / Q( I, J ) - 80 CONTINUE - TEMP = DNRM2( K, S, 1 ) - DO 90 I = 1, K - II = INDX( I ) - Q( I, J ) = S( II ) / TEMP - 90 CONTINUE - 100 CONTINUE -* -* Compute the updated eigenvectors. -* - 110 CONTINUE -* - N2 = N - N1 - N12 = CTOT( 1 ) + CTOT( 2 ) - N23 = CTOT( 2 ) + CTOT( 3 ) -* - CALL DLACPY( 'A', N23, K, Q( CTOT( 1 )+1, 1 ), LDQ, S, N23 ) - IQ2 = N1*N12 + 1 - IF( N23.NE.0 ) THEN - CALL DGEMM( 'N', 'N', N2, K, N23, ONE, Q2( IQ2 ), N2, S, N23, - $ ZERO, Q( N1+1, 1 ), LDQ ) - ELSE - CALL DLASET( 'A', N2, K, ZERO, ZERO, Q( N1+1, 1 ), LDQ ) - END IF -* - CALL DLACPY( 'A', N12, K, Q, LDQ, S, N12 ) - IF( N12.NE.0 ) THEN - CALL DGEMM( 'N', 'N', N1, K, N12, ONE, Q2, N1, S, N12, ZERO, Q, - $ LDQ ) - ELSE - CALL DLASET( 'A', N1, K, ZERO, ZERO, Q( 1, 1 ), LDQ ) - END IF -* -* - 120 CONTINUE - RETURN -* -* End of DLAED3 -* - END diff --git a/lib/linalg/dlaed4.cpp b/lib/linalg/dlaed4.cpp new file mode 100644 index 0000000000..9bc4f35caf --- /dev/null +++ b/lib/linalg/dlaed4.cpp @@ -0,0 +1,571 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dlaed4_(integer *n, integer *i__, doublereal *d__, doublereal *z__, doublereal *delta, + doublereal *rho, doublereal *dlam, integer *info) +{ + integer i__1; + doublereal d__1; + double sqrt(doublereal); + doublereal a, b, c__; + integer j; + doublereal w; + integer ii; + doublereal dw, zz[3]; + integer ip1; + doublereal del, eta, phi, eps, tau, psi; + integer iim1, iip1; + doublereal dphi, dpsi; + integer iter; + doublereal temp, prew, temp1, dltlb, dltub, midpt; + integer niter; + logical swtch; + extern int dlaed5_(integer *, doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *), + dlaed6_(integer *, logical *, doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *); + logical swtch3; + extern doublereal dlamch_(char *, ftnlen); + logical orgati; + doublereal erretm, rhoinv; + --delta; + --z__; + --d__; + *info = 0; + if (*n == 1) { + *dlam = d__[1] + *rho * z__[1] * z__[1]; + delta[1] = 1.; + return 0; + } + if (*n == 2) { + dlaed5_(i__, &d__[1], &z__[1], &delta[1], rho, dlam); + return 0; + } + eps = dlamch_((char *)"Epsilon", (ftnlen)7); + rhoinv = 1. / *rho; + if (*i__ == *n) { + ii = *n - 1; + niter = 1; + midpt = *rho / 2.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] = d__[j] - d__[*i__] - midpt; + } + psi = 0.; + i__1 = *n - 2; + for (j = 1; j <= i__1; ++j) { + psi += z__[j] * z__[j] / delta[j]; + } + c__ = rhoinv + psi; + w = c__ + z__[ii] * z__[ii] / delta[ii] + z__[*n] * z__[*n] / delta[*n]; + if (w <= 0.) { + temp = z__[*n - 1] * z__[*n - 1] / (d__[*n] - d__[*n - 1] + *rho) + + z__[*n] * z__[*n] / *rho; + if (c__ <= temp) { + tau = *rho; + } else { + del = d__[*n] - d__[*n - 1]; + a = -c__ * del + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n]; + b = z__[*n] * z__[*n] * del; + if (a < 0.) { + tau = b * 2. / (sqrt(a * a + b * 4. * c__) - a); + } else { + tau = (a + sqrt(a * a + b * 4. * c__)) / (c__ * 2.); + } + } + dltlb = midpt; + dltub = *rho; + } else { + del = d__[*n] - d__[*n - 1]; + a = -c__ * del + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n]; + b = z__[*n] * z__[*n] * del; + if (a < 0.) { + tau = b * 2. / (sqrt(a * a + b * 4. * c__) - a); + } else { + tau = (a + sqrt(a * a + b * 4. * c__)) / (c__ * 2.); + } + dltlb = 0.; + dltub = midpt; + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] = d__[j] - d__[*i__] - tau; + } + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = ii; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / delta[j]; + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; + } + erretm = abs(erretm); + temp = z__[*n] / delta[*n]; + phi = z__[*n] * temp; + dphi = temp * temp; + erretm = (-phi - psi) * 8. + erretm - phi + rhoinv + abs(tau) * (dpsi + dphi); + w = rhoinv + phi + psi; + if (abs(w) <= eps * erretm) { + *dlam = d__[*i__] + tau; + goto L250; + } + if (w <= 0.) { + dltlb = max(dltlb, tau); + } else { + dltub = min(dltub, tau); + } + ++niter; + c__ = w - delta[*n - 1] * dpsi - delta[*n] * dphi; + a = (delta[*n - 1] + delta[*n]) * w - delta[*n - 1] * delta[*n] * (dpsi + dphi); + b = delta[*n - 1] * delta[*n] * w; + if (c__ < 0.) { + c__ = abs(c__); + } + if (c__ == 0.) { + eta = -w / (dpsi + dphi); + } else if (a >= 0.) { + eta = (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ * 2.); + } else { + eta = b * 2. / (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))); + } + if (w * eta > 0.) { + eta = -w / (dpsi + dphi); + } + temp = tau + eta; + if (temp > dltub || temp < dltlb) { + if (w < 0.) { + eta = (dltub - tau) / 2.; + } else { + eta = (dltlb - tau) / 2.; + } + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] -= eta; + } + tau += eta; + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = ii; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / delta[j]; + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; + } + erretm = abs(erretm); + temp = z__[*n] / delta[*n]; + phi = z__[*n] * temp; + dphi = temp * temp; + erretm = (-phi - psi) * 8. + erretm - phi + rhoinv + abs(tau) * (dpsi + dphi); + w = rhoinv + phi + psi; + iter = niter + 1; + for (niter = iter; niter <= 30; ++niter) { + if (abs(w) <= eps * erretm) { + *dlam = d__[*i__] + tau; + goto L250; + } + if (w <= 0.) { + dltlb = max(dltlb, tau); + } else { + dltub = min(dltub, tau); + } + c__ = w - delta[*n - 1] * dpsi - delta[*n] * dphi; + a = (delta[*n - 1] + delta[*n]) * w - delta[*n - 1] * delta[*n] * (dpsi + dphi); + b = delta[*n - 1] * delta[*n] * w; + if (a >= 0.) { + eta = (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ * 2.); + } else { + eta = b * 2. / (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))); + } + if (w * eta > 0.) { + eta = -w / (dpsi + dphi); + } + temp = tau + eta; + if (temp > dltub || temp < dltlb) { + if (w < 0.) { + eta = (dltub - tau) / 2.; + } else { + eta = (dltlb - tau) / 2.; + } + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] -= eta; + } + tau += eta; + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = ii; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / delta[j]; + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; + } + erretm = abs(erretm); + temp = z__[*n] / delta[*n]; + phi = z__[*n] * temp; + dphi = temp * temp; + erretm = (-phi - psi) * 8. + erretm - phi + rhoinv + abs(tau) * (dpsi + dphi); + w = rhoinv + phi + psi; + } + *info = 1; + *dlam = d__[*i__] + tau; + goto L250; + } else { + niter = 1; + ip1 = *i__ + 1; + del = d__[ip1] - d__[*i__]; + midpt = del / 2.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] = d__[j] - d__[*i__] - midpt; + } + psi = 0.; + i__1 = *i__ - 1; + for (j = 1; j <= i__1; ++j) { + psi += z__[j] * z__[j] / delta[j]; + } + phi = 0.; + i__1 = *i__ + 2; + for (j = *n; j >= i__1; --j) { + phi += z__[j] * z__[j] / delta[j]; + } + c__ = rhoinv + psi + phi; + w = c__ + z__[*i__] * z__[*i__] / delta[*i__] + z__[ip1] * z__[ip1] / delta[ip1]; + if (w > 0.) { + orgati = TRUE_; + a = c__ * del + z__[*i__] * z__[*i__] + z__[ip1] * z__[ip1]; + b = z__[*i__] * z__[*i__] * del; + if (a > 0.) { + tau = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))); + } else { + tau = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ * 2.); + } + dltlb = 0.; + dltub = midpt; + } else { + orgati = FALSE_; + a = c__ * del - z__[*i__] * z__[*i__] - z__[ip1] * z__[ip1]; + b = z__[ip1] * z__[ip1] * del; + if (a < 0.) { + tau = b * 2. / (a - sqrt((d__1 = a * a + b * 4. * c__, abs(d__1)))); + } else { + tau = -(a + sqrt((d__1 = a * a + b * 4. * c__, abs(d__1)))) / (c__ * 2.); + } + dltlb = -midpt; + dltub = 0.; + } + if (orgati) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] = d__[j] - d__[*i__] - tau; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] = d__[j] - d__[ip1] - tau; + } + } + if (orgati) { + ii = *i__; + } else { + ii = *i__ + 1; + } + iim1 = ii - 1; + iip1 = ii + 1; + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = iim1; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / delta[j]; + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; + } + erretm = abs(erretm); + dphi = 0.; + phi = 0.; + i__1 = iip1; + for (j = *n; j >= i__1; --j) { + temp = z__[j] / delta[j]; + phi += z__[j] * temp; + dphi += temp * temp; + erretm += phi; + } + w = rhoinv + phi + psi; + swtch3 = FALSE_; + if (orgati) { + if (w < 0.) { + swtch3 = TRUE_; + } + } else { + if (w > 0.) { + swtch3 = TRUE_; + } + } + if (ii == 1 || ii == *n) { + swtch3 = FALSE_; + } + temp = z__[ii] / delta[ii]; + dw = dpsi + dphi + temp * temp; + temp = z__[ii] * temp; + w += temp; + erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3. + abs(tau) * dw; + if (abs(w) <= eps * erretm) { + if (orgati) { + *dlam = d__[*i__] + tau; + } else { + *dlam = d__[ip1] + tau; + } + goto L250; + } + if (w <= 0.) { + dltlb = max(dltlb, tau); + } else { + dltub = min(dltub, tau); + } + ++niter; + if (!swtch3) { + if (orgati) { + d__1 = z__[*i__] / delta[*i__]; + c__ = w - delta[ip1] * dw - (d__[*i__] - d__[ip1]) * (d__1 * d__1); + } else { + d__1 = z__[ip1] / delta[ip1]; + c__ = w - delta[*i__] * dw - (d__[ip1] - d__[*i__]) * (d__1 * d__1); + } + a = (delta[*i__] + delta[ip1]) * w - delta[*i__] * delta[ip1] * dw; + b = delta[*i__] * delta[ip1] * w; + if (c__ == 0.) { + if (a == 0.) { + if (orgati) { + a = z__[*i__] * z__[*i__] + delta[ip1] * delta[ip1] * (dpsi + dphi); + } else { + a = z__[ip1] * z__[ip1] + delta[*i__] * delta[*i__] * (dpsi + dphi); + } + } + eta = b / a; + } else if (a <= 0.) { + eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ * 2.); + } else { + eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))); + } + } else { + temp = rhoinv + psi + phi; + if (orgati) { + temp1 = z__[iim1] / delta[iim1]; + temp1 *= temp1; + c__ = temp - delta[iip1] * (dpsi + dphi) - (d__[iim1] - d__[iip1]) * temp1; + zz[0] = z__[iim1] * z__[iim1]; + zz[2] = delta[iip1] * delta[iip1] * (dpsi - temp1 + dphi); + } else { + temp1 = z__[iip1] / delta[iip1]; + temp1 *= temp1; + c__ = temp - delta[iim1] * (dpsi + dphi) - (d__[iip1] - d__[iim1]) * temp1; + zz[0] = delta[iim1] * delta[iim1] * (dpsi + (dphi - temp1)); + zz[2] = z__[iip1] * z__[iip1]; + } + zz[1] = z__[ii] * z__[ii]; + dlaed6_(&niter, &orgati, &c__, &delta[iim1], zz, &w, &eta, info); + if (*info != 0) { + goto L250; + } + } + if (w * eta >= 0.) { + eta = -w / dw; + } + temp = tau + eta; + if (temp > dltub || temp < dltlb) { + if (w < 0.) { + eta = (dltub - tau) / 2.; + } else { + eta = (dltlb - tau) / 2.; + } + } + prew = w; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] -= eta; + } + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = iim1; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / delta[j]; + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; + } + erretm = abs(erretm); + dphi = 0.; + phi = 0.; + i__1 = iip1; + for (j = *n; j >= i__1; --j) { + temp = z__[j] / delta[j]; + phi += z__[j] * temp; + dphi += temp * temp; + erretm += phi; + } + temp = z__[ii] / delta[ii]; + dw = dpsi + dphi + temp * temp; + temp = z__[ii] * temp; + w = rhoinv + phi + psi + temp; + erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3. + + (d__1 = tau + eta, abs(d__1)) * dw; + swtch = FALSE_; + if (orgati) { + if (-w > abs(prew) / 10.) { + swtch = TRUE_; + } + } else { + if (w > abs(prew) / 10.) { + swtch = TRUE_; + } + } + tau += eta; + iter = niter + 1; + for (niter = iter; niter <= 30; ++niter) { + if (abs(w) <= eps * erretm) { + if (orgati) { + *dlam = d__[*i__] + tau; + } else { + *dlam = d__[ip1] + tau; + } + goto L250; + } + if (w <= 0.) { + dltlb = max(dltlb, tau); + } else { + dltub = min(dltub, tau); + } + if (!swtch3) { + if (!swtch) { + if (orgati) { + d__1 = z__[*i__] / delta[*i__]; + c__ = w - delta[ip1] * dw - (d__[*i__] - d__[ip1]) * (d__1 * d__1); + } else { + d__1 = z__[ip1] / delta[ip1]; + c__ = w - delta[*i__] * dw - (d__[ip1] - d__[*i__]) * (d__1 * d__1); + } + } else { + temp = z__[ii] / delta[ii]; + if (orgati) { + dpsi += temp * temp; + } else { + dphi += temp * temp; + } + c__ = w - delta[*i__] * dpsi - delta[ip1] * dphi; + } + a = (delta[*i__] + delta[ip1]) * w - delta[*i__] * delta[ip1] * dw; + b = delta[*i__] * delta[ip1] * w; + if (c__ == 0.) { + if (a == 0.) { + if (!swtch) { + if (orgati) { + a = z__[*i__] * z__[*i__] + delta[ip1] * delta[ip1] * (dpsi + dphi); + } else { + a = z__[ip1] * z__[ip1] + delta[*i__] * delta[*i__] * (dpsi + dphi); + } + } else { + a = delta[*i__] * delta[*i__] * dpsi + delta[ip1] * delta[ip1] * dphi; + } + } + eta = b / a; + } else if (a <= 0.) { + eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ * 2.); + } else { + eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))); + } + } else { + temp = rhoinv + psi + phi; + if (swtch) { + c__ = temp - delta[iim1] * dpsi - delta[iip1] * dphi; + zz[0] = delta[iim1] * delta[iim1] * dpsi; + zz[2] = delta[iip1] * delta[iip1] * dphi; + } else { + if (orgati) { + temp1 = z__[iim1] / delta[iim1]; + temp1 *= temp1; + c__ = temp - delta[iip1] * (dpsi + dphi) - (d__[iim1] - d__[iip1]) * temp1; + zz[0] = z__[iim1] * z__[iim1]; + zz[2] = delta[iip1] * delta[iip1] * (dpsi - temp1 + dphi); + } else { + temp1 = z__[iip1] / delta[iip1]; + temp1 *= temp1; + c__ = temp - delta[iim1] * (dpsi + dphi) - (d__[iip1] - d__[iim1]) * temp1; + zz[0] = delta[iim1] * delta[iim1] * (dpsi + (dphi - temp1)); + zz[2] = z__[iip1] * z__[iip1]; + } + } + dlaed6_(&niter, &orgati, &c__, &delta[iim1], zz, &w, &eta, info); + if (*info != 0) { + goto L250; + } + } + if (w * eta >= 0.) { + eta = -w / dw; + } + temp = tau + eta; + if (temp > dltub || temp < dltlb) { + if (w < 0.) { + eta = (dltub - tau) / 2.; + } else { + eta = (dltlb - tau) / 2.; + } + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] -= eta; + } + tau += eta; + prew = w; + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = iim1; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / delta[j]; + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; + } + erretm = abs(erretm); + dphi = 0.; + phi = 0.; + i__1 = iip1; + for (j = *n; j >= i__1; --j) { + temp = z__[j] / delta[j]; + phi += z__[j] * temp; + dphi += temp * temp; + erretm += phi; + } + temp = z__[ii] / delta[ii]; + dw = dpsi + dphi + temp * temp; + temp = z__[ii] * temp; + w = rhoinv + phi + psi + temp; + erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3. + abs(tau) * dw; + if (w * prew > 0. && abs(w) > abs(prew) / 10.) { + swtch = !swtch; + } + } + *info = 1; + if (orgati) { + *dlam = d__[*i__] + tau; + } else { + *dlam = d__[ip1] + tau; + } + } +L250: + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlaed4.f b/lib/linalg/dlaed4.f deleted file mode 100644 index b51e23d850..0000000000 --- a/lib/linalg/dlaed4.f +++ /dev/null @@ -1,917 +0,0 @@ -*> \brief \b DLAED4 used by DSTEDC. Finds a single root of the secular equation. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAED4 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO ) -* -* .. Scalar Arguments .. -* INTEGER I, INFO, N -* DOUBLE PRECISION DLAM, RHO -* .. -* .. Array Arguments .. -* DOUBLE PRECISION D( * ), DELTA( * ), Z( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> This subroutine computes the I-th updated eigenvalue of a symmetric -*> rank-one modification to a diagonal matrix whose elements are -*> given in the array d, and that -*> -*> D(i) < D(j) for i < j -*> -*> and that RHO > 0. This is arranged by the calling routine, and is -*> no loss in generality. The rank-one modified system is thus -*> -*> diag( D ) + RHO * Z * Z_transpose. -*> -*> where we assume the Euclidean norm of Z is 1. -*> -*> The method consists of approximating the rational functions in the -*> secular equation by simpler interpolating rational functions. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The length of all arrays. -*> \endverbatim -*> -*> \param[in] I -*> \verbatim -*> I is INTEGER -*> The index of the eigenvalue to be computed. 1 <= I <= N. -*> \endverbatim -*> -*> \param[in] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> The original eigenvalues. It is assumed that they are in -*> order, D(I) < D(J) for I < J. -*> \endverbatim -*> -*> \param[in] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension (N) -*> The components of the updating vector. -*> \endverbatim -*> -*> \param[out] DELTA -*> \verbatim -*> DELTA is DOUBLE PRECISION array, dimension (N) -*> If N > 2, DELTA contains (D(j) - lambda_I) in its j-th -*> component. If N = 1, then DELTA(1) = 1. If N = 2, see DLAED5 -*> for detail. The vector DELTA contains the information necessary -*> to construct the eigenvectors by DLAED3 and DLAED9. -*> \endverbatim -*> -*> \param[in] RHO -*> \verbatim -*> RHO is DOUBLE PRECISION -*> The scalar in the symmetric updating formula. -*> \endverbatim -*> -*> \param[out] DLAM -*> \verbatim -*> DLAM is DOUBLE PRECISION -*> The computed lambda_I, the I-th updated eigenvalue. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> > 0: if INFO = 1, the updating process failed. -*> \endverbatim -* -*> \par Internal Parameters: -* ========================= -*> -*> \verbatim -*> Logical variable ORGATI (origin-at-i?) is used for distinguishing -*> whether D(i) or D(i+1) is treated as the origin. -*> -*> ORGATI = .true. origin at i -*> ORGATI = .false. origin at i+1 -*> -*> Logical variable SWTCH3 (switch-for-3-poles?) is for noting -*> if we are working with THREE poles! -*> -*> MAXIT is the maximum number of iterations allowed for each -*> eigenvalue. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -*> \par Contributors: -* ================== -*> -*> Ren-Cang Li, Computer Science Division, University of California -*> at Berkeley, USA -*> -* ===================================================================== - SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER I, INFO, N - DOUBLE PRECISION DLAM, RHO -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), DELTA( * ), Z( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - INTEGER MAXIT - PARAMETER ( MAXIT = 30 ) - DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0, - $ TEN = 10.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL ORGATI, SWTCH, SWTCH3 - INTEGER II, IIM1, IIP1, IP1, ITER, J, NITER - DOUBLE PRECISION A, B, C, DEL, DLTLB, DLTUB, DPHI, DPSI, DW, - $ EPS, ERRETM, ETA, MIDPT, PHI, PREW, PSI, - $ RHOINV, TAU, TEMP, TEMP1, W -* .. -* .. Local Arrays .. - DOUBLE PRECISION ZZ( 3 ) -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DLAED5, DLAED6 -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* -* Since this routine is called in an inner loop, we do no argument -* checking. -* -* Quick return for N=1 and 2. -* - INFO = 0 - IF( N.EQ.1 ) THEN -* -* Presumably, I=1 upon entry -* - DLAM = D( 1 ) + RHO*Z( 1 )*Z( 1 ) - DELTA( 1 ) = ONE - RETURN - END IF - IF( N.EQ.2 ) THEN - CALL DLAED5( I, D, Z, DELTA, RHO, DLAM ) - RETURN - END IF -* -* Compute machine epsilon -* - EPS = DLAMCH( 'Epsilon' ) - RHOINV = ONE / RHO -* -* The case I = N -* - IF( I.EQ.N ) THEN -* -* Initialize some basic variables -* - II = N - 1 - NITER = 1 -* -* Calculate initial guess -* - MIDPT = RHO / TWO -* -* If ||Z||_2 is not one, then TEMP should be set to -* RHO * ||Z||_2^2 / TWO -* - DO 10 J = 1, N - DELTA( J ) = ( D( J )-D( I ) ) - MIDPT - 10 CONTINUE -* - PSI = ZERO - DO 20 J = 1, N - 2 - PSI = PSI + Z( J )*Z( J ) / DELTA( J ) - 20 CONTINUE -* - C = RHOINV + PSI - W = C + Z( II )*Z( II ) / DELTA( II ) + - $ Z( N )*Z( N ) / DELTA( N ) -* - IF( W.LE.ZERO ) THEN - TEMP = Z( N-1 )*Z( N-1 ) / ( D( N )-D( N-1 )+RHO ) + - $ Z( N )*Z( N ) / RHO - IF( C.LE.TEMP ) THEN - TAU = RHO - ELSE - DEL = D( N ) - D( N-1 ) - A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N ) - B = Z( N )*Z( N )*DEL - IF( A.LT.ZERO ) THEN - TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A ) - ELSE - TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C ) - END IF - END IF -* -* It can be proved that -* D(N)+RHO/2 <= LAMBDA(N) < D(N)+TAU <= D(N)+RHO -* - DLTLB = MIDPT - DLTUB = RHO - ELSE - DEL = D( N ) - D( N-1 ) - A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N ) - B = Z( N )*Z( N )*DEL - IF( A.LT.ZERO ) THEN - TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A ) - ELSE - TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C ) - END IF -* -* It can be proved that -* D(N) < D(N)+TAU < LAMBDA(N) < D(N)+RHO/2 -* - DLTLB = ZERO - DLTUB = MIDPT - END IF -* - DO 30 J = 1, N - DELTA( J ) = ( D( J )-D( I ) ) - TAU - 30 CONTINUE -* -* Evaluate PSI and the derivative DPSI -* - DPSI = ZERO - PSI = ZERO - ERRETM = ZERO - DO 40 J = 1, II - TEMP = Z( J ) / DELTA( J ) - PSI = PSI + Z( J )*TEMP - DPSI = DPSI + TEMP*TEMP - ERRETM = ERRETM + PSI - 40 CONTINUE - ERRETM = ABS( ERRETM ) -* -* Evaluate PHI and the derivative DPHI -* - TEMP = Z( N ) / DELTA( N ) - PHI = Z( N )*TEMP - DPHI = TEMP*TEMP - ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + - $ ABS( TAU )*( DPSI+DPHI ) -* - W = RHOINV + PHI + PSI -* -* Test for convergence -* - IF( ABS( W ).LE.EPS*ERRETM ) THEN - DLAM = D( I ) + TAU - GO TO 250 - END IF -* - IF( W.LE.ZERO ) THEN - DLTLB = MAX( DLTLB, TAU ) - ELSE - DLTUB = MIN( DLTUB, TAU ) - END IF -* -* Calculate the new step -* - NITER = NITER + 1 - C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI - A = ( DELTA( N-1 )+DELTA( N ) )*W - - $ DELTA( N-1 )*DELTA( N )*( DPSI+DPHI ) - B = DELTA( N-1 )*DELTA( N )*W - IF( C.LT.ZERO ) - $ C = ABS( C ) - IF( C.EQ.ZERO ) THEN -* ETA = B/A -* ETA = RHO - TAU -* ETA = DLTUB - TAU -* -* Update proposed by Li, Ren-Cang: - ETA = -W / ( DPSI+DPHI ) - ELSE IF( A.GE.ZERO ) THEN - ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) - ELSE - ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) - END IF -* -* Note, eta should be positive if w is negative, and -* eta should be negative otherwise. However, -* if for some reason caused by roundoff, eta*w > 0, -* we simply use one Newton step instead. This way -* will guarantee eta*w < 0. -* - IF( W*ETA.GT.ZERO ) - $ ETA = -W / ( DPSI+DPHI ) - TEMP = TAU + ETA - IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN - IF( W.LT.ZERO ) THEN - ETA = ( DLTUB-TAU ) / TWO - ELSE - ETA = ( DLTLB-TAU ) / TWO - END IF - END IF - DO 50 J = 1, N - DELTA( J ) = DELTA( J ) - ETA - 50 CONTINUE -* - TAU = TAU + ETA -* -* Evaluate PSI and the derivative DPSI -* - DPSI = ZERO - PSI = ZERO - ERRETM = ZERO - DO 60 J = 1, II - TEMP = Z( J ) / DELTA( J ) - PSI = PSI + Z( J )*TEMP - DPSI = DPSI + TEMP*TEMP - ERRETM = ERRETM + PSI - 60 CONTINUE - ERRETM = ABS( ERRETM ) -* -* Evaluate PHI and the derivative DPHI -* - TEMP = Z( N ) / DELTA( N ) - PHI = Z( N )*TEMP - DPHI = TEMP*TEMP - ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + - $ ABS( TAU )*( DPSI+DPHI ) -* - W = RHOINV + PHI + PSI -* -* Main loop to update the values of the array DELTA -* - ITER = NITER + 1 -* - DO 90 NITER = ITER, MAXIT -* -* Test for convergence -* - IF( ABS( W ).LE.EPS*ERRETM ) THEN - DLAM = D( I ) + TAU - GO TO 250 - END IF -* - IF( W.LE.ZERO ) THEN - DLTLB = MAX( DLTLB, TAU ) - ELSE - DLTUB = MIN( DLTUB, TAU ) - END IF -* -* Calculate the new step -* - C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI - A = ( DELTA( N-1 )+DELTA( N ) )*W - - $ DELTA( N-1 )*DELTA( N )*( DPSI+DPHI ) - B = DELTA( N-1 )*DELTA( N )*W - IF( A.GE.ZERO ) THEN - ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) - ELSE - ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) - END IF -* -* Note, eta should be positive if w is negative, and -* eta should be negative otherwise. However, -* if for some reason caused by roundoff, eta*w > 0, -* we simply use one Newton step instead. This way -* will guarantee eta*w < 0. -* - IF( W*ETA.GT.ZERO ) - $ ETA = -W / ( DPSI+DPHI ) - TEMP = TAU + ETA - IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN - IF( W.LT.ZERO ) THEN - ETA = ( DLTUB-TAU ) / TWO - ELSE - ETA = ( DLTLB-TAU ) / TWO - END IF - END IF - DO 70 J = 1, N - DELTA( J ) = DELTA( J ) - ETA - 70 CONTINUE -* - TAU = TAU + ETA -* -* Evaluate PSI and the derivative DPSI -* - DPSI = ZERO - PSI = ZERO - ERRETM = ZERO - DO 80 J = 1, II - TEMP = Z( J ) / DELTA( J ) - PSI = PSI + Z( J )*TEMP - DPSI = DPSI + TEMP*TEMP - ERRETM = ERRETM + PSI - 80 CONTINUE - ERRETM = ABS( ERRETM ) -* -* Evaluate PHI and the derivative DPHI -* - TEMP = Z( N ) / DELTA( N ) - PHI = Z( N )*TEMP - DPHI = TEMP*TEMP - ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + - $ ABS( TAU )*( DPSI+DPHI ) -* - W = RHOINV + PHI + PSI - 90 CONTINUE -* -* Return with INFO = 1, NITER = MAXIT and not converged -* - INFO = 1 - DLAM = D( I ) + TAU - GO TO 250 -* -* End for the case I = N -* - ELSE -* -* The case for I < N -* - NITER = 1 - IP1 = I + 1 -* -* Calculate initial guess -* - DEL = D( IP1 ) - D( I ) - MIDPT = DEL / TWO - DO 100 J = 1, N - DELTA( J ) = ( D( J )-D( I ) ) - MIDPT - 100 CONTINUE -* - PSI = ZERO - DO 110 J = 1, I - 1 - PSI = PSI + Z( J )*Z( J ) / DELTA( J ) - 110 CONTINUE -* - PHI = ZERO - DO 120 J = N, I + 2, -1 - PHI = PHI + Z( J )*Z( J ) / DELTA( J ) - 120 CONTINUE - C = RHOINV + PSI + PHI - W = C + Z( I )*Z( I ) / DELTA( I ) + - $ Z( IP1 )*Z( IP1 ) / DELTA( IP1 ) -* - IF( W.GT.ZERO ) THEN -* -* d(i)< the ith eigenvalue < (d(i)+d(i+1))/2 -* -* We choose d(i) as origin. -* - ORGATI = .TRUE. - A = C*DEL + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 ) - B = Z( I )*Z( I )*DEL - IF( A.GT.ZERO ) THEN - TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) - ELSE - TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) - END IF - DLTLB = ZERO - DLTUB = MIDPT - ELSE -* -* (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1) -* -* We choose d(i+1) as origin. -* - ORGATI = .FALSE. - A = C*DEL - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 ) - B = Z( IP1 )*Z( IP1 )*DEL - IF( A.LT.ZERO ) THEN - TAU = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) ) - ELSE - TAU = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C ) - END IF - DLTLB = -MIDPT - DLTUB = ZERO - END IF -* - IF( ORGATI ) THEN - DO 130 J = 1, N - DELTA( J ) = ( D( J )-D( I ) ) - TAU - 130 CONTINUE - ELSE - DO 140 J = 1, N - DELTA( J ) = ( D( J )-D( IP1 ) ) - TAU - 140 CONTINUE - END IF - IF( ORGATI ) THEN - II = I - ELSE - II = I + 1 - END IF - IIM1 = II - 1 - IIP1 = II + 1 -* -* Evaluate PSI and the derivative DPSI -* - DPSI = ZERO - PSI = ZERO - ERRETM = ZERO - DO 150 J = 1, IIM1 - TEMP = Z( J ) / DELTA( J ) - PSI = PSI + Z( J )*TEMP - DPSI = DPSI + TEMP*TEMP - ERRETM = ERRETM + PSI - 150 CONTINUE - ERRETM = ABS( ERRETM ) -* -* Evaluate PHI and the derivative DPHI -* - DPHI = ZERO - PHI = ZERO - DO 160 J = N, IIP1, -1 - TEMP = Z( J ) / DELTA( J ) - PHI = PHI + Z( J )*TEMP - DPHI = DPHI + TEMP*TEMP - ERRETM = ERRETM + PHI - 160 CONTINUE -* - W = RHOINV + PHI + PSI -* -* W is the value of the secular function with -* its ii-th element removed. -* - SWTCH3 = .FALSE. - IF( ORGATI ) THEN - IF( W.LT.ZERO ) - $ SWTCH3 = .TRUE. - ELSE - IF( W.GT.ZERO ) - $ SWTCH3 = .TRUE. - END IF - IF( II.EQ.1 .OR. II.EQ.N ) - $ SWTCH3 = .FALSE. -* - TEMP = Z( II ) / DELTA( II ) - DW = DPSI + DPHI + TEMP*TEMP - TEMP = Z( II )*TEMP - W = W + TEMP - ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + - $ THREE*ABS( TEMP ) + ABS( TAU )*DW -* -* Test for convergence -* - IF( ABS( W ).LE.EPS*ERRETM ) THEN - IF( ORGATI ) THEN - DLAM = D( I ) + TAU - ELSE - DLAM = D( IP1 ) + TAU - END IF - GO TO 250 - END IF -* - IF( W.LE.ZERO ) THEN - DLTLB = MAX( DLTLB, TAU ) - ELSE - DLTUB = MIN( DLTUB, TAU ) - END IF -* -* Calculate the new step -* - NITER = NITER + 1 - IF( .NOT.SWTCH3 ) THEN - IF( ORGATI ) THEN - C = W - DELTA( IP1 )*DW - ( D( I )-D( IP1 ) )* - $ ( Z( I ) / DELTA( I ) )**2 - ELSE - C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )* - $ ( Z( IP1 ) / DELTA( IP1 ) )**2 - END IF - A = ( DELTA( I )+DELTA( IP1 ) )*W - - $ DELTA( I )*DELTA( IP1 )*DW - B = DELTA( I )*DELTA( IP1 )*W - IF( C.EQ.ZERO ) THEN - IF( A.EQ.ZERO ) THEN - IF( ORGATI ) THEN - A = Z( I )*Z( I ) + DELTA( IP1 )*DELTA( IP1 )* - $ ( DPSI+DPHI ) - ELSE - A = Z( IP1 )*Z( IP1 ) + DELTA( I )*DELTA( I )* - $ ( DPSI+DPHI ) - END IF - END IF - ETA = B / A - ELSE IF( A.LE.ZERO ) THEN - ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) - ELSE - ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) - END IF - ELSE -* -* Interpolation using THREE most relevant poles -* - TEMP = RHOINV + PSI + PHI - IF( ORGATI ) THEN - TEMP1 = Z( IIM1 ) / DELTA( IIM1 ) - TEMP1 = TEMP1*TEMP1 - C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) - - $ ( D( IIM1 )-D( IIP1 ) )*TEMP1 - ZZ( 1 ) = Z( IIM1 )*Z( IIM1 ) - ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )* - $ ( ( DPSI-TEMP1 )+DPHI ) - ELSE - TEMP1 = Z( IIP1 ) / DELTA( IIP1 ) - TEMP1 = TEMP1*TEMP1 - C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) - - $ ( D( IIP1 )-D( IIM1 ) )*TEMP1 - ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )* - $ ( DPSI+( DPHI-TEMP1 ) ) - ZZ( 3 ) = Z( IIP1 )*Z( IIP1 ) - END IF - ZZ( 2 ) = Z( II )*Z( II ) - CALL DLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA, - $ INFO ) - IF( INFO.NE.0 ) - $ GO TO 250 - END IF -* -* Note, eta should be positive if w is negative, and -* eta should be negative otherwise. However, -* if for some reason caused by roundoff, eta*w > 0, -* we simply use one Newton step instead. This way -* will guarantee eta*w < 0. -* - IF( W*ETA.GE.ZERO ) - $ ETA = -W / DW - TEMP = TAU + ETA - IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN - IF( W.LT.ZERO ) THEN - ETA = ( DLTUB-TAU ) / TWO - ELSE - ETA = ( DLTLB-TAU ) / TWO - END IF - END IF -* - PREW = W -* - DO 180 J = 1, N - DELTA( J ) = DELTA( J ) - ETA - 180 CONTINUE -* -* Evaluate PSI and the derivative DPSI -* - DPSI = ZERO - PSI = ZERO - ERRETM = ZERO - DO 190 J = 1, IIM1 - TEMP = Z( J ) / DELTA( J ) - PSI = PSI + Z( J )*TEMP - DPSI = DPSI + TEMP*TEMP - ERRETM = ERRETM + PSI - 190 CONTINUE - ERRETM = ABS( ERRETM ) -* -* Evaluate PHI and the derivative DPHI -* - DPHI = ZERO - PHI = ZERO - DO 200 J = N, IIP1, -1 - TEMP = Z( J ) / DELTA( J ) - PHI = PHI + Z( J )*TEMP - DPHI = DPHI + TEMP*TEMP - ERRETM = ERRETM + PHI - 200 CONTINUE -* - TEMP = Z( II ) / DELTA( II ) - DW = DPSI + DPHI + TEMP*TEMP - TEMP = Z( II )*TEMP - W = RHOINV + PHI + PSI + TEMP - ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + - $ THREE*ABS( TEMP ) + ABS( TAU+ETA )*DW -* - SWTCH = .FALSE. - IF( ORGATI ) THEN - IF( -W.GT.ABS( PREW ) / TEN ) - $ SWTCH = .TRUE. - ELSE - IF( W.GT.ABS( PREW ) / TEN ) - $ SWTCH = .TRUE. - END IF -* - TAU = TAU + ETA -* -* Main loop to update the values of the array DELTA -* - ITER = NITER + 1 -* - DO 240 NITER = ITER, MAXIT -* -* Test for convergence -* - IF( ABS( W ).LE.EPS*ERRETM ) THEN - IF( ORGATI ) THEN - DLAM = D( I ) + TAU - ELSE - DLAM = D( IP1 ) + TAU - END IF - GO TO 250 - END IF -* - IF( W.LE.ZERO ) THEN - DLTLB = MAX( DLTLB, TAU ) - ELSE - DLTUB = MIN( DLTUB, TAU ) - END IF -* -* Calculate the new step -* - IF( .NOT.SWTCH3 ) THEN - IF( .NOT.SWTCH ) THEN - IF( ORGATI ) THEN - C = W - DELTA( IP1 )*DW - - $ ( D( I )-D( IP1 ) )*( Z( I ) / DELTA( I ) )**2 - ELSE - C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )* - $ ( Z( IP1 ) / DELTA( IP1 ) )**2 - END IF - ELSE - TEMP = Z( II ) / DELTA( II ) - IF( ORGATI ) THEN - DPSI = DPSI + TEMP*TEMP - ELSE - DPHI = DPHI + TEMP*TEMP - END IF - C = W - DELTA( I )*DPSI - DELTA( IP1 )*DPHI - END IF - A = ( DELTA( I )+DELTA( IP1 ) )*W - - $ DELTA( I )*DELTA( IP1 )*DW - B = DELTA( I )*DELTA( IP1 )*W - IF( C.EQ.ZERO ) THEN - IF( A.EQ.ZERO ) THEN - IF( .NOT.SWTCH ) THEN - IF( ORGATI ) THEN - A = Z( I )*Z( I ) + DELTA( IP1 )* - $ DELTA( IP1 )*( DPSI+DPHI ) - ELSE - A = Z( IP1 )*Z( IP1 ) + - $ DELTA( I )*DELTA( I )*( DPSI+DPHI ) - END IF - ELSE - A = DELTA( I )*DELTA( I )*DPSI + - $ DELTA( IP1 )*DELTA( IP1 )*DPHI - END IF - END IF - ETA = B / A - ELSE IF( A.LE.ZERO ) THEN - ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) - ELSE - ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) - END IF - ELSE -* -* Interpolation using THREE most relevant poles -* - TEMP = RHOINV + PSI + PHI - IF( SWTCH ) THEN - C = TEMP - DELTA( IIM1 )*DPSI - DELTA( IIP1 )*DPHI - ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*DPSI - ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*DPHI - ELSE - IF( ORGATI ) THEN - TEMP1 = Z( IIM1 ) / DELTA( IIM1 ) - TEMP1 = TEMP1*TEMP1 - C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) - - $ ( D( IIM1 )-D( IIP1 ) )*TEMP1 - ZZ( 1 ) = Z( IIM1 )*Z( IIM1 ) - ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )* - $ ( ( DPSI-TEMP1 )+DPHI ) - ELSE - TEMP1 = Z( IIP1 ) / DELTA( IIP1 ) - TEMP1 = TEMP1*TEMP1 - C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) - - $ ( D( IIP1 )-D( IIM1 ) )*TEMP1 - ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )* - $ ( DPSI+( DPHI-TEMP1 ) ) - ZZ( 3 ) = Z( IIP1 )*Z( IIP1 ) - END IF - END IF - CALL DLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA, - $ INFO ) - IF( INFO.NE.0 ) - $ GO TO 250 - END IF -* -* Note, eta should be positive if w is negative, and -* eta should be negative otherwise. However, -* if for some reason caused by roundoff, eta*w > 0, -* we simply use one Newton step instead. This way -* will guarantee eta*w < 0. -* - IF( W*ETA.GE.ZERO ) - $ ETA = -W / DW - TEMP = TAU + ETA - IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN - IF( W.LT.ZERO ) THEN - ETA = ( DLTUB-TAU ) / TWO - ELSE - ETA = ( DLTLB-TAU ) / TWO - END IF - END IF -* - DO 210 J = 1, N - DELTA( J ) = DELTA( J ) - ETA - 210 CONTINUE -* - TAU = TAU + ETA - PREW = W -* -* Evaluate PSI and the derivative DPSI -* - DPSI = ZERO - PSI = ZERO - ERRETM = ZERO - DO 220 J = 1, IIM1 - TEMP = Z( J ) / DELTA( J ) - PSI = PSI + Z( J )*TEMP - DPSI = DPSI + TEMP*TEMP - ERRETM = ERRETM + PSI - 220 CONTINUE - ERRETM = ABS( ERRETM ) -* -* Evaluate PHI and the derivative DPHI -* - DPHI = ZERO - PHI = ZERO - DO 230 J = N, IIP1, -1 - TEMP = Z( J ) / DELTA( J ) - PHI = PHI + Z( J )*TEMP - DPHI = DPHI + TEMP*TEMP - ERRETM = ERRETM + PHI - 230 CONTINUE -* - TEMP = Z( II ) / DELTA( II ) - DW = DPSI + DPHI + TEMP*TEMP - TEMP = Z( II )*TEMP - W = RHOINV + PHI + PSI + TEMP - ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + - $ THREE*ABS( TEMP ) + ABS( TAU )*DW - IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN ) - $ SWTCH = .NOT.SWTCH -* - 240 CONTINUE -* -* Return with INFO = 1, NITER = MAXIT and not converged -* - INFO = 1 - IF( ORGATI ) THEN - DLAM = D( I ) + TAU - ELSE - DLAM = D( IP1 ) + TAU - END IF -* - END IF -* - 250 CONTINUE -* - RETURN -* -* End of DLAED4 -* - END diff --git a/lib/linalg/dlaed5.cpp b/lib/linalg/dlaed5.cpp new file mode 100644 index 0000000000..30671066fa --- /dev/null +++ b/lib/linalg/dlaed5.cpp @@ -0,0 +1,58 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dlaed5_(integer *i__, doublereal *d__, doublereal *z__, doublereal *delta, doublereal *rho, + doublereal *dlam) +{ + doublereal d__1; + double sqrt(doublereal); + doublereal b, c__, w, del, tau, temp; + --delta; + --z__; + --d__; + del = d__[2] - d__[1]; + if (*i__ == 1) { + w = *rho * 2. * (z__[2] * z__[2] - z__[1] * z__[1]) / del + 1.; + if (w > 0.) { + b = del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); + c__ = *rho * z__[1] * z__[1] * del; + tau = c__ * 2. / (b + sqrt((d__1 = b * b - c__ * 4., abs(d__1)))); + *dlam = d__[1] + tau; + delta[1] = -z__[1] / tau; + delta[2] = z__[2] / (del - tau); + } else { + b = -del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); + c__ = *rho * z__[2] * z__[2] * del; + if (b > 0.) { + tau = c__ * -2. / (b + sqrt(b * b + c__ * 4.)); + } else { + tau = (b - sqrt(b * b + c__ * 4.)) / 2.; + } + *dlam = d__[2] + tau; + delta[1] = -z__[1] / (del + tau); + delta[2] = -z__[2] / tau; + } + temp = sqrt(delta[1] * delta[1] + delta[2] * delta[2]); + delta[1] /= temp; + delta[2] /= temp; + } else { + b = -del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); + c__ = *rho * z__[2] * z__[2] * del; + if (b > 0.) { + tau = (b + sqrt(b * b + c__ * 4.)) / 2.; + } else { + tau = c__ * 2. / (-b + sqrt(b * b + c__ * 4.)); + } + *dlam = d__[2] + tau; + delta[1] = -z__[1] / (del + tau); + delta[2] = -z__[2] / tau; + temp = sqrt(delta[1] * delta[1] + delta[2] * delta[2]); + delta[1] /= temp; + delta[2] /= temp; + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlaed5.f b/lib/linalg/dlaed5.f deleted file mode 100644 index d9e977e6b7..0000000000 --- a/lib/linalg/dlaed5.f +++ /dev/null @@ -1,186 +0,0 @@ -*> \brief \b DLAED5 used by DSTEDC. Solves the 2-by-2 secular equation. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAED5 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM ) -* -* .. Scalar Arguments .. -* INTEGER I -* DOUBLE PRECISION DLAM, RHO -* .. -* .. Array Arguments .. -* DOUBLE PRECISION D( 2 ), DELTA( 2 ), Z( 2 ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> This subroutine computes the I-th eigenvalue of a symmetric rank-one -*> modification of a 2-by-2 diagonal matrix -*> -*> diag( D ) + RHO * Z * transpose(Z) . -*> -*> The diagonal elements in the array D are assumed to satisfy -*> -*> D(i) < D(j) for i < j . -*> -*> We also assume RHO > 0 and that the Euclidean norm of the vector -*> Z is one. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] I -*> \verbatim -*> I is INTEGER -*> The index of the eigenvalue to be computed. I = 1 or I = 2. -*> \endverbatim -*> -*> \param[in] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (2) -*> The original eigenvalues. We assume D(1) < D(2). -*> \endverbatim -*> -*> \param[in] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension (2) -*> The components of the updating vector. -*> \endverbatim -*> -*> \param[out] DELTA -*> \verbatim -*> DELTA is DOUBLE PRECISION array, dimension (2) -*> The vector DELTA contains the information necessary -*> to construct the eigenvectors. -*> \endverbatim -*> -*> \param[in] RHO -*> \verbatim -*> RHO is DOUBLE PRECISION -*> The scalar in the symmetric updating formula. -*> \endverbatim -*> -*> \param[out] DLAM -*> \verbatim -*> DLAM is DOUBLE PRECISION -*> The computed lambda_I, the I-th updated eigenvalue. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -*> \par Contributors: -* ================== -*> -*> Ren-Cang Li, Computer Science Division, University of California -*> at Berkeley, USA -*> -* ===================================================================== - SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER I - DOUBLE PRECISION DLAM, RHO -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( 2 ), DELTA( 2 ), Z( 2 ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, FOUR - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ FOUR = 4.0D0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION B, C, DEL, TAU, TEMP, W -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -* .. -* .. Executable Statements .. -* - DEL = D( 2 ) - D( 1 ) - IF( I.EQ.1 ) THEN - W = ONE + TWO*RHO*( Z( 2 )*Z( 2 )-Z( 1 )*Z( 1 ) ) / DEL - IF( W.GT.ZERO ) THEN - B = DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) - C = RHO*Z( 1 )*Z( 1 )*DEL -* -* B > ZERO, always -* - TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) ) - DLAM = D( 1 ) + TAU - DELTA( 1 ) = -Z( 1 ) / TAU - DELTA( 2 ) = Z( 2 ) / ( DEL-TAU ) - ELSE - B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) - C = RHO*Z( 2 )*Z( 2 )*DEL - IF( B.GT.ZERO ) THEN - TAU = -TWO*C / ( B+SQRT( B*B+FOUR*C ) ) - ELSE - TAU = ( B-SQRT( B*B+FOUR*C ) ) / TWO - END IF - DLAM = D( 2 ) + TAU - DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) - DELTA( 2 ) = -Z( 2 ) / TAU - END IF - TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) - DELTA( 1 ) = DELTA( 1 ) / TEMP - DELTA( 2 ) = DELTA( 2 ) / TEMP - ELSE -* -* Now I=2 -* - B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) - C = RHO*Z( 2 )*Z( 2 )*DEL - IF( B.GT.ZERO ) THEN - TAU = ( B+SQRT( B*B+FOUR*C ) ) / TWO - ELSE - TAU = TWO*C / ( -B+SQRT( B*B+FOUR*C ) ) - END IF - DLAM = D( 2 ) + TAU - DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) - DELTA( 2 ) = -Z( 2 ) / TAU - TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) - DELTA( 1 ) = DELTA( 1 ) / TEMP - DELTA( 2 ) = DELTA( 2 ) / TEMP - END IF - RETURN -* -* End of DLAED5 -* - END diff --git a/lib/linalg/dlaed6.cpp b/lib/linalg/dlaed6.cpp new file mode 100644 index 0000000000..083046b822 --- /dev/null +++ b/lib/linalg/dlaed6.cpp @@ -0,0 +1,209 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dlaed6_(integer *kniter, logical *orgati, doublereal *rho, doublereal *d__, doublereal *z__, + doublereal *finit, doublereal *tau, integer *info) +{ + integer i__1; + doublereal d__1, d__2, d__3, d__4; + double sqrt(doublereal), log(doublereal), pow_lmp_di(doublereal *, integer *); + doublereal a, b, c__, f; + integer i__; + doublereal fc, df, ddf, lbd, eta, ubd, eps, base; + integer iter; + doublereal temp, temp1, temp2, temp3, temp4; + logical scale; + integer niter; + doublereal small1, small2, sminv1, sminv2; + extern doublereal dlamch_(char *, ftnlen); + doublereal dscale[3], sclfac, zscale[3], erretm, sclinv; + --z__; + --d__; + *info = 0; + if (*orgati) { + lbd = d__[2]; + ubd = d__[3]; + } else { + lbd = d__[1]; + ubd = d__[2]; + } + if (*finit < 0.) { + lbd = 0.; + } else { + ubd = 0.; + } + niter = 1; + *tau = 0.; + if (*kniter == 2) { + if (*orgati) { + temp = (d__[3] - d__[2]) / 2.; + c__ = *rho + z__[1] / (d__[1] - d__[2] - temp); + a = c__ * (d__[2] + d__[3]) + z__[2] + z__[3]; + b = c__ * d__[2] * d__[3] + z__[2] * d__[3] + z__[3] * d__[2]; + } else { + temp = (d__[1] - d__[2]) / 2.; + c__ = *rho + z__[3] / (d__[3] - d__[2] - temp); + a = c__ * (d__[1] + d__[2]) + z__[1] + z__[2]; + b = c__ * d__[1] * d__[2] + z__[1] * d__[2] + z__[2] * d__[1]; + } + d__1 = abs(a), d__2 = abs(b), d__1 = max(d__1, d__2), d__2 = abs(c__); + temp = max(d__1, d__2); + a /= temp; + b /= temp; + c__ /= temp; + if (c__ == 0.) { + *tau = b / a; + } else if (a <= 0.) { + *tau = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ * 2.); + } else { + *tau = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))); + } + if (*tau < lbd || *tau > ubd) { + *tau = (lbd + ubd) / 2.; + } + if (d__[1] == *tau || d__[2] == *tau || d__[3] == *tau) { + *tau = 0.; + } else { + temp = *finit + *tau * z__[1] / (d__[1] * (d__[1] - *tau)) + + *tau * z__[2] / (d__[2] * (d__[2] - *tau)) + + *tau * z__[3] / (d__[3] * (d__[3] - *tau)); + if (temp <= 0.) { + lbd = *tau; + } else { + ubd = *tau; + } + if (abs(*finit) <= abs(temp)) { + *tau = 0.; + } + } + } + eps = dlamch_((char *)"Epsilon", (ftnlen)7); + base = dlamch_((char *)"Base", (ftnlen)4); + i__1 = (integer)(log(dlamch_((char *)"SafMin", (ftnlen)6)) / log(base) / 3.); + small1 = pow_lmp_di(&base, &i__1); + sminv1 = 1. / small1; + small2 = small1 * small1; + sminv2 = sminv1 * sminv1; + if (*orgati) { + d__3 = (d__1 = d__[2] - *tau, abs(d__1)), d__4 = (d__2 = d__[3] - *tau, abs(d__2)); + temp = min(d__3, d__4); + } else { + d__3 = (d__1 = d__[1] - *tau, abs(d__1)), d__4 = (d__2 = d__[2] - *tau, abs(d__2)); + temp = min(d__3, d__4); + } + scale = FALSE_; + if (temp <= small1) { + scale = TRUE_; + if (temp <= small2) { + sclfac = sminv2; + sclinv = small2; + } else { + sclfac = sminv1; + sclinv = small1; + } + for (i__ = 1; i__ <= 3; ++i__) { + dscale[i__ - 1] = d__[i__] * sclfac; + zscale[i__ - 1] = z__[i__] * sclfac; + } + *tau *= sclfac; + lbd *= sclfac; + ubd *= sclfac; + } else { + for (i__ = 1; i__ <= 3; ++i__) { + dscale[i__ - 1] = d__[i__]; + zscale[i__ - 1] = z__[i__]; + } + } + fc = 0.; + df = 0.; + ddf = 0.; + for (i__ = 1; i__ <= 3; ++i__) { + temp = 1. / (dscale[i__ - 1] - *tau); + temp1 = zscale[i__ - 1] * temp; + temp2 = temp1 * temp; + temp3 = temp2 * temp; + fc += temp1 / dscale[i__ - 1]; + df += temp2; + ddf += temp3; + } + f = *finit + *tau * fc; + if (abs(f) <= 0.) { + goto L60; + } + if (f <= 0.) { + lbd = *tau; + } else { + ubd = *tau; + } + iter = niter + 1; + for (niter = iter; niter <= 40; ++niter) { + if (*orgati) { + temp1 = dscale[1] - *tau; + temp2 = dscale[2] - *tau; + } else { + temp1 = dscale[0] - *tau; + temp2 = dscale[1] - *tau; + } + a = (temp1 + temp2) * f - temp1 * temp2 * df; + b = temp1 * temp2 * f; + c__ = f - (temp1 + temp2) * df + temp1 * temp2 * ddf; + d__1 = abs(a), d__2 = abs(b), d__1 = max(d__1, d__2), d__2 = abs(c__); + temp = max(d__1, d__2); + a /= temp; + b /= temp; + c__ /= temp; + if (c__ == 0.) { + eta = b / a; + } else if (a <= 0.) { + eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ * 2.); + } else { + eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))); + } + if (f * eta >= 0.) { + eta = -f / df; + } + *tau += eta; + if (*tau < lbd || *tau > ubd) { + *tau = (lbd + ubd) / 2.; + } + fc = 0.; + erretm = 0.; + df = 0.; + ddf = 0.; + for (i__ = 1; i__ <= 3; ++i__) { + if (dscale[i__ - 1] - *tau != 0.) { + temp = 1. / (dscale[i__ - 1] - *tau); + temp1 = zscale[i__ - 1] * temp; + temp2 = temp1 * temp; + temp3 = temp2 * temp; + temp4 = temp1 / dscale[i__ - 1]; + fc += temp4; + erretm += abs(temp4); + df += temp2; + ddf += temp3; + } else { + goto L60; + } + } + f = *finit + *tau * fc; + erretm = (abs(*finit) + abs(*tau) * erretm) * 8. + abs(*tau) * df; + if (abs(f) <= eps * 4. * erretm || ubd - lbd <= eps * 4. * abs(*tau)) { + goto L60; + } + if (f <= 0.) { + lbd = *tau; + } else { + ubd = *tau; + } + } + *info = 1; +L60: + if (scale) { + *tau *= sclinv; + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlaed6.f b/lib/linalg/dlaed6.f deleted file mode 100644 index a0c0364e56..0000000000 --- a/lib/linalg/dlaed6.f +++ /dev/null @@ -1,407 +0,0 @@ -*> \brief \b DLAED6 used by DSTEDC. Computes one Newton step in solution of the secular equation. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAED6 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) -* -* .. Scalar Arguments .. -* LOGICAL ORGATI -* INTEGER INFO, KNITER -* DOUBLE PRECISION FINIT, RHO, TAU -* .. -* .. Array Arguments .. -* DOUBLE PRECISION D( 3 ), Z( 3 ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAED6 computes the positive or negative root (closest to the origin) -*> of -*> z(1) z(2) z(3) -*> f(x) = rho + --------- + ---------- + --------- -*> d(1)-x d(2)-x d(3)-x -*> -*> It is assumed that -*> -*> if ORGATI = .true. the root is between d(2) and d(3); -*> otherwise it is between d(1) and d(2) -*> -*> This routine will be called by DLAED4 when necessary. In most cases, -*> the root sought is the smallest in magnitude, though it might not be -*> in some extremely rare situations. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] KNITER -*> \verbatim -*> KNITER is INTEGER -*> Refer to DLAED4 for its significance. -*> \endverbatim -*> -*> \param[in] ORGATI -*> \verbatim -*> ORGATI is LOGICAL -*> If ORGATI is true, the needed root is between d(2) and -*> d(3); otherwise it is between d(1) and d(2). See -*> DLAED4 for further details. -*> \endverbatim -*> -*> \param[in] RHO -*> \verbatim -*> RHO is DOUBLE PRECISION -*> Refer to the equation f(x) above. -*> \endverbatim -*> -*> \param[in] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (3) -*> D satisfies d(1) < d(2) < d(3). -*> \endverbatim -*> -*> \param[in] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension (3) -*> Each of the elements in z must be positive. -*> \endverbatim -*> -*> \param[in] FINIT -*> \verbatim -*> FINIT is DOUBLE PRECISION -*> The value of f at 0. It is more accurate than the one -*> evaluated inside this routine (if someone wants to do -*> so). -*> \endverbatim -*> -*> \param[out] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION -*> The root of the equation f(x). -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> > 0: if INFO = 1, failure to converge -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> 10/02/03: This version has a few statements commented out for thread -*> safety (machine parameters are computed on each entry). SJH. -*> -*> 05/10/06: Modified from a new version of Ren-Cang Li, use -*> Gragg-Thornton-Warner cubic convergent scheme for better stability. -*> \endverbatim -* -*> \par Contributors: -* ================== -*> -*> Ren-Cang Li, Computer Science Division, University of California -*> at Berkeley, USA -*> -* ===================================================================== - SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - LOGICAL ORGATI - INTEGER INFO, KNITER - DOUBLE PRECISION FINIT, RHO, TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( 3 ), Z( 3 ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - INTEGER MAXIT - PARAMETER ( MAXIT = 40 ) - DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0 ) -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. Local Arrays .. - DOUBLE PRECISION DSCALE( 3 ), ZSCALE( 3 ) -* .. -* .. Local Scalars .. - LOGICAL SCALE - INTEGER I, ITER, NITER - DOUBLE PRECISION A, B, BASE, C, DDF, DF, EPS, ERRETM, ETA, F, - $ FC, SCLFAC, SCLINV, SMALL1, SMALL2, SMINV1, - $ SMINV2, TEMP, TEMP1, TEMP2, TEMP3, TEMP4, - $ LBD, UBD -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - INFO = 0 -* - IF( ORGATI ) THEN - LBD = D(2) - UBD = D(3) - ELSE - LBD = D(1) - UBD = D(2) - END IF - IF( FINIT .LT. ZERO )THEN - LBD = ZERO - ELSE - UBD = ZERO - END IF -* - NITER = 1 - TAU = ZERO - IF( KNITER.EQ.2 ) THEN - IF( ORGATI ) THEN - TEMP = ( D( 3 )-D( 2 ) ) / TWO - C = RHO + Z( 1 ) / ( ( D( 1 )-D( 2 ) )-TEMP ) - A = C*( D( 2 )+D( 3 ) ) + Z( 2 ) + Z( 3 ) - B = C*D( 2 )*D( 3 ) + Z( 2 )*D( 3 ) + Z( 3 )*D( 2 ) - ELSE - TEMP = ( D( 1 )-D( 2 ) ) / TWO - C = RHO + Z( 3 ) / ( ( D( 3 )-D( 2 ) )-TEMP ) - A = C*( D( 1 )+D( 2 ) ) + Z( 1 ) + Z( 2 ) - B = C*D( 1 )*D( 2 ) + Z( 1 )*D( 2 ) + Z( 2 )*D( 1 ) - END IF - TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) ) - A = A / TEMP - B = B / TEMP - C = C / TEMP - IF( C.EQ.ZERO ) THEN - TAU = B / A - ELSE IF( A.LE.ZERO ) THEN - TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) - ELSE - TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) - END IF - IF( TAU .LT. LBD .OR. TAU .GT. UBD ) - $ TAU = ( LBD+UBD )/TWO - IF( D(1).EQ.TAU .OR. D(2).EQ.TAU .OR. D(3).EQ.TAU ) THEN - TAU = ZERO - ELSE - TEMP = FINIT + TAU*Z(1)/( D(1)*( D( 1 )-TAU ) ) + - $ TAU*Z(2)/( D(2)*( D( 2 )-TAU ) ) + - $ TAU*Z(3)/( D(3)*( D( 3 )-TAU ) ) - IF( TEMP .LE. ZERO )THEN - LBD = TAU - ELSE - UBD = TAU - END IF - IF( ABS( FINIT ).LE.ABS( TEMP ) ) - $ TAU = ZERO - END IF - END IF -* -* get machine parameters for possible scaling to avoid overflow -* -* modified by Sven: parameters SMALL1, SMINV1, SMALL2, -* SMINV2, EPS are not SAVEd anymore between one call to the -* others but recomputed at each call -* - EPS = DLAMCH( 'Epsilon' ) - BASE = DLAMCH( 'Base' ) - SMALL1 = BASE**( INT( LOG( DLAMCH( 'SafMin' ) ) / LOG( BASE ) / - $ THREE ) ) - SMINV1 = ONE / SMALL1 - SMALL2 = SMALL1*SMALL1 - SMINV2 = SMINV1*SMINV1 -* -* Determine if scaling of inputs necessary to avoid overflow -* when computing 1/TEMP**3 -* - IF( ORGATI ) THEN - TEMP = MIN( ABS( D( 2 )-TAU ), ABS( D( 3 )-TAU ) ) - ELSE - TEMP = MIN( ABS( D( 1 )-TAU ), ABS( D( 2 )-TAU ) ) - END IF - SCALE = .FALSE. - IF( TEMP.LE.SMALL1 ) THEN - SCALE = .TRUE. - IF( TEMP.LE.SMALL2 ) THEN -* -* Scale up by power of radix nearest 1/SAFMIN**(2/3) -* - SCLFAC = SMINV2 - SCLINV = SMALL2 - ELSE -* -* Scale up by power of radix nearest 1/SAFMIN**(1/3) -* - SCLFAC = SMINV1 - SCLINV = SMALL1 - END IF -* -* Scaling up safe because D, Z, TAU scaled elsewhere to be O(1) -* - DO 10 I = 1, 3 - DSCALE( I ) = D( I )*SCLFAC - ZSCALE( I ) = Z( I )*SCLFAC - 10 CONTINUE - TAU = TAU*SCLFAC - LBD = LBD*SCLFAC - UBD = UBD*SCLFAC - ELSE -* -* Copy D and Z to DSCALE and ZSCALE -* - DO 20 I = 1, 3 - DSCALE( I ) = D( I ) - ZSCALE( I ) = Z( I ) - 20 CONTINUE - END IF -* - FC = ZERO - DF = ZERO - DDF = ZERO - DO 30 I = 1, 3 - TEMP = ONE / ( DSCALE( I )-TAU ) - TEMP1 = ZSCALE( I )*TEMP - TEMP2 = TEMP1*TEMP - TEMP3 = TEMP2*TEMP - FC = FC + TEMP1 / DSCALE( I ) - DF = DF + TEMP2 - DDF = DDF + TEMP3 - 30 CONTINUE - F = FINIT + TAU*FC -* - IF( ABS( F ).LE.ZERO ) - $ GO TO 60 - IF( F .LE. ZERO )THEN - LBD = TAU - ELSE - UBD = TAU - END IF -* -* Iteration begins -- Use Gragg-Thornton-Warner cubic convergent -* scheme -* -* It is not hard to see that -* -* 1) Iterations will go up monotonically -* if FINIT < 0; -* -* 2) Iterations will go down monotonically -* if FINIT > 0. -* - ITER = NITER + 1 -* - DO 50 NITER = ITER, MAXIT -* - IF( ORGATI ) THEN - TEMP1 = DSCALE( 2 ) - TAU - TEMP2 = DSCALE( 3 ) - TAU - ELSE - TEMP1 = DSCALE( 1 ) - TAU - TEMP2 = DSCALE( 2 ) - TAU - END IF - A = ( TEMP1+TEMP2 )*F - TEMP1*TEMP2*DF - B = TEMP1*TEMP2*F - C = F - ( TEMP1+TEMP2 )*DF + TEMP1*TEMP2*DDF - TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) ) - A = A / TEMP - B = B / TEMP - C = C / TEMP - IF( C.EQ.ZERO ) THEN - ETA = B / A - ELSE IF( A.LE.ZERO ) THEN - ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) - ELSE - ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) - END IF - IF( F*ETA.GE.ZERO ) THEN - ETA = -F / DF - END IF -* - TAU = TAU + ETA - IF( TAU .LT. LBD .OR. TAU .GT. UBD ) - $ TAU = ( LBD + UBD )/TWO -* - FC = ZERO - ERRETM = ZERO - DF = ZERO - DDF = ZERO - DO 40 I = 1, 3 - IF ( ( DSCALE( I )-TAU ).NE.ZERO ) THEN - TEMP = ONE / ( DSCALE( I )-TAU ) - TEMP1 = ZSCALE( I )*TEMP - TEMP2 = TEMP1*TEMP - TEMP3 = TEMP2*TEMP - TEMP4 = TEMP1 / DSCALE( I ) - FC = FC + TEMP4 - ERRETM = ERRETM + ABS( TEMP4 ) - DF = DF + TEMP2 - DDF = DDF + TEMP3 - ELSE - GO TO 60 - END IF - 40 CONTINUE - F = FINIT + TAU*FC - ERRETM = EIGHT*( ABS( FINIT )+ABS( TAU )*ERRETM ) + - $ ABS( TAU )*DF - IF( ( ABS( F ).LE.FOUR*EPS*ERRETM ) .OR. - $ ( (UBD-LBD).LE.FOUR*EPS*ABS(TAU) ) ) - $ GO TO 60 - IF( F .LE. ZERO )THEN - LBD = TAU - ELSE - UBD = TAU - END IF - 50 CONTINUE - INFO = 1 - 60 CONTINUE -* -* Undo scaling -* - IF( SCALE ) - $ TAU = TAU*SCLINV - RETURN -* -* End of DLAED6 -* - END diff --git a/lib/linalg/dlaed7.cpp b/lib/linalg/dlaed7.cpp new file mode 100644 index 0000000000..036fdeff6f --- /dev/null +++ b/lib/linalg/dlaed7.cpp @@ -0,0 +1,131 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__2 = 2; +static integer c__1 = 1; +static doublereal c_b10 = 1.; +static doublereal c_b11 = 0.; +static integer c_n1 = -1; +int dlaed7_(integer *icompq, integer *n, integer *qsiz, integer *tlvls, integer *curlvl, + integer *curpbm, doublereal *d__, doublereal *q, integer *ldq, integer *indxq, + doublereal *rho, integer *cutpnt, doublereal *qstore, integer *qptr, integer *prmptr, + integer *perm, integer *givptr, integer *givcol, doublereal *givnum, doublereal *work, + integer *iwork, integer *info) +{ + integer q_dim1, q_offset, i__1, i__2; + integer pow_lmp_ii(integer *, integer *); + integer i__, k, n1, n2, is, iw, iz, iq2, ptr, ldq2, indx, curr; + extern int dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, + ftnlen, ftnlen); + integer indxc, indxp; + extern int dlaed8_(integer *, integer *, integer *, integer *, doublereal *, doublereal *, + integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, + doublereal *, integer *, doublereal *, integer *, integer *, integer *, + doublereal *, integer *, integer *, integer *), + dlaed9_(integer *, integer *, integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *, integer *), + dlaeda_(integer *, integer *, integer *, integer *, integer *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, + integer *); + integer idlmda; + extern int dlamrg_(integer *, integer *, doublereal *, integer *, integer *, integer *), + xerbla_(char *, integer *, ftnlen); + integer coltyp; + --d__; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + --indxq; + --qstore; + --qptr; + --prmptr; + --perm; + --givptr; + givcol -= 3; + givnum -= 3; + --work; + --iwork; + *info = 0; + if (*icompq < 0 || *icompq > 1) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*icompq == 1 && *qsiz < *n) { + *info = -3; + } else if (*ldq < max(1, *n)) { + *info = -9; + } else if (min(1, *n) > *cutpnt || *n < *cutpnt) { + *info = -12; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DLAED7", &i__1, (ftnlen)6); + return 0; + } + if (*n == 0) { + return 0; + } + if (*icompq == 1) { + ldq2 = *qsiz; + } else { + ldq2 = *n; + } + iz = 1; + idlmda = iz + *n; + iw = idlmda + *n; + iq2 = iw + *n; + is = iq2 + *n * ldq2; + indx = 1; + indxc = indx + *n; + coltyp = indxc + *n; + indxp = coltyp + *n; + ptr = pow_lmp_ii(&c__2, tlvls) + 1; + i__1 = *curlvl - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *tlvls - i__; + ptr += pow_lmp_ii(&c__2, &i__2); + } + curr = ptr + *curpbm; + dlaeda_(n, tlvls, curlvl, curpbm, &prmptr[1], &perm[1], &givptr[1], &givcol[3], &givnum[3], + &qstore[1], &qptr[1], &work[iz], &work[iz + *n], info); + if (*curlvl == *tlvls) { + qptr[curr] = 1; + prmptr[curr] = 1; + givptr[curr] = 1; + } + dlaed8_(icompq, &k, n, qsiz, &d__[1], &q[q_offset], ldq, &indxq[1], rho, cutpnt, &work[iz], + &work[idlmda], &work[iq2], &ldq2, &work[iw], &perm[prmptr[curr]], &givptr[curr + 1], + &givcol[(givptr[curr] << 1) + 1], &givnum[(givptr[curr] << 1) + 1], &iwork[indxp], + &iwork[indx], info); + prmptr[curr + 1] = prmptr[curr] + *n; + givptr[curr + 1] += givptr[curr]; + if (k != 0) { + dlaed9_(&k, &c__1, &k, n, &d__[1], &work[is], &k, rho, &work[idlmda], &work[iw], + &qstore[qptr[curr]], &k, info); + if (*info != 0) { + goto L30; + } + if (*icompq == 1) { + dgemm_((char *)"N", (char *)"N", qsiz, &k, &k, &c_b10, &work[iq2], &ldq2, &qstore[qptr[curr]], &k, + &c_b11, &q[q_offset], ldq, (ftnlen)1, (ftnlen)1); + } + i__1 = k; + qptr[curr + 1] = qptr[curr] + i__1 * i__1; + n1 = k; + n2 = *n - k; + dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]); + } else { + qptr[curr + 1] = qptr[curr]; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + indxq[i__] = i__; + } + } +L30: + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlaed7.f b/lib/linalg/dlaed7.f deleted file mode 100644 index d968c56752..0000000000 --- a/lib/linalg/dlaed7.f +++ /dev/null @@ -1,404 +0,0 @@ -*> \brief \b DLAED7 used by DSTEDC. Computes the updated eigensystem of a diagonal matrix after modification by a rank-one symmetric matrix. Used when the original matrix is dense. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAED7 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, -* LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR, -* PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK, -* INFO ) -* -* .. Scalar Arguments .. -* INTEGER CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N, -* $ QSIZ, TLVLS -* DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. -* INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ), -* $ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * ) -* DOUBLE PRECISION D( * ), GIVNUM( 2, * ), Q( LDQ, * ), -* $ QSTORE( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAED7 computes the updated eigensystem of a diagonal -*> matrix after modification by a rank-one symmetric matrix. This -*> routine is used only for the eigenproblem which requires all -*> eigenvalues and optionally eigenvectors of a dense symmetric matrix -*> that has been reduced to tridiagonal form. DLAED1 handles -*> the case in which all eigenvalues and eigenvectors of a symmetric -*> tridiagonal matrix are desired. -*> -*> T = Q(in) ( D(in) + RHO * Z*Z**T ) Q**T(in) = Q(out) * D(out) * Q**T(out) -*> -*> where Z = Q**Tu, u is a vector of length N with ones in the -*> CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. -*> -*> The eigenvectors of the original matrix are stored in Q, and the -*> eigenvalues are in D. The algorithm consists of three stages: -*> -*> The first stage consists of deflating the size of the problem -*> when there are multiple eigenvalues or if there is a zero in -*> the Z vector. For each such occurrence the dimension of the -*> secular equation problem is reduced by one. This stage is -*> performed by the routine DLAED8. -*> -*> The second stage consists of calculating the updated -*> eigenvalues. This is done by finding the roots of the secular -*> equation via the routine DLAED4 (as called by DLAED9). -*> This routine also calculates the eigenvectors of the current -*> problem. -*> -*> The final stage consists of computing the updated eigenvectors -*> directly using the updated eigenvalues. The eigenvectors for -*> the current problem are multiplied with the eigenvectors from -*> the overall problem. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] ICOMPQ -*> \verbatim -*> ICOMPQ is INTEGER -*> = 0: Compute eigenvalues only. -*> = 1: Compute eigenvectors of original dense symmetric matrix -*> also. On entry, Q contains the orthogonal matrix used -*> to reduce the original matrix to tridiagonal form. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The dimension of the symmetric tridiagonal matrix. N >= 0. -*> \endverbatim -*> -*> \param[in] QSIZ -*> \verbatim -*> QSIZ is INTEGER -*> The dimension of the orthogonal matrix used to reduce -*> the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. -*> \endverbatim -*> -*> \param[in] TLVLS -*> \verbatim -*> TLVLS is INTEGER -*> The total number of merging levels in the overall divide and -*> conquer tree. -*> \endverbatim -*> -*> \param[in] CURLVL -*> \verbatim -*> CURLVL is INTEGER -*> The current level in the overall merge routine, -*> 0 <= CURLVL <= TLVLS. -*> \endverbatim -*> -*> \param[in] CURPBM -*> \verbatim -*> CURPBM is INTEGER -*> The current problem in the current level in the overall -*> merge routine (counting from upper left to lower right). -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, the eigenvalues of the rank-1-perturbed matrix. -*> On exit, the eigenvalues of the repaired matrix. -*> \endverbatim -*> -*> \param[in,out] Q -*> \verbatim -*> Q is DOUBLE PRECISION array, dimension (LDQ, N) -*> On entry, the eigenvectors of the rank-1-perturbed matrix. -*> On exit, the eigenvectors of the repaired tridiagonal matrix. -*> \endverbatim -*> -*> \param[in] LDQ -*> \verbatim -*> LDQ is INTEGER -*> The leading dimension of the array Q. LDQ >= max(1,N). -*> \endverbatim -*> -*> \param[out] INDXQ -*> \verbatim -*> INDXQ is INTEGER array, dimension (N) -*> The permutation which will reintegrate the subproblem just -*> solved back into sorted order, i.e., D( INDXQ( I = 1, N ) ) -*> will be in ascending order. -*> \endverbatim -*> -*> \param[in] RHO -*> \verbatim -*> RHO is DOUBLE PRECISION -*> The subdiagonal element used to create the rank-1 -*> modification. -*> \endverbatim -*> -*> \param[in] CUTPNT -*> \verbatim -*> CUTPNT is INTEGER -*> Contains the location of the last eigenvalue in the leading -*> sub-matrix. min(1,N) <= CUTPNT <= N. -*> \endverbatim -*> -*> \param[in,out] QSTORE -*> \verbatim -*> QSTORE is DOUBLE PRECISION array, dimension (N**2+1) -*> Stores eigenvectors of submatrices encountered during -*> divide and conquer, packed together. QPTR points to -*> beginning of the submatrices. -*> \endverbatim -*> -*> \param[in,out] QPTR -*> \verbatim -*> QPTR is INTEGER array, dimension (N+2) -*> List of indices pointing to beginning of submatrices stored -*> in QSTORE. The submatrices are numbered starting at the -*> bottom left of the divide and conquer tree, from left to -*> right and bottom to top. -*> \endverbatim -*> -*> \param[in] PRMPTR -*> \verbatim -*> PRMPTR is INTEGER array, dimension (N lg N) -*> Contains a list of pointers which indicate where in PERM a -*> level's permutation is stored. PRMPTR(i+1) - PRMPTR(i) -*> indicates the size of the permutation and also the size of -*> the full, non-deflated problem. -*> \endverbatim -*> -*> \param[in] PERM -*> \verbatim -*> PERM is INTEGER array, dimension (N lg N) -*> Contains the permutations (from deflation and sorting) to be -*> applied to each eigenblock. -*> \endverbatim -*> -*> \param[in] GIVPTR -*> \verbatim -*> GIVPTR is INTEGER array, dimension (N lg N) -*> Contains a list of pointers which indicate where in GIVCOL a -*> level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i) -*> indicates the number of Givens rotations. -*> \endverbatim -*> -*> \param[in] GIVCOL -*> \verbatim -*> GIVCOL is INTEGER array, dimension (2, N lg N) -*> Each pair of numbers indicates a pair of columns to take place -*> in a Givens rotation. -*> \endverbatim -*> -*> \param[in] GIVNUM -*> \verbatim -*> GIVNUM is DOUBLE PRECISION array, dimension (2, N lg N) -*> Each number indicates the S value to be used in the -*> corresponding Givens rotation. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (3*N+2*QSIZ*N) -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, dimension (4*N) -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit. -*> < 0: if INFO = -i, the i-th argument had an illegal value. -*> > 0: if INFO = 1, an eigenvalue did not converge -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -*> \par Contributors: -* ================== -*> -*> Jeff Rutter, Computer Science Division, University of California -*> at Berkeley, USA -* -* ===================================================================== - SUBROUTINE DLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, - $ LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR, - $ PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK, - $ INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N, - $ QSIZ, TLVLS - DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. - INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ), - $ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * ) - DOUBLE PRECISION D( * ), GIVNUM( 2, * ), Q( LDQ, * ), - $ QSTORE( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -* .. -* .. Local Scalars .. - INTEGER COLTYP, CURR, I, IDLMDA, INDX, INDXC, INDXP, - $ IQ2, IS, IW, IZ, K, LDQ2, N1, N2, PTR -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DLAED8, DLAED9, DLAEDA, DLAMRG, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN - INFO = -3 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( MIN( 1, N ).GT.CUTPNT .OR. N.LT.CUTPNT ) THEN - INFO = -12 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLAED7', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* The following values are for bookkeeping purposes only. They are -* integer pointers which indicate the portion of the workspace -* used by a particular array in DLAED8 and DLAED9. -* - IF( ICOMPQ.EQ.1 ) THEN - LDQ2 = QSIZ - ELSE - LDQ2 = N - END IF -* - IZ = 1 - IDLMDA = IZ + N - IW = IDLMDA + N - IQ2 = IW + N - IS = IQ2 + N*LDQ2 -* - INDX = 1 - INDXC = INDX + N - COLTYP = INDXC + N - INDXP = COLTYP + N -* -* Form the z-vector which consists of the last row of Q_1 and the -* first row of Q_2. -* - PTR = 1 + 2**TLVLS - DO 10 I = 1, CURLVL - 1 - PTR = PTR + 2**( TLVLS-I ) - 10 CONTINUE - CURR = PTR + CURPBM - CALL DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, - $ GIVCOL, GIVNUM, QSTORE, QPTR, WORK( IZ ), - $ WORK( IZ+N ), INFO ) -* -* When solving the final problem, we no longer need the stored data, -* so we will overwrite the data from this level onto the previously -* used storage space. -* - IF( CURLVL.EQ.TLVLS ) THEN - QPTR( CURR ) = 1 - PRMPTR( CURR ) = 1 - GIVPTR( CURR ) = 1 - END IF -* -* Sort and Deflate eigenvalues. -* - CALL DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, CUTPNT, - $ WORK( IZ ), WORK( IDLMDA ), WORK( IQ2 ), LDQ2, - $ WORK( IW ), PERM( PRMPTR( CURR ) ), GIVPTR( CURR+1 ), - $ GIVCOL( 1, GIVPTR( CURR ) ), - $ GIVNUM( 1, GIVPTR( CURR ) ), IWORK( INDXP ), - $ IWORK( INDX ), INFO ) - PRMPTR( CURR+1 ) = PRMPTR( CURR ) + N - GIVPTR( CURR+1 ) = GIVPTR( CURR+1 ) + GIVPTR( CURR ) -* -* Solve Secular Equation. -* - IF( K.NE.0 ) THEN - CALL DLAED9( K, 1, K, N, D, WORK( IS ), K, RHO, WORK( IDLMDA ), - $ WORK( IW ), QSTORE( QPTR( CURR ) ), K, INFO ) - IF( INFO.NE.0 ) - $ GO TO 30 - IF( ICOMPQ.EQ.1 ) THEN - CALL DGEMM( 'N', 'N', QSIZ, K, K, ONE, WORK( IQ2 ), LDQ2, - $ QSTORE( QPTR( CURR ) ), K, ZERO, Q, LDQ ) - END IF - QPTR( CURR+1 ) = QPTR( CURR ) + K**2 -* -* Prepare the INDXQ sorting permutation. -* - N1 = K - N2 = N - K - CALL DLAMRG( N1, N2, D, 1, -1, INDXQ ) - ELSE - QPTR( CURR+1 ) = QPTR( CURR ) - DO 20 I = 1, N - INDXQ( I ) = I - 20 CONTINUE - END IF -* - 30 CONTINUE - RETURN -* -* End of DLAED7 -* - END diff --git a/lib/linalg/dlaed8.cpp b/lib/linalg/dlaed8.cpp new file mode 100644 index 0000000000..46580ce44f --- /dev/null +++ b/lib/linalg/dlaed8.cpp @@ -0,0 +1,230 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static doublereal c_b3 = -1.; +static integer c__1 = 1; +int dlaed8_(integer *icompq, integer *k, integer *n, integer *qsiz, doublereal *d__, doublereal *q, + integer *ldq, integer *indxq, doublereal *rho, integer *cutpnt, doublereal *z__, + doublereal *dlamda, doublereal *q2, integer *ldq2, doublereal *w, integer *perm, + integer *givptr, integer *givcol, doublereal *givnum, integer *indxp, integer *indx, + integer *info) +{ + integer q_dim1, q_offset, q2_dim1, q2_offset, i__1; + doublereal d__1; + double sqrt(doublereal); + doublereal c__; + integer i__, j; + doublereal s, t; + integer k2, n1, n2, jp, n1p1; + doublereal eps, tau, tol; + integer jlam, imax, jmax; + extern int drot_(integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, + doublereal *), + dscal_(integer *, doublereal *, doublereal *, integer *), + dcopy_(integer *, doublereal *, integer *, doublereal *, integer *); + extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, ftnlen); + extern integer idamax_(integer *, doublereal *, integer *); + extern int dlamrg_(integer *, integer *, doublereal *, integer *, integer *, integer *), + 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; + --indxq; + --z__; + --dlamda; + q2_dim1 = *ldq2; + q2_offset = 1 + q2_dim1; + q2 -= q2_offset; + --w; + --perm; + givcol -= 3; + givnum -= 3; + --indxp; + --indx; + *info = 0; + if (*icompq < 0 || *icompq > 1) { + *info = -1; + } else if (*n < 0) { + *info = -3; + } else if (*icompq == 1 && *qsiz < *n) { + *info = -4; + } else if (*ldq < max(1, *n)) { + *info = -7; + } else if (*cutpnt < min(1, *n) || *cutpnt > *n) { + *info = -10; + } else if (*ldq2 < max(1, *n)) { + *info = -14; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DLAED8", &i__1, (ftnlen)6); + return 0; + } + *givptr = 0; + if (*n == 0) { + return 0; + } + n1 = *cutpnt; + n2 = *n - n1; + n1p1 = n1 + 1; + if (*rho < 0.) { + dscal_(&n2, &c_b3, &z__[n1p1], &c__1); + } + t = 1. / sqrt(2.); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + indx[j] = j; + } + dscal_(n, &t, &z__[1], &c__1); + *rho = (d__1 = *rho * 2., abs(d__1)); + i__1 = *n; + for (i__ = *cutpnt + 1; i__ <= i__1; ++i__) { + indxq[i__] += *cutpnt; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dlamda[i__] = d__[indxq[i__]]; + w[i__] = z__[indxq[i__]]; + } + i__ = 1; + j = *cutpnt + 1; + dlamrg_(&n1, &n2, &dlamda[1], &c__1, &c__1, &indx[1]); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = dlamda[indx[i__]]; + z__[i__] = w[indx[i__]]; + } + imax = idamax_(n, &z__[1], &c__1); + jmax = idamax_(n, &d__[1], &c__1); + eps = dlamch_((char *)"Epsilon", (ftnlen)7); + tol = eps * 8. * (d__1 = d__[jmax], abs(d__1)); + if (*rho * (d__1 = z__[imax], abs(d__1)) <= tol) { + *k = 0; + if (*icompq == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + perm[j] = indxq[indx[j]]; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + perm[j] = indxq[indx[j]]; + dcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1], &c__1); + } + dlacpy_((char *)"A", qsiz, n, &q2[q2_dim1 + 1], ldq2, &q[q_dim1 + 1], ldq, (ftnlen)1); + } + return 0; + } + *k = 0; + k2 = *n + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*rho * (d__1 = z__[j], abs(d__1)) <= tol) { + --k2; + indxp[k2] = j; + if (j == *n) { + goto L110; + } + } else { + jlam = j; + goto L80; + } + } +L80: + ++j; + if (j > *n) { + goto L100; + } + if (*rho * (d__1 = z__[j], abs(d__1)) <= tol) { + --k2; + indxp[k2] = j; + } else { + s = z__[jlam]; + c__ = z__[j]; + tau = dlapy2_(&c__, &s); + t = d__[j] - d__[jlam]; + c__ /= tau; + s = -s / tau; + if ((d__1 = t * c__ * s, abs(d__1)) <= tol) { + z__[j] = tau; + z__[jlam] = 0.; + ++(*givptr); + givcol[(*givptr << 1) + 1] = indxq[indx[jlam]]; + givcol[(*givptr << 1) + 2] = indxq[indx[j]]; + givnum[(*givptr << 1) + 1] = c__; + givnum[(*givptr << 1) + 2] = s; + if (*icompq == 1) { + drot_(qsiz, &q[indxq[indx[jlam]] * q_dim1 + 1], &c__1, + &q[indxq[indx[j]] * q_dim1 + 1], &c__1, &c__, &s); + } + t = d__[jlam] * c__ * c__ + d__[j] * s * s; + d__[j] = d__[jlam] * s * s + d__[j] * c__ * c__; + d__[jlam] = t; + --k2; + i__ = 1; + L90: + if (k2 + i__ <= *n) { + if (d__[jlam] < d__[indxp[k2 + i__]]) { + indxp[k2 + i__ - 1] = indxp[k2 + i__]; + indxp[k2 + i__] = jlam; + ++i__; + goto L90; + } else { + indxp[k2 + i__ - 1] = jlam; + } + } else { + indxp[k2 + i__ - 1] = jlam; + } + jlam = j; + } else { + ++(*k); + w[*k] = z__[jlam]; + dlamda[*k] = d__[jlam]; + indxp[*k] = jlam; + jlam = j; + } + } + goto L80; +L100: + ++(*k); + w[*k] = z__[jlam]; + dlamda[*k] = d__[jlam]; + indxp[*k] = jlam; +L110: + if (*icompq == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + jp = indxp[j]; + dlamda[j] = d__[jp]; + perm[j] = indxq[indx[jp]]; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + jp = indxp[j]; + dlamda[j] = d__[jp]; + perm[j] = indxq[indx[jp]]; + dcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1], &c__1); + } + } + if (*k < *n) { + if (*icompq == 0) { + i__1 = *n - *k; + dcopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1); + } else { + i__1 = *n - *k; + dcopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1); + i__1 = *n - *k; + dlacpy_((char *)"A", qsiz, &i__1, &q2[(*k + 1) * q2_dim1 + 1], ldq2, &q[(*k + 1) * q_dim1 + 1], + ldq, (ftnlen)1); + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlaed8.f b/lib/linalg/dlaed8.f deleted file mode 100644 index 3631fb4566..0000000000 --- a/lib/linalg/dlaed8.f +++ /dev/null @@ -1,521 +0,0 @@ -*> \brief \b DLAED8 used by DSTEDC. Merges eigenvalues and deflates secular equation. Used when the original matrix is dense. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAED8 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, -* CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR, -* GIVCOL, GIVNUM, INDXP, INDX, INFO ) -* -* .. Scalar Arguments .. -* INTEGER CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N, -* $ QSIZ -* DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. -* INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ), -* $ INDXQ( * ), PERM( * ) -* DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ), -* $ Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAED8 merges the two sets of eigenvalues together into a single -*> sorted set. Then it tries to deflate the size of the problem. -*> There are two ways in which deflation can occur: when two or more -*> eigenvalues are close together or if there is a tiny element in the -*> Z vector. For each such occurrence the order of the related secular -*> equation problem is reduced by one. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] ICOMPQ -*> \verbatim -*> ICOMPQ is INTEGER -*> = 0: Compute eigenvalues only. -*> = 1: Compute eigenvectors of original dense symmetric matrix -*> also. On entry, Q contains the orthogonal matrix used -*> to reduce the original matrix to tridiagonal form. -*> \endverbatim -*> -*> \param[out] K -*> \verbatim -*> K is INTEGER -*> The number of non-deflated eigenvalues, and the order of the -*> related secular equation. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The dimension of the symmetric tridiagonal matrix. N >= 0. -*> \endverbatim -*> -*> \param[in] QSIZ -*> \verbatim -*> QSIZ is INTEGER -*> The dimension of the orthogonal matrix used to reduce -*> the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, the eigenvalues of the two submatrices to be -*> combined. On exit, the trailing (N-K) updated eigenvalues -*> (those which were deflated) sorted into increasing order. -*> \endverbatim -*> -*> \param[in,out] Q -*> \verbatim -*> Q is DOUBLE PRECISION array, dimension (LDQ,N) -*> If ICOMPQ = 0, Q is not referenced. Otherwise, -*> on entry, Q contains the eigenvectors of the partially solved -*> system which has been previously updated in matrix -*> multiplies with other partially solved eigensystems. -*> On exit, Q contains the trailing (N-K) updated eigenvectors -*> (those which were deflated) in its last N-K columns. -*> \endverbatim -*> -*> \param[in] LDQ -*> \verbatim -*> LDQ is INTEGER -*> The leading dimension of the array Q. LDQ >= max(1,N). -*> \endverbatim -*> -*> \param[in] INDXQ -*> \verbatim -*> INDXQ is INTEGER array, dimension (N) -*> The permutation which separately sorts the two sub-problems -*> in D into ascending order. Note that elements in the second -*> half of this permutation must first have CUTPNT added to -*> their values in order to be accurate. -*> \endverbatim -*> -*> \param[in,out] RHO -*> \verbatim -*> RHO is DOUBLE PRECISION -*> On entry, the off-diagonal element associated with the rank-1 -*> cut which originally split the two submatrices which are now -*> being recombined. -*> On exit, RHO has been modified to the value required by -*> DLAED3. -*> \endverbatim -*> -*> \param[in] CUTPNT -*> \verbatim -*> CUTPNT is INTEGER -*> The location of the last eigenvalue in the leading -*> sub-matrix. min(1,N) <= CUTPNT <= N. -*> \endverbatim -*> -*> \param[in] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension (N) -*> On entry, Z contains the updating vector (the last row of -*> the first sub-eigenvector matrix and the first row of the -*> second sub-eigenvector matrix). -*> On exit, the contents of Z are destroyed by the updating -*> process. -*> \endverbatim -*> -*> \param[out] DLAMDA -*> \verbatim -*> DLAMDA is DOUBLE PRECISION array, dimension (N) -*> A copy of the first K eigenvalues which will be used by -*> DLAED3 to form the secular equation. -*> \endverbatim -*> -*> \param[out] Q2 -*> \verbatim -*> Q2 is DOUBLE PRECISION array, dimension (LDQ2,N) -*> If ICOMPQ = 0, Q2 is not referenced. Otherwise, -*> a copy of the first K eigenvectors which will be used by -*> DLAED7 in a matrix multiply (DGEMM) to update the new -*> eigenvectors. -*> \endverbatim -*> -*> \param[in] LDQ2 -*> \verbatim -*> LDQ2 is INTEGER -*> The leading dimension of the array Q2. LDQ2 >= max(1,N). -*> \endverbatim -*> -*> \param[out] W -*> \verbatim -*> W is DOUBLE PRECISION array, dimension (N) -*> The first k values of the final deflation-altered z-vector and -*> will be passed to DLAED3. -*> \endverbatim -*> -*> \param[out] PERM -*> \verbatim -*> PERM is INTEGER array, dimension (N) -*> The permutations (from deflation and sorting) to be applied -*> to each eigenblock. -*> \endverbatim -*> -*> \param[out] GIVPTR -*> \verbatim -*> GIVPTR is INTEGER -*> The number of Givens rotations which took place in this -*> subproblem. -*> \endverbatim -*> -*> \param[out] GIVCOL -*> \verbatim -*> GIVCOL is INTEGER array, dimension (2, N) -*> Each pair of numbers indicates a pair of columns to take place -*> in a Givens rotation. -*> \endverbatim -*> -*> \param[out] GIVNUM -*> \verbatim -*> GIVNUM is DOUBLE PRECISION array, dimension (2, N) -*> Each number indicates the S value to be used in the -*> corresponding Givens rotation. -*> \endverbatim -*> -*> \param[out] INDXP -*> \verbatim -*> INDXP is INTEGER array, dimension (N) -*> The permutation used to place deflated values of D at the end -*> of the array. INDXP(1:K) points to the nondeflated D-values -*> and INDXP(K+1:N) points to the deflated eigenvalues. -*> \endverbatim -*> -*> \param[out] INDX -*> \verbatim -*> INDX is INTEGER array, dimension (N) -*> The permutation used to sort the contents of D into ascending -*> order. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit. -*> < 0: if INFO = -i, the i-th argument had an illegal value. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -*> \par Contributors: -* ================== -*> -*> Jeff Rutter, Computer Science Division, University of California -*> at Berkeley, USA -* -* ===================================================================== - SUBROUTINE DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, - $ CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR, - $ GIVCOL, GIVNUM, INDXP, INDX, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N, - $ QSIZ - DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. - INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ), - $ INDXQ( * ), PERM( * ) - DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ), - $ Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT - PARAMETER ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0, - $ TWO = 2.0D0, EIGHT = 8.0D0 ) -* .. -* .. Local Scalars .. -* - INTEGER I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2 - DOUBLE PRECISION C, EPS, S, T, TAU, TOL -* .. -* .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH, DLAPY2 - EXTERNAL IDAMAX, DLAMCH, DLAPY2 -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DLACPY, DLAMRG, DROT, DSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN - INFO = -4 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN - INFO = -10 - ELSE IF( LDQ2.LT.MAX( 1, N ) ) THEN - INFO = -14 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLAED8', -INFO ) - RETURN - END IF -* -* Need to initialize GIVPTR to O here in case of quick exit -* to prevent an unspecified code behavior (usually sigfault) -* when IWORK array on entry to *stedc is not zeroed -* (or at least some IWORK entries which used in *laed7 for GIVPTR). -* - GIVPTR = 0 -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - N1 = CUTPNT - N2 = N - N1 - N1P1 = N1 + 1 -* - IF( RHO.LT.ZERO ) THEN - CALL DSCAL( N2, MONE, Z( N1P1 ), 1 ) - END IF -* -* Normalize z so that norm(z) = 1 -* - T = ONE / SQRT( TWO ) - DO 10 J = 1, N - INDX( J ) = J - 10 CONTINUE - CALL DSCAL( N, T, Z, 1 ) - RHO = ABS( TWO*RHO ) -* -* Sort the eigenvalues into increasing order -* - DO 20 I = CUTPNT + 1, N - INDXQ( I ) = INDXQ( I ) + CUTPNT - 20 CONTINUE - DO 30 I = 1, N - DLAMDA( I ) = D( INDXQ( I ) ) - W( I ) = Z( INDXQ( I ) ) - 30 CONTINUE - I = 1 - J = CUTPNT + 1 - CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDX ) - DO 40 I = 1, N - D( I ) = DLAMDA( INDX( I ) ) - Z( I ) = W( INDX( I ) ) - 40 CONTINUE -* -* Calculate the allowable deflation tolerance -* - IMAX = IDAMAX( N, Z, 1 ) - JMAX = IDAMAX( N, D, 1 ) - EPS = DLAMCH( 'Epsilon' ) - TOL = EIGHT*EPS*ABS( D( JMAX ) ) -* -* If the rank-1 modifier is small enough, no more needs to be done -* except to reorganize Q so that its columns correspond with the -* elements in D. -* - IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN - K = 0 - IF( ICOMPQ.EQ.0 ) THEN - DO 50 J = 1, N - PERM( J ) = INDXQ( INDX( J ) ) - 50 CONTINUE - ELSE - DO 60 J = 1, N - PERM( J ) = INDXQ( INDX( J ) ) - CALL DCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 ) - 60 CONTINUE - CALL DLACPY( 'A', QSIZ, N, Q2( 1, 1 ), LDQ2, Q( 1, 1 ), - $ LDQ ) - END IF - RETURN - END IF -* -* If there are multiple eigenvalues then the problem deflates. Here -* the number of equal eigenvalues are found. As each equal -* eigenvalue is found, an elementary reflector is computed to rotate -* the corresponding eigensubspace so that the corresponding -* components of Z are zero in this new basis. -* - K = 0 - K2 = N + 1 - DO 70 J = 1, N - IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN -* -* Deflate due to small z component. -* - K2 = K2 - 1 - INDXP( K2 ) = J - IF( J.EQ.N ) - $ GO TO 110 - ELSE - JLAM = J - GO TO 80 - END IF - 70 CONTINUE - 80 CONTINUE - J = J + 1 - IF( J.GT.N ) - $ GO TO 100 - IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN -* -* Deflate due to small z component. -* - K2 = K2 - 1 - INDXP( K2 ) = J - ELSE -* -* Check if eigenvalues are close enough to allow deflation. -* - S = Z( JLAM ) - C = Z( J ) -* -* Find sqrt(a**2+b**2) without overflow or -* destructive underflow. -* - TAU = DLAPY2( C, S ) - T = D( J ) - D( JLAM ) - C = C / TAU - S = -S / TAU - IF( ABS( T*C*S ).LE.TOL ) THEN -* -* Deflation is possible. -* - Z( J ) = TAU - Z( JLAM ) = ZERO -* -* Record the appropriate Givens rotation -* - GIVPTR = GIVPTR + 1 - GIVCOL( 1, GIVPTR ) = INDXQ( INDX( JLAM ) ) - GIVCOL( 2, GIVPTR ) = INDXQ( INDX( J ) ) - GIVNUM( 1, GIVPTR ) = C - GIVNUM( 2, GIVPTR ) = S - IF( ICOMPQ.EQ.1 ) THEN - CALL DROT( QSIZ, Q( 1, INDXQ( INDX( JLAM ) ) ), 1, - $ Q( 1, INDXQ( INDX( J ) ) ), 1, C, S ) - END IF - T = D( JLAM )*C*C + D( J )*S*S - D( J ) = D( JLAM )*S*S + D( J )*C*C - D( JLAM ) = T - K2 = K2 - 1 - I = 1 - 90 CONTINUE - IF( K2+I.LE.N ) THEN - IF( D( JLAM ).LT.D( INDXP( K2+I ) ) ) THEN - INDXP( K2+I-1 ) = INDXP( K2+I ) - INDXP( K2+I ) = JLAM - I = I + 1 - GO TO 90 - ELSE - INDXP( K2+I-1 ) = JLAM - END IF - ELSE - INDXP( K2+I-1 ) = JLAM - END IF - JLAM = J - ELSE - K = K + 1 - W( K ) = Z( JLAM ) - DLAMDA( K ) = D( JLAM ) - INDXP( K ) = JLAM - JLAM = J - END IF - END IF - GO TO 80 - 100 CONTINUE -* -* Record the last eigenvalue. -* - K = K + 1 - W( K ) = Z( JLAM ) - DLAMDA( K ) = D( JLAM ) - INDXP( K ) = JLAM -* - 110 CONTINUE -* -* Sort the eigenvalues and corresponding eigenvectors into DLAMDA -* and Q2 respectively. The eigenvalues/vectors which were not -* deflated go into the first K slots of DLAMDA and Q2 respectively, -* while those which were deflated go into the last N - K slots. -* - IF( ICOMPQ.EQ.0 ) THEN - DO 120 J = 1, N - JP = INDXP( J ) - DLAMDA( J ) = D( JP ) - PERM( J ) = INDXQ( INDX( JP ) ) - 120 CONTINUE - ELSE - DO 130 J = 1, N - JP = INDXP( J ) - DLAMDA( J ) = D( JP ) - PERM( J ) = INDXQ( INDX( JP ) ) - CALL DCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 ) - 130 CONTINUE - END IF -* -* The deflated eigenvalues and their corresponding vectors go back -* into the last N - K slots of D and Q respectively. -* - IF( K.LT.N ) THEN - IF( ICOMPQ.EQ.0 ) THEN - CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 ) - ELSE - CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 ) - CALL DLACPY( 'A', QSIZ, N-K, Q2( 1, K+1 ), LDQ2, - $ Q( 1, K+1 ), LDQ ) - END IF - END IF -* - RETURN -* -* End of DLAED8 -* - END diff --git a/lib/linalg/dlaed9.cpp b/lib/linalg/dlaed9.cpp new file mode 100644 index 0000000000..2ca15ee0d7 --- /dev/null +++ b/lib/linalg/dlaed9.cpp @@ -0,0 +1,109 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +int dlaed9_(integer *k, integer *kstart, integer *kstop, integer *n, doublereal *d__, doublereal *q, + integer *ldq, doublereal *rho, doublereal *dlamda, doublereal *w, doublereal *s, + integer *lds, integer *info) +{ + integer q_dim1, q_offset, s_dim1, s_offset, i__1, i__2; + doublereal d__1; + double sqrt(doublereal), d_lmp_sign(doublereal *, doublereal *); + integer i__, j; + doublereal temp; + extern doublereal dnrm2_(integer *, doublereal *, integer *); + extern int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *), + dlaed4_(integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *); + extern doublereal dlamc3_(doublereal *, doublereal *); + extern int xerbla_(char *, integer *, ftnlen); + --d__; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + --dlamda; + --w; + s_dim1 = *lds; + s_offset = 1 + s_dim1; + s -= s_offset; + *info = 0; + if (*k < 0) { + *info = -1; + } else if (*kstart < 1 || *kstart > max(1, *k)) { + *info = -2; + } else if (max(1, *kstop) < *kstart || *kstop > max(1, *k)) { + *info = -3; + } else if (*n < *k) { + *info = -4; + } else if (*ldq < max(1, *k)) { + *info = -7; + } else if (*lds < max(1, *k)) { + *info = -12; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DLAED9", &i__1, (ftnlen)6); + return 0; + } + if (*k == 0) { + return 0; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dlamda[i__] = dlamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__]; + } + i__1 = *kstop; + for (j = *kstart; j <= i__1; ++j) { + dlaed4_(k, &j, &dlamda[1], &w[1], &q[j * q_dim1 + 1], rho, &d__[j], info); + if (*info != 0) { + goto L120; + } + } + if (*k == 1 || *k == 2) { + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *k; + for (j = 1; j <= i__2; ++j) { + s[j + i__ * s_dim1] = q[j + i__ * q_dim1]; + } + } + goto L120; + } + dcopy_(k, &w[1], &c__1, &s[s_offset], &c__1); + i__1 = *ldq + 1; + dcopy_(k, &q[q_offset], &i__1, &w[1], &c__1); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]); + } + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]); + } + } + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + d__1 = sqrt(-w[i__]); + w[i__] = d_lmp_sign(&d__1, &s[i__ + s_dim1]); + } + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + q[i__ + j * q_dim1] = w[i__] / q[i__ + j * q_dim1]; + } + temp = dnrm2_(k, &q[j * q_dim1 + 1], &c__1); + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + s[i__ + j * s_dim1] = q[i__ + j * q_dim1] / temp; + } + } +L120: + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlaed9.f b/lib/linalg/dlaed9.f deleted file mode 100644 index b88cdd9077..0000000000 --- a/lib/linalg/dlaed9.f +++ /dev/null @@ -1,291 +0,0 @@ -*> \brief \b DLAED9 used by DSTEDC. Finds the roots of the secular equation and updates the eigenvectors. Used when the original matrix is dense. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAED9 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W, -* S, LDS, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N -* DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. -* DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ), -* $ W( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAED9 finds the roots of the secular equation, as defined by the -*> values in D, Z, and RHO, between KSTART and KSTOP. It makes the -*> appropriate calls to DLAED4 and then stores the new matrix of -*> eigenvectors for use in calculating the next level of Z vectors. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of terms in the rational function to be solved by -*> DLAED4. K >= 0. -*> \endverbatim -*> -*> \param[in] KSTART -*> \verbatim -*> KSTART is INTEGER -*> \endverbatim -*> -*> \param[in] KSTOP -*> \verbatim -*> KSTOP is INTEGER -*> The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP -*> are to be computed. 1 <= KSTART <= KSTOP <= K. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of rows and columns in the Q matrix. -*> N >= K (delation may result in N > K). -*> \endverbatim -*> -*> \param[out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> D(I) contains the updated eigenvalues -*> for KSTART <= I <= KSTOP. -*> \endverbatim -*> -*> \param[out] Q -*> \verbatim -*> Q is DOUBLE PRECISION array, dimension (LDQ,N) -*> \endverbatim -*> -*> \param[in] LDQ -*> \verbatim -*> LDQ is INTEGER -*> The leading dimension of the array Q. LDQ >= max( 1, N ). -*> \endverbatim -*> -*> \param[in] RHO -*> \verbatim -*> RHO is DOUBLE PRECISION -*> The value of the parameter in the rank one update equation. -*> RHO >= 0 required. -*> \endverbatim -*> -*> \param[in] DLAMDA -*> \verbatim -*> DLAMDA is DOUBLE PRECISION array, dimension (K) -*> The first K elements of this array contain the old roots -*> of the deflated updating problem. These are the poles -*> of the secular equation. -*> \endverbatim -*> -*> \param[in] W -*> \verbatim -*> W is DOUBLE PRECISION array, dimension (K) -*> The first K elements of this array contain the components -*> of the deflation-adjusted updating vector. -*> \endverbatim -*> -*> \param[out] S -*> \verbatim -*> S is DOUBLE PRECISION array, dimension (LDS, K) -*> Will contain the eigenvectors of the repaired matrix which -*> will be stored for subsequent Z vector calculation and -*> multiplied by the previously accumulated eigenvectors -*> to update the system. -*> \endverbatim -*> -*> \param[in] LDS -*> \verbatim -*> LDS is INTEGER -*> The leading dimension of S. LDS >= max( 1, K ). -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit. -*> < 0: if INFO = -i, the i-th argument had an illegal value. -*> > 0: if INFO = 1, an eigenvalue did not converge -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -*> \par Contributors: -* ================== -*> -*> Jeff Rutter, Computer Science Division, University of California -*> at Berkeley, USA -* -* ===================================================================== - SUBROUTINE DLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W, - $ S, LDS, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N - DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ), - $ W( * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, J - DOUBLE PRECISION TEMP -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMC3, DNRM2 - EXTERNAL DLAMC3, DNRM2 -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DLAED4, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, SIGN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( K.LT.0 ) THEN - INFO = -1 - ELSE IF( KSTART.LT.1 .OR. KSTART.GT.MAX( 1, K ) ) THEN - INFO = -2 - ELSE IF( MAX( 1, KSTOP ).LT.KSTART .OR. KSTOP.GT.MAX( 1, K ) ) - $ THEN - INFO = -3 - ELSE IF( N.LT.K ) THEN - INFO = -4 - ELSE IF( LDQ.LT.MAX( 1, K ) ) THEN - INFO = -7 - ELSE IF( LDS.LT.MAX( 1, K ) ) THEN - INFO = -12 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLAED9', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( K.EQ.0 ) - $ RETURN -* -* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can -* be computed with high relative accuracy (barring over/underflow). -* This is a problem on machines without a guard digit in -* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). -* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), -* which on any of these machines zeros out the bottommost -* bit of DLAMDA(I) if it is 1; this makes the subsequent -* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation -* occurs. On binary machines with a guard digit (almost all -* machines) it does not change DLAMDA(I) at all. On hexadecimal -* and decimal machines with a guard digit, it slightly -* changes the bottommost bits of DLAMDA(I). It does not account -* for hexadecimal or decimal machines without guard digits -* (we know of none). We use a subroutine call to compute -* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating -* this code. -* - DO 10 I = 1, N - DLAMDA( I ) = DLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I ) - 10 CONTINUE -* - DO 20 J = KSTART, KSTOP - CALL DLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO ) -* -* If the zero finder fails, the computation is terminated. -* - IF( INFO.NE.0 ) - $ GO TO 120 - 20 CONTINUE -* - IF( K.EQ.1 .OR. K.EQ.2 ) THEN - DO 40 I = 1, K - DO 30 J = 1, K - S( J, I ) = Q( J, I ) - 30 CONTINUE - 40 CONTINUE - GO TO 120 - END IF -* -* Compute updated W. -* - CALL DCOPY( K, W, 1, S, 1 ) -* -* Initialize W(I) = Q(I,I) -* - CALL DCOPY( K, Q, LDQ+1, W, 1 ) - DO 70 J = 1, K - DO 50 I = 1, J - 1 - W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) ) - 50 CONTINUE - DO 60 I = J + 1, K - W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) ) - 60 CONTINUE - 70 CONTINUE - DO 80 I = 1, K - W( I ) = SIGN( SQRT( -W( I ) ), S( I, 1 ) ) - 80 CONTINUE -* -* Compute eigenvectors of the modified rank-1 modification. -* - DO 110 J = 1, K - DO 90 I = 1, K - Q( I, J ) = W( I ) / Q( I, J ) - 90 CONTINUE - TEMP = DNRM2( K, Q( 1, J ), 1 ) - DO 100 I = 1, K - S( I, J ) = Q( I, J ) / TEMP - 100 CONTINUE - 110 CONTINUE -* - 120 CONTINUE - RETURN -* -* End of DLAED9 -* - END diff --git a/lib/linalg/dlaeda.cpp b/lib/linalg/dlaeda.cpp new file mode 100644 index 0000000000..32ab3718a3 --- /dev/null +++ b/lib/linalg/dlaeda.cpp @@ -0,0 +1,113 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__2 = 2; +static integer c__1 = 1; +static doublereal c_b24 = 1.; +static doublereal c_b26 = 0.; +int dlaeda_(integer *n, integer *tlvls, integer *curlvl, integer *curpbm, integer *prmptr, + integer *perm, integer *givptr, integer *givcol, doublereal *givnum, doublereal *q, + integer *qptr, doublereal *z__, doublereal *ztemp, integer *info) +{ + integer i__1, i__2, i__3; + integer pow_lmp_ii(integer *, integer *); + double sqrt(doublereal); + integer i__, k, mid, ptr; + extern int drot_(integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, + doublereal *); + integer curr, bsiz1, bsiz2, psiz1, psiz2, zptr1; + extern int dgemv_(char *, integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, ftnlen), + dcopy_(integer *, doublereal *, integer *, doublereal *, integer *), + xerbla_(char *, integer *, ftnlen); + --ztemp; + --z__; + --qptr; + --q; + givnum -= 3; + givcol -= 3; + --givptr; + --perm; + --prmptr; + *info = 0; + if (*n < 0) { + *info = -1; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DLAEDA", &i__1, (ftnlen)6); + return 0; + } + if (*n == 0) { + return 0; + } + mid = *n / 2 + 1; + ptr = 1; + i__1 = *curlvl - 1; + curr = ptr + *curpbm * pow_lmp_ii(&c__2, curlvl) + pow_lmp_ii(&c__2, &i__1) - 1; + bsiz1 = (integer)(sqrt((doublereal)(qptr[curr + 1] - qptr[curr])) + .5); + bsiz2 = (integer)(sqrt((doublereal)(qptr[curr + 2] - qptr[curr + 1])) + .5); + i__1 = mid - bsiz1 - 1; + for (k = 1; k <= i__1; ++k) { + z__[k] = 0.; + } + dcopy_(&bsiz1, &q[qptr[curr] + bsiz1 - 1], &bsiz1, &z__[mid - bsiz1], &c__1); + dcopy_(&bsiz2, &q[qptr[curr + 1]], &bsiz2, &z__[mid], &c__1); + i__1 = *n; + for (k = mid + bsiz2; k <= i__1; ++k) { + z__[k] = 0.; + } + ptr = pow_lmp_ii(&c__2, tlvls) + 1; + i__1 = *curlvl - 1; + for (k = 1; k <= i__1; ++k) { + i__2 = *curlvl - k; + i__3 = *curlvl - k - 1; + curr = ptr + *curpbm * pow_lmp_ii(&c__2, &i__2) + pow_lmp_ii(&c__2, &i__3) - 1; + psiz1 = prmptr[curr + 1] - prmptr[curr]; + psiz2 = prmptr[curr + 2] - prmptr[curr + 1]; + zptr1 = mid - psiz1; + i__2 = givptr[curr + 1] - 1; + for (i__ = givptr[curr]; i__ <= i__2; ++i__) { + drot_(&c__1, &z__[zptr1 + givcol[(i__ << 1) + 1] - 1], &c__1, + &z__[zptr1 + givcol[(i__ << 1) + 2] - 1], &c__1, &givnum[(i__ << 1) + 1], + &givnum[(i__ << 1) + 2]); + } + i__2 = givptr[curr + 2] - 1; + for (i__ = givptr[curr + 1]; i__ <= i__2; ++i__) { + drot_(&c__1, &z__[mid - 1 + givcol[(i__ << 1) + 1]], &c__1, + &z__[mid - 1 + givcol[(i__ << 1) + 2]], &c__1, &givnum[(i__ << 1) + 1], + &givnum[(i__ << 1) + 2]); + } + psiz1 = prmptr[curr + 1] - prmptr[curr]; + psiz2 = prmptr[curr + 2] - prmptr[curr + 1]; + i__2 = psiz1 - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + ztemp[i__ + 1] = z__[zptr1 + perm[prmptr[curr] + i__] - 1]; + } + i__2 = psiz2 - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + ztemp[psiz1 + i__ + 1] = z__[mid + perm[prmptr[curr + 1] + i__] - 1]; + } + bsiz1 = (integer)(sqrt((doublereal)(qptr[curr + 1] - qptr[curr])) + .5); + bsiz2 = (integer)(sqrt((doublereal)(qptr[curr + 2] - qptr[curr + 1])) + .5); + if (bsiz1 > 0) { + dgemv_((char *)"T", &bsiz1, &bsiz1, &c_b24, &q[qptr[curr]], &bsiz1, &ztemp[1], &c__1, &c_b26, + &z__[zptr1], &c__1, (ftnlen)1); + } + i__2 = psiz1 - bsiz1; + dcopy_(&i__2, &ztemp[bsiz1 + 1], &c__1, &z__[zptr1 + bsiz1], &c__1); + if (bsiz2 > 0) { + dgemv_((char *)"T", &bsiz2, &bsiz2, &c_b24, &q[qptr[curr + 1]], &bsiz2, &ztemp[psiz1 + 1], + &c__1, &c_b26, &z__[mid], &c__1, (ftnlen)1); + } + i__2 = psiz2 - bsiz2; + dcopy_(&i__2, &ztemp[psiz1 + bsiz2 + 1], &c__1, &z__[mid + bsiz2], &c__1); + i__2 = *tlvls - k; + ptr += pow_lmp_ii(&c__2, &i__2); + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlaeda.f b/lib/linalg/dlaeda.f deleted file mode 100644 index 8864fd7f2a..0000000000 --- a/lib/linalg/dlaeda.f +++ /dev/null @@ -1,305 +0,0 @@ -*> \brief \b DLAEDA used by DSTEDC. Computes the Z vector determining the rank-one modification of the diagonal matrix. Used when the original matrix is dense. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAEDA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, -* GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO ) -* -* .. Scalar Arguments .. -* INTEGER CURLVL, CURPBM, INFO, N, TLVLS -* .. -* .. Array Arguments .. -* INTEGER GIVCOL( 2, * ), GIVPTR( * ), PERM( * ), -* $ PRMPTR( * ), QPTR( * ) -* DOUBLE PRECISION GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAEDA computes the Z vector corresponding to the merge step in the -*> CURLVLth step of the merge process with TLVLS steps for the CURPBMth -*> problem. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The dimension of the symmetric tridiagonal matrix. N >= 0. -*> \endverbatim -*> -*> \param[in] TLVLS -*> \verbatim -*> TLVLS is INTEGER -*> The total number of merging levels in the overall divide and -*> conquer tree. -*> \endverbatim -*> -*> \param[in] CURLVL -*> \verbatim -*> CURLVL is INTEGER -*> The current level in the overall merge routine, -*> 0 <= curlvl <= tlvls. -*> \endverbatim -*> -*> \param[in] CURPBM -*> \verbatim -*> CURPBM is INTEGER -*> The current problem in the current level in the overall -*> merge routine (counting from upper left to lower right). -*> \endverbatim -*> -*> \param[in] PRMPTR -*> \verbatim -*> PRMPTR is INTEGER array, dimension (N lg N) -*> Contains a list of pointers which indicate where in PERM a -*> level's permutation is stored. PRMPTR(i+1) - PRMPTR(i) -*> indicates the size of the permutation and incidentally the -*> size of the full, non-deflated problem. -*> \endverbatim -*> -*> \param[in] PERM -*> \verbatim -*> PERM is INTEGER array, dimension (N lg N) -*> Contains the permutations (from deflation and sorting) to be -*> applied to each eigenblock. -*> \endverbatim -*> -*> \param[in] GIVPTR -*> \verbatim -*> GIVPTR is INTEGER array, dimension (N lg N) -*> Contains a list of pointers which indicate where in GIVCOL a -*> level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i) -*> indicates the number of Givens rotations. -*> \endverbatim -*> -*> \param[in] GIVCOL -*> \verbatim -*> GIVCOL is INTEGER array, dimension (2, N lg N) -*> Each pair of numbers indicates a pair of columns to take place -*> in a Givens rotation. -*> \endverbatim -*> -*> \param[in] GIVNUM -*> \verbatim -*> GIVNUM is DOUBLE PRECISION array, dimension (2, N lg N) -*> Each number indicates the S value to be used in the -*> corresponding Givens rotation. -*> \endverbatim -*> -*> \param[in] Q -*> \verbatim -*> Q is DOUBLE PRECISION array, dimension (N**2) -*> Contains the square eigenblocks from previous levels, the -*> starting positions for blocks are given by QPTR. -*> \endverbatim -*> -*> \param[in] QPTR -*> \verbatim -*> QPTR is INTEGER array, dimension (N+2) -*> Contains a list of pointers which indicate where in Q an -*> eigenblock is stored. SQRT( QPTR(i+1) - QPTR(i) ) indicates -*> the size of the block. -*> \endverbatim -*> -*> \param[out] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension (N) -*> On output this vector contains the updating vector (the last -*> row of the first sub-eigenvector matrix and the first row of -*> the second sub-eigenvector matrix). -*> \endverbatim -*> -*> \param[out] ZTEMP -*> \verbatim -*> ZTEMP is DOUBLE PRECISION array, dimension (N) -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit. -*> < 0: if INFO = -i, the i-th argument had an illegal value. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -*> \par Contributors: -* ================== -*> -*> Jeff Rutter, Computer Science Division, University of California -*> at Berkeley, USA -* -* ===================================================================== - SUBROUTINE DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, - $ GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER CURLVL, CURPBM, INFO, N, TLVLS -* .. -* .. Array Arguments .. - INTEGER GIVCOL( 2, * ), GIVPTR( * ), PERM( * ), - $ PRMPTR( * ), QPTR( * ) - DOUBLE PRECISION GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - INTEGER BSIZ1, BSIZ2, CURR, I, K, MID, PSIZ1, PSIZ2, - $ PTR, ZPTR1 -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DGEMV, DROT, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, INT, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( N.LT.0 ) THEN - INFO = -1 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLAEDA', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Determine location of first number in second half. -* - MID = N / 2 + 1 -* -* Gather last/first rows of appropriate eigenblocks into center of Z -* - PTR = 1 -* -* Determine location of lowest level subproblem in the full storage -* scheme -* - CURR = PTR + CURPBM*2**CURLVL + 2**( CURLVL-1 ) - 1 -* -* Determine size of these matrices. We add HALF to the value of -* the SQRT in case the machine underestimates one of these square -* roots. -* - BSIZ1 = INT( HALF+SQRT( DBLE( QPTR( CURR+1 )-QPTR( CURR ) ) ) ) - BSIZ2 = INT( HALF+SQRT( DBLE( QPTR( CURR+2 )-QPTR( CURR+1 ) ) ) ) - DO 10 K = 1, MID - BSIZ1 - 1 - Z( K ) = ZERO - 10 CONTINUE - CALL DCOPY( BSIZ1, Q( QPTR( CURR )+BSIZ1-1 ), BSIZ1, - $ Z( MID-BSIZ1 ), 1 ) - CALL DCOPY( BSIZ2, Q( QPTR( CURR+1 ) ), BSIZ2, Z( MID ), 1 ) - DO 20 K = MID + BSIZ2, N - Z( K ) = ZERO - 20 CONTINUE -* -* Loop through remaining levels 1 -> CURLVL applying the Givens -* rotations and permutation and then multiplying the center matrices -* against the current Z. -* - PTR = 2**TLVLS + 1 - DO 70 K = 1, CURLVL - 1 - CURR = PTR + CURPBM*2**( CURLVL-K ) + 2**( CURLVL-K-1 ) - 1 - PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR ) - PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 ) - ZPTR1 = MID - PSIZ1 -* -* Apply Givens at CURR and CURR+1 -* - DO 30 I = GIVPTR( CURR ), GIVPTR( CURR+1 ) - 1 - CALL DROT( 1, Z( ZPTR1+GIVCOL( 1, I )-1 ), 1, - $ Z( ZPTR1+GIVCOL( 2, I )-1 ), 1, GIVNUM( 1, I ), - $ GIVNUM( 2, I ) ) - 30 CONTINUE - DO 40 I = GIVPTR( CURR+1 ), GIVPTR( CURR+2 ) - 1 - CALL DROT( 1, Z( MID-1+GIVCOL( 1, I ) ), 1, - $ Z( MID-1+GIVCOL( 2, I ) ), 1, GIVNUM( 1, I ), - $ GIVNUM( 2, I ) ) - 40 CONTINUE - PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR ) - PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 ) - DO 50 I = 0, PSIZ1 - 1 - ZTEMP( I+1 ) = Z( ZPTR1+PERM( PRMPTR( CURR )+I )-1 ) - 50 CONTINUE - DO 60 I = 0, PSIZ2 - 1 - ZTEMP( PSIZ1+I+1 ) = Z( MID+PERM( PRMPTR( CURR+1 )+I )-1 ) - 60 CONTINUE -* -* Multiply Blocks at CURR and CURR+1 -* -* Determine size of these matrices. We add HALF to the value of -* the SQRT in case the machine underestimates one of these -* square roots. -* - BSIZ1 = INT( HALF+SQRT( DBLE( QPTR( CURR+1 )-QPTR( CURR ) ) ) ) - BSIZ2 = INT( HALF+SQRT( DBLE( QPTR( CURR+2 )-QPTR( CURR+ - $ 1 ) ) ) ) - IF( BSIZ1.GT.0 ) THEN - CALL DGEMV( 'T', BSIZ1, BSIZ1, ONE, Q( QPTR( CURR ) ), - $ BSIZ1, ZTEMP( 1 ), 1, ZERO, Z( ZPTR1 ), 1 ) - END IF - CALL DCOPY( PSIZ1-BSIZ1, ZTEMP( BSIZ1+1 ), 1, Z( ZPTR1+BSIZ1 ), - $ 1 ) - IF( BSIZ2.GT.0 ) THEN - CALL DGEMV( 'T', BSIZ2, BSIZ2, ONE, Q( QPTR( CURR+1 ) ), - $ BSIZ2, ZTEMP( PSIZ1+1 ), 1, ZERO, Z( MID ), 1 ) - END IF - CALL DCOPY( PSIZ2-BSIZ2, ZTEMP( PSIZ1+BSIZ2+1 ), 1, - $ Z( MID+BSIZ2 ), 1 ) -* - PTR = PTR + 2**( TLVLS-K ) - 70 CONTINUE -* - RETURN -* -* End of DLAEDA -* - END diff --git a/lib/linalg/dlaev2.cpp b/lib/linalg/dlaev2.cpp new file mode 100644 index 0000000000..454b0b9c40 --- /dev/null +++ b/lib/linalg/dlaev2.cpp @@ -0,0 +1,78 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dlaev2_(doublereal *a, doublereal *b, doublereal *c__, doublereal *rt1, doublereal *rt2, + doublereal *cs1, doublereal *sn1) +{ + doublereal d__1; + double sqrt(doublereal); + doublereal ab, df, cs, ct, tb, sm, tn, rt, adf, acs; + integer sgn1, sgn2; + doublereal acmn, acmx; + sm = *a + *c__; + df = *a - *c__; + adf = abs(df); + tb = *b + *b; + ab = abs(tb); + if (abs(*a) > abs(*c__)) { + acmx = *a; + acmn = *c__; + } else { + acmx = *c__; + acmn = *a; + } + if (adf > ab) { + d__1 = ab / adf; + rt = adf * sqrt(d__1 * d__1 + 1.); + } else if (adf < ab) { + d__1 = adf / ab; + rt = ab * sqrt(d__1 * d__1 + 1.); + } else { + rt = ab * sqrt(2.); + } + if (sm < 0.) { + *rt1 = (sm - rt) * .5; + sgn1 = -1; + *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; + } else if (sm > 0.) { + *rt1 = (sm + rt) * .5; + sgn1 = 1; + *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; + } else { + *rt1 = rt * .5; + *rt2 = rt * -.5; + sgn1 = 1; + } + if (df >= 0.) { + cs = df + rt; + sgn2 = 1; + } else { + cs = df - rt; + sgn2 = -1; + } + acs = abs(cs); + if (acs > ab) { + ct = -tb / cs; + *sn1 = 1. / sqrt(ct * ct + 1.); + *cs1 = ct * *sn1; + } else { + if (ab == 0.) { + *cs1 = 1.; + *sn1 = 0.; + } else { + tn = -cs / tb; + *cs1 = 1. / sqrt(tn * tn + 1.); + *sn1 = tn * *cs1; + } + } + if (sgn1 == sgn2) { + tn = *cs1; + *cs1 = -(*sn1); + *sn1 = tn; + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlaev2.f b/lib/linalg/dlaev2.f deleted file mode 100644 index 9e29991a6d..0000000000 --- a/lib/linalg/dlaev2.f +++ /dev/null @@ -1,235 +0,0 @@ -*> \brief \b DLAEV2 computes the eigenvalues and eigenvectors of a 2-by-2 symmetric/Hermitian matrix. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAEV2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1 -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix -*> [ A B ] -*> [ B C ]. -*> On return, RT1 is the eigenvalue of larger absolute value, RT2 is the -*> eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right -*> eigenvector for RT1, giving the decomposition -*> -*> [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ] -*> [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION -*> The (1,1) element of the 2-by-2 matrix. -*> \endverbatim -*> -*> \param[in] B -*> \verbatim -*> B is DOUBLE PRECISION -*> The (1,2) element and the conjugate of the (2,1) element of -*> the 2-by-2 matrix. -*> \endverbatim -*> -*> \param[in] C -*> \verbatim -*> C is DOUBLE PRECISION -*> The (2,2) element of the 2-by-2 matrix. -*> \endverbatim -*> -*> \param[out] RT1 -*> \verbatim -*> RT1 is DOUBLE PRECISION -*> The eigenvalue of larger absolute value. -*> \endverbatim -*> -*> \param[out] RT2 -*> \verbatim -*> RT2 is DOUBLE PRECISION -*> The eigenvalue of smaller absolute value. -*> \endverbatim -*> -*> \param[out] CS1 -*> \verbatim -*> CS1 is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[out] SN1 -*> \verbatim -*> SN1 is DOUBLE PRECISION -*> The vector (CS1, SN1) is a unit right eigenvector for RT1. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> RT1 is accurate to a few ulps barring over/underflow. -*> -*> RT2 may be inaccurate if there is massive cancellation in the -*> determinant A*C-B*B; higher precision or correctly rounded or -*> correctly truncated arithmetic would be needed to compute RT2 -*> accurately in all cases. -*> -*> CS1 and SN1 are accurate to a few ulps barring over/underflow. -*> -*> Overflow is possible only if RT1 is within a factor of 5 of overflow. -*> Underflow is harmless if the input data is 0 or exceeds -*> underflow_threshold / macheps. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1 -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.0D0 ) - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION HALF - PARAMETER ( HALF = 0.5D0 ) -* .. -* .. Local Scalars .. - INTEGER SGN1, SGN2 - DOUBLE PRECISION AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM, - $ TB, TN -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -* .. -* .. Executable Statements .. -* -* Compute the eigenvalues -* - SM = A + C - DF = A - C - ADF = ABS( DF ) - TB = B + B - AB = ABS( TB ) - IF( ABS( A ).GT.ABS( C ) ) THEN - ACMX = A - ACMN = C - ELSE - ACMX = C - ACMN = A - END IF - IF( ADF.GT.AB ) THEN - RT = ADF*SQRT( ONE+( AB / ADF )**2 ) - ELSE IF( ADF.LT.AB ) THEN - RT = AB*SQRT( ONE+( ADF / AB )**2 ) - ELSE -* -* Includes case AB=ADF=0 -* - RT = AB*SQRT( TWO ) - END IF - IF( SM.LT.ZERO ) THEN - RT1 = HALF*( SM-RT ) - SGN1 = -1 -* -* Order of execution important. -* To get fully accurate smaller eigenvalue, -* next line needs to be executed in higher precision. -* - RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B - ELSE IF( SM.GT.ZERO ) THEN - RT1 = HALF*( SM+RT ) - SGN1 = 1 -* -* Order of execution important. -* To get fully accurate smaller eigenvalue, -* next line needs to be executed in higher precision. -* - RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B - ELSE -* -* Includes case RT1 = RT2 = 0 -* - RT1 = HALF*RT - RT2 = -HALF*RT - SGN1 = 1 - END IF -* -* Compute the eigenvector -* - IF( DF.GE.ZERO ) THEN - CS = DF + RT - SGN2 = 1 - ELSE - CS = DF - RT - SGN2 = -1 - END IF - ACS = ABS( CS ) - IF( ACS.GT.AB ) THEN - CT = -TB / CS - SN1 = ONE / SQRT( ONE+CT*CT ) - CS1 = CT*SN1 - ELSE - IF( AB.EQ.ZERO ) THEN - CS1 = ONE - SN1 = ZERO - ELSE - TN = -CS / TB - CS1 = ONE / SQRT( ONE+TN*TN ) - SN1 = TN*CS1 - END IF - END IF - IF( SGN1.EQ.SGN2 ) THEN - TN = CS1 - CS1 = -SN1 - SN1 = TN - END IF - RETURN -* -* End of DLAEV2 -* - END diff --git a/lib/linalg/dlaisnan.f b/lib/linalg/dlaisnan.f deleted file mode 100644 index 2caf5fb1d0..0000000000 --- a/lib/linalg/dlaisnan.f +++ /dev/null @@ -1,88 +0,0 @@ -*> \brief \b DLAISNAN tests input for NaN by comparing two arguments for inequality. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAISNAN + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 ) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION, INTENT(IN) :: DIN1, DIN2 -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> This routine is not for general use. It exists solely to avoid -*> over-optimization in DISNAN. -*> -*> DLAISNAN checks for NaNs by comparing its two arguments for -*> inequality. NaN is the only floating-point value where NaN != NaN -*> returns .TRUE. To check for NaNs, pass the same variable as both -*> arguments. -*> -*> A compiler must assume that the two arguments are -*> not the same variable, and the test will not be optimized away. -*> Interprocedural or whole-program optimization may delete this -*> test. The ISNAN functions will be replaced by the correct -*> Fortran 03 intrinsic once the intrinsic is widely available. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] DIN1 -*> \verbatim -*> DIN1 is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in] DIN2 -*> \verbatim -*> DIN2 is DOUBLE PRECISION -*> Two numbers to compare for inequality. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION, INTENT(IN) :: DIN1, DIN2 -* .. -* -* ===================================================================== -* -* .. Executable Statements .. - DLAISNAN = (DIN1.NE.DIN2) - RETURN - END diff --git a/lib/linalg/dlals0.cpp b/lib/linalg/dlals0.cpp new file mode 100644 index 0000000000..6623506f7e --- /dev/null +++ b/lib/linalg/dlals0.cpp @@ -0,0 +1,225 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static doublereal c_b5 = -1.; +static integer c__1 = 1; +static doublereal c_b11 = 1.; +static doublereal c_b13 = 0.; +static integer c__0 = 0; +int dlals0_(integer *icompq, integer *nl, integer *nr, integer *sqre, integer *nrhs, doublereal *b, + integer *ldb, doublereal *bx, integer *ldbx, integer *perm, integer *givptr, + integer *givcol, integer *ldgcol, doublereal *givnum, integer *ldgnum, + doublereal *poles, doublereal *difl, doublereal *difr, doublereal *z__, integer *k, + doublereal *c__, doublereal *s, doublereal *work, integer *info) +{ + integer givcol_dim1, givcol_offset, b_dim1, b_offset, bx_dim1, bx_offset, difr_dim1, + difr_offset, givnum_dim1, givnum_offset, poles_dim1, poles_offset, i__1, i__2; + doublereal d__1; + integer i__, j, m, n; + doublereal dj; + integer nlp1; + doublereal temp; + extern int drot_(integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, + doublereal *); + extern doublereal dnrm2_(integer *, doublereal *, integer *); + extern int dscal_(integer *, doublereal *, doublereal *, integer *); + doublereal diflj, difrj, dsigj; + extern int dgemv_(char *, integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, ftnlen), + dcopy_(integer *, doublereal *, integer *, doublereal *, integer *); + extern doublereal dlamc3_(doublereal *, doublereal *); + extern int 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); + doublereal dsigjp; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + bx_dim1 = *ldbx; + bx_offset = 1 + bx_dim1; + bx -= bx_offset; + --perm; + givcol_dim1 = *ldgcol; + givcol_offset = 1 + givcol_dim1; + givcol -= givcol_offset; + difr_dim1 = *ldgnum; + difr_offset = 1 + difr_dim1; + difr -= difr_offset; + poles_dim1 = *ldgnum; + poles_offset = 1 + poles_dim1; + poles -= poles_offset; + givnum_dim1 = *ldgnum; + givnum_offset = 1 + givnum_dim1; + givnum -= givnum_offset; + --difl; + --z__; + --work; + *info = 0; + n = *nl + *nr + 1; + if (*icompq < 0 || *icompq > 1) { + *info = -1; + } else if (*nl < 1) { + *info = -2; + } else if (*nr < 1) { + *info = -3; + } else if (*sqre < 0 || *sqre > 1) { + *info = -4; + } else if (*nrhs < 1) { + *info = -5; + } else if (*ldb < n) { + *info = -7; + } else if (*ldbx < n) { + *info = -9; + } else if (*givptr < 0) { + *info = -11; + } else if (*ldgcol < n) { + *info = -13; + } else if (*ldgnum < n) { + *info = -15; + } else if (*k < 1) { + *info = -20; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DLALS0", &i__1, (ftnlen)6); + return 0; + } + m = n + *sqre; + nlp1 = *nl + 1; + if (*icompq == 0) { + i__1 = *givptr; + for (i__ = 1; i__ <= i__1; ++i__) { + drot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, + &b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ + (givnum_dim1 << 1)], + &givnum[i__ + givnum_dim1]); + } + dcopy_(nrhs, &b[nlp1 + b_dim1], ldb, &bx[bx_dim1 + 1], ldbx); + i__1 = n; + for (i__ = 2; i__ <= i__1; ++i__) { + dcopy_(nrhs, &b[perm[i__] + b_dim1], ldb, &bx[i__ + bx_dim1], ldbx); + } + if (*k == 1) { + dcopy_(nrhs, &bx[bx_offset], ldbx, &b[b_offset], ldb); + if (z__[1] < 0.) { + dscal_(nrhs, &c_b5, &b[b_offset], ldb); + } + } else { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + diflj = difl[j]; + dj = poles[j + poles_dim1]; + dsigj = -poles[j + (poles_dim1 << 1)]; + if (j < *k) { + difrj = -difr[j + difr_dim1]; + dsigjp = -poles[j + 1 + (poles_dim1 << 1)]; + } + if (z__[j] == 0. || poles[j + (poles_dim1 << 1)] == 0.) { + work[j] = 0.; + } else { + work[j] = -poles[j + (poles_dim1 << 1)] * z__[j] / diflj / + (poles[j + (poles_dim1 << 1)] + dj); + } + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + if (z__[i__] == 0. || poles[i__ + (poles_dim1 << 1)] == 0.) { + work[i__] = 0.; + } else { + work[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__] / + (dlamc3_(&poles[i__ + (poles_dim1 << 1)], &dsigj) - diflj) / + (poles[i__ + (poles_dim1 << 1)] + dj); + } + } + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + if (z__[i__] == 0. || poles[i__ + (poles_dim1 << 1)] == 0.) { + work[i__] = 0.; + } else { + work[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__] / + (dlamc3_(&poles[i__ + (poles_dim1 << 1)], &dsigjp) + difrj) / + (poles[i__ + (poles_dim1 << 1)] + dj); + } + } + work[1] = -1.; + temp = dnrm2_(k, &work[1], &c__1); + dgemv_((char *)"T", k, nrhs, &c_b11, &bx[bx_offset], ldbx, &work[1], &c__1, &c_b13, + &b[j + b_dim1], ldb, (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &temp, &c_b11, &c__1, nrhs, &b[j + b_dim1], ldb, info, + (ftnlen)1); + } + } + if (*k < max(m, n)) { + i__1 = n - *k; + dlacpy_((char *)"A", &i__1, nrhs, &bx[*k + 1 + bx_dim1], ldbx, &b[*k + 1 + b_dim1], ldb, + (ftnlen)1); + } + } else { + if (*k == 1) { + dcopy_(nrhs, &b[b_offset], ldb, &bx[bx_offset], ldbx); + } else { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dsigj = poles[j + (poles_dim1 << 1)]; + if (z__[j] == 0.) { + work[j] = 0.; + } else { + work[j] = -z__[j] / difl[j] / (dsigj + poles[j + poles_dim1]) / + difr[j + (difr_dim1 << 1)]; + } + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + if (z__[j] == 0.) { + work[i__] = 0.; + } else { + d__1 = -poles[i__ + 1 + (poles_dim1 << 1)]; + work[i__] = z__[j] / (dlamc3_(&dsigj, &d__1) - difr[i__ + difr_dim1]) / + (dsigj + poles[i__ + poles_dim1]) / + difr[i__ + (difr_dim1 << 1)]; + } + } + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + if (z__[j] == 0.) { + work[i__] = 0.; + } else { + d__1 = -poles[i__ + (poles_dim1 << 1)]; + work[i__] = z__[j] / (dlamc3_(&dsigj, &d__1) - difl[i__]) / + (dsigj + poles[i__ + poles_dim1]) / + difr[i__ + (difr_dim1 << 1)]; + } + } + dgemv_((char *)"T", k, nrhs, &c_b11, &b[b_offset], ldb, &work[1], &c__1, &c_b13, + &bx[j + bx_dim1], ldbx, (ftnlen)1); + } + } + if (*sqre == 1) { + dcopy_(nrhs, &b[m + b_dim1], ldb, &bx[m + bx_dim1], ldbx); + drot_(nrhs, &bx[bx_dim1 + 1], ldbx, &bx[m + bx_dim1], ldbx, c__, s); + } + if (*k < max(m, n)) { + i__1 = n - *k; + dlacpy_((char *)"A", &i__1, nrhs, &b[*k + 1 + b_dim1], ldb, &bx[*k + 1 + bx_dim1], ldbx, + (ftnlen)1); + } + dcopy_(nrhs, &bx[bx_dim1 + 1], ldbx, &b[nlp1 + b_dim1], ldb); + if (*sqre == 1) { + dcopy_(nrhs, &bx[m + bx_dim1], ldbx, &b[m + b_dim1], ldb); + } + i__1 = n; + for (i__ = 2; i__ <= i__1; ++i__) { + dcopy_(nrhs, &bx[i__ + bx_dim1], ldbx, &b[perm[i__] + b_dim1], ldb); + } + for (i__ = *givptr; i__ >= 1; --i__) { + d__1 = -givnum[i__ + givnum_dim1]; + drot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, + &b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ + (givnum_dim1 << 1)], + &d__1); + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlals0.f b/lib/linalg/dlals0.f deleted file mode 100644 index cfca222806..0000000000 --- a/lib/linalg/dlals0.f +++ /dev/null @@ -1,496 +0,0 @@ -*> \brief \b DLALS0 applies back multiplying factors in solving the least squares problem using divide and conquer SVD approach. Used by sgelsd. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLALS0 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, -* PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, -* POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL, -* $ LDGNUM, NL, NR, NRHS, SQRE -* DOUBLE PRECISION C, S -* .. -* .. Array Arguments .. -* INTEGER GIVCOL( LDGCOL, * ), PERM( * ) -* DOUBLE PRECISION B( LDB, * ), BX( LDBX, * ), DIFL( * ), -* $ DIFR( LDGNUM, * ), GIVNUM( LDGNUM, * ), -* $ POLES( LDGNUM, * ), WORK( * ), Z( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLALS0 applies back the multiplying factors of either the left or the -*> right singular vector matrix of a diagonal matrix appended by a row -*> to the right hand side matrix B in solving the least squares problem -*> using the divide-and-conquer SVD approach. -*> -*> For the left singular vector matrix, three types of orthogonal -*> matrices are involved: -*> -*> (1L) Givens rotations: the number of such rotations is GIVPTR; the -*> pairs of columns/rows they were applied to are stored in GIVCOL; -*> and the C- and S-values of these rotations are stored in GIVNUM. -*> -*> (2L) Permutation. The (NL+1)-st row of B is to be moved to the first -*> row, and for J=2:N, PERM(J)-th row of B is to be moved to the -*> J-th row. -*> -*> (3L) The left singular vector matrix of the remaining matrix. -*> -*> For the right singular vector matrix, four types of orthogonal -*> matrices are involved: -*> -*> (1R) The right singular vector matrix of the remaining matrix. -*> -*> (2R) If SQRE = 1, one extra Givens rotation to generate the right -*> null space. -*> -*> (3R) The inverse transformation of (2L). -*> -*> (4R) The inverse transformation of (1L). -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] ICOMPQ -*> \verbatim -*> ICOMPQ is INTEGER -*> Specifies whether singular vectors are to be computed in -*> factored form: -*> = 0: Left singular vector matrix. -*> = 1: Right singular vector matrix. -*> \endverbatim -*> -*> \param[in] NL -*> \verbatim -*> NL is INTEGER -*> The row dimension of the upper block. NL >= 1. -*> \endverbatim -*> -*> \param[in] NR -*> \verbatim -*> NR is INTEGER -*> The row dimension of the lower block. NR >= 1. -*> \endverbatim -*> -*> \param[in] SQRE -*> \verbatim -*> SQRE is INTEGER -*> = 0: the lower block is an NR-by-NR square matrix. -*> = 1: the lower block is an NR-by-(NR+1) rectangular matrix. -*> -*> The bidiagonal matrix has row dimension N = NL + NR + 1, -*> and column dimension M = N + SQRE. -*> \endverbatim -*> -*> \param[in] NRHS -*> \verbatim -*> NRHS is INTEGER -*> The number of columns of B and BX. NRHS must be at least 1. -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension ( LDB, NRHS ) -*> On input, B contains the right hand sides of the least -*> squares problem in rows 1 through M. On output, B contains -*> the solution X in rows 1 through N. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of B. LDB must be at least -*> max(1,MAX( M, N ) ). -*> \endverbatim -*> -*> \param[out] BX -*> \verbatim -*> BX is DOUBLE PRECISION array, dimension ( LDBX, NRHS ) -*> \endverbatim -*> -*> \param[in] LDBX -*> \verbatim -*> LDBX is INTEGER -*> The leading dimension of BX. -*> \endverbatim -*> -*> \param[in] PERM -*> \verbatim -*> PERM is INTEGER array, dimension ( N ) -*> The permutations (from deflation and sorting) applied -*> to the two blocks. -*> \endverbatim -*> -*> \param[in] GIVPTR -*> \verbatim -*> GIVPTR is INTEGER -*> The number of Givens rotations which took place in this -*> subproblem. -*> \endverbatim -*> -*> \param[in] GIVCOL -*> \verbatim -*> GIVCOL is INTEGER array, dimension ( LDGCOL, 2 ) -*> Each pair of numbers indicates a pair of rows/columns -*> involved in a Givens rotation. -*> \endverbatim -*> -*> \param[in] LDGCOL -*> \verbatim -*> LDGCOL is INTEGER -*> The leading dimension of GIVCOL, must be at least N. -*> \endverbatim -*> -*> \param[in] GIVNUM -*> \verbatim -*> GIVNUM is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) -*> Each number indicates the C or S value used in the -*> corresponding Givens rotation. -*> \endverbatim -*> -*> \param[in] LDGNUM -*> \verbatim -*> LDGNUM is INTEGER -*> The leading dimension of arrays DIFR, POLES and -*> GIVNUM, must be at least K. -*> \endverbatim -*> -*> \param[in] POLES -*> \verbatim -*> POLES is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) -*> On entry, POLES(1:K, 1) contains the new singular -*> values obtained from solving the secular equation, and -*> POLES(1:K, 2) is an array containing the poles in the secular -*> equation. -*> \endverbatim -*> -*> \param[in] DIFL -*> \verbatim -*> DIFL is DOUBLE PRECISION array, dimension ( K ). -*> On entry, DIFL(I) is the distance between I-th updated -*> (undeflated) singular value and the I-th (undeflated) old -*> singular value. -*> \endverbatim -*> -*> \param[in] DIFR -*> \verbatim -*> DIFR is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ). -*> On entry, DIFR(I, 1) contains the distances between I-th -*> updated (undeflated) singular value and the I+1-th -*> (undeflated) old singular value. And DIFR(I, 2) is the -*> normalizing factor for the I-th right singular vector. -*> \endverbatim -*> -*> \param[in] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension ( K ) -*> Contain the components of the deflation-adjusted updating row -*> vector. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> Contains the dimension of the non-deflated matrix, -*> This is the order of the related secular equation. 1 <= K <=N. -*> \endverbatim -*> -*> \param[in] C -*> \verbatim -*> C is DOUBLE PRECISION -*> C contains garbage if SQRE =0 and the C-value of a Givens -*> rotation related to the right null space if SQRE = 1. -*> \endverbatim -*> -*> \param[in] S -*> \verbatim -*> S is DOUBLE PRECISION -*> S contains garbage if SQRE =0 and the S-value of a Givens -*> rotation related to the right null space if SQRE = 1. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension ( K ) -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit. -*> < 0: if INFO = -i, the i-th argument had an illegal value. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -*> \par Contributors: -* ================== -*> -*> Ming Gu and Ren-Cang Li, Computer Science Division, University of -*> California at Berkeley, USA \n -*> Osni Marques, LBNL/NERSC, USA \n -* -* ===================================================================== - SUBROUTINE DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, - $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, - $ POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL, - $ LDGNUM, NL, NR, NRHS, SQRE - DOUBLE PRECISION C, S -* .. -* .. Array Arguments .. - INTEGER GIVCOL( LDGCOL, * ), PERM( * ) - DOUBLE PRECISION B( LDB, * ), BX( LDBX, * ), DIFL( * ), - $ DIFR( LDGNUM, * ), GIVNUM( LDGNUM, * ), - $ POLES( LDGNUM, * ), WORK( * ), Z( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO, NEGONE - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0, NEGONE = -1.0D0 ) -* .. -* .. Local Scalars .. - INTEGER I, J, M, N, NLP1 - DOUBLE PRECISION DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, TEMP -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DGEMV, DLACPY, DLASCL, DROT, DSCAL, - $ XERBLA -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMC3, DNRM2 - EXTERNAL DLAMC3, DNRM2 -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - N = NL + NR + 1 -* - IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN - INFO = -1 - ELSE IF( NL.LT.1 ) THEN - INFO = -2 - ELSE IF( NR.LT.1 ) THEN - INFO = -3 - ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN - INFO = -4 - ELSE IF( NRHS.LT.1 ) THEN - INFO = -5 - ELSE IF( LDB.LT.N ) THEN - INFO = -7 - ELSE IF( LDBX.LT.N ) THEN - INFO = -9 - ELSE IF( GIVPTR.LT.0 ) THEN - INFO = -11 - ELSE IF( LDGCOL.LT.N ) THEN - INFO = -13 - ELSE IF( LDGNUM.LT.N ) THEN - INFO = -15 - ELSE IF( K.LT.1 ) THEN - INFO = -20 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLALS0', -INFO ) - RETURN - END IF -* - M = N + SQRE - NLP1 = NL + 1 -* - IF( ICOMPQ.EQ.0 ) THEN -* -* Apply back orthogonal transformations from the left. -* -* Step (1L): apply back the Givens rotations performed. -* - DO 10 I = 1, GIVPTR - CALL DROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB, - $ B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ), - $ GIVNUM( I, 1 ) ) - 10 CONTINUE -* -* Step (2L): permute rows of B. -* - CALL DCOPY( NRHS, B( NLP1, 1 ), LDB, BX( 1, 1 ), LDBX ) - DO 20 I = 2, N - CALL DCOPY( NRHS, B( PERM( I ), 1 ), LDB, BX( I, 1 ), LDBX ) - 20 CONTINUE -* -* Step (3L): apply the inverse of the left singular vector -* matrix to BX. -* - IF( K.EQ.1 ) THEN - CALL DCOPY( NRHS, BX, LDBX, B, LDB ) - IF( Z( 1 ).LT.ZERO ) THEN - CALL DSCAL( NRHS, NEGONE, B, LDB ) - END IF - ELSE - DO 50 J = 1, K - DIFLJ = DIFL( J ) - DJ = POLES( J, 1 ) - DSIGJ = -POLES( J, 2 ) - IF( J.LT.K ) THEN - DIFRJ = -DIFR( J, 1 ) - DSIGJP = -POLES( J+1, 2 ) - END IF - IF( ( Z( J ).EQ.ZERO ) .OR. ( POLES( J, 2 ).EQ.ZERO ) ) - $ THEN - WORK( J ) = ZERO - ELSE - WORK( J ) = -POLES( J, 2 )*Z( J ) / DIFLJ / - $ ( POLES( J, 2 )+DJ ) - END IF - DO 30 I = 1, J - 1 - IF( ( Z( I ).EQ.ZERO ) .OR. - $ ( POLES( I, 2 ).EQ.ZERO ) ) THEN - WORK( I ) = ZERO - ELSE - WORK( I ) = POLES( I, 2 )*Z( I ) / - $ ( DLAMC3( POLES( I, 2 ), DSIGJ )- - $ DIFLJ ) / ( POLES( I, 2 )+DJ ) - END IF - 30 CONTINUE - DO 40 I = J + 1, K - IF( ( Z( I ).EQ.ZERO ) .OR. - $ ( POLES( I, 2 ).EQ.ZERO ) ) THEN - WORK( I ) = ZERO - ELSE - WORK( I ) = POLES( I, 2 )*Z( I ) / - $ ( DLAMC3( POLES( I, 2 ), DSIGJP )+ - $ DIFRJ ) / ( POLES( I, 2 )+DJ ) - END IF - 40 CONTINUE - WORK( 1 ) = NEGONE - TEMP = DNRM2( K, WORK, 1 ) - CALL DGEMV( 'T', K, NRHS, ONE, BX, LDBX, WORK, 1, ZERO, - $ B( J, 1 ), LDB ) - CALL DLASCL( 'G', 0, 0, TEMP, ONE, 1, NRHS, B( J, 1 ), - $ LDB, INFO ) - 50 CONTINUE - END IF -* -* Move the deflated rows of BX to B also. -* - IF( K.LT.MAX( M, N ) ) - $ CALL DLACPY( 'A', N-K, NRHS, BX( K+1, 1 ), LDBX, - $ B( K+1, 1 ), LDB ) - ELSE -* -* Apply back the right orthogonal transformations. -* -* Step (1R): apply back the new right singular vector matrix -* to B. -* - IF( K.EQ.1 ) THEN - CALL DCOPY( NRHS, B, LDB, BX, LDBX ) - ELSE - DO 80 J = 1, K - DSIGJ = POLES( J, 2 ) - IF( Z( J ).EQ.ZERO ) THEN - WORK( J ) = ZERO - ELSE - WORK( J ) = -Z( J ) / DIFL( J ) / - $ ( DSIGJ+POLES( J, 1 ) ) / DIFR( J, 2 ) - END IF - DO 60 I = 1, J - 1 - IF( Z( J ).EQ.ZERO ) THEN - WORK( I ) = ZERO - ELSE - WORK( I ) = Z( J ) / ( DLAMC3( DSIGJ, -POLES( I+1, - $ 2 ) )-DIFR( I, 1 ) ) / - $ ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 ) - END IF - 60 CONTINUE - DO 70 I = J + 1, K - IF( Z( J ).EQ.ZERO ) THEN - WORK( I ) = ZERO - ELSE - WORK( I ) = Z( J ) / ( DLAMC3( DSIGJ, -POLES( I, - $ 2 ) )-DIFL( I ) ) / - $ ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 ) - END IF - 70 CONTINUE - CALL DGEMV( 'T', K, NRHS, ONE, B, LDB, WORK, 1, ZERO, - $ BX( J, 1 ), LDBX ) - 80 CONTINUE - END IF -* -* Step (2R): if SQRE = 1, apply back the rotation that is -* related to the right null space of the subproblem. -* - IF( SQRE.EQ.1 ) THEN - CALL DCOPY( NRHS, B( M, 1 ), LDB, BX( M, 1 ), LDBX ) - CALL DROT( NRHS, BX( 1, 1 ), LDBX, BX( M, 1 ), LDBX, C, S ) - END IF - IF( K.LT.MAX( M, N ) ) - $ CALL DLACPY( 'A', N-K, NRHS, B( K+1, 1 ), LDB, BX( K+1, 1 ), - $ LDBX ) -* -* Step (3R): permute rows of B. -* - CALL DCOPY( NRHS, BX( 1, 1 ), LDBX, B( NLP1, 1 ), LDB ) - IF( SQRE.EQ.1 ) THEN - CALL DCOPY( NRHS, BX( M, 1 ), LDBX, B( M, 1 ), LDB ) - END IF - DO 90 I = 2, N - CALL DCOPY( NRHS, BX( I, 1 ), LDBX, B( PERM( I ), 1 ), LDB ) - 90 CONTINUE -* -* Step (4R): apply back the Givens rotations performed. -* - DO 100 I = GIVPTR, 1, -1 - CALL DROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB, - $ B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ), - $ -GIVNUM( I, 1 ) ) - 100 CONTINUE - END IF -* - RETURN -* -* End of DLALS0 -* - END diff --git a/lib/linalg/dlalsa.cpp b/lib/linalg/dlalsa.cpp new file mode 100644 index 0000000000..82b9d56562 --- /dev/null +++ b/lib/linalg/dlalsa.cpp @@ -0,0 +1,209 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static doublereal c_b7 = 1.; +static doublereal c_b8 = 0.; +static integer c__2 = 2; +int dlalsa_(integer *icompq, integer *smlsiz, integer *n, integer *nrhs, doublereal *b, + integer *ldb, doublereal *bx, integer *ldbx, doublereal *u, integer *ldu, + doublereal *vt, integer *k, doublereal *difl, doublereal *difr, doublereal *z__, + doublereal *poles, integer *givptr, integer *givcol, integer *ldgcol, integer *perm, + doublereal *givnum, doublereal *c__, doublereal *s, doublereal *work, integer *iwork, + integer *info) +{ + integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, b_dim1, b_offset, bx_dim1, + bx_offset, difl_dim1, difl_offset, difr_dim1, difr_offset, givnum_dim1, givnum_offset, + poles_dim1, poles_offset, u_dim1, u_offset, vt_dim1, vt_offset, z_dim1, z_offset, i__1, + i__2; + integer pow_lmp_ii(integer *, integer *); + integer i__, j, i1, ic, lf, nd, ll, nl, nr, im1, nlf, nrf, lvl, ndb1, nlp1, lvl2, nrp1, nlvl, + sqre; + extern int dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, + ftnlen, ftnlen); + integer inode, ndiml, ndimr; + extern int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *), + dlals0_(integer *, integer *, integer *, integer *, integer *, doublereal *, integer *, + doublereal *, integer *, integer *, integer *, integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, + doublereal *, doublereal *, doublereal *, integer *), + dlasdt_(integer *, integer *, integer *, integer *, integer *, integer *, integer *), + xerbla_(char *, integer *, ftnlen); + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + bx_dim1 = *ldbx; + bx_offset = 1 + bx_dim1; + bx -= bx_offset; + givnum_dim1 = *ldu; + givnum_offset = 1 + givnum_dim1; + givnum -= givnum_offset; + poles_dim1 = *ldu; + poles_offset = 1 + poles_dim1; + poles -= poles_offset; + z_dim1 = *ldu; + z_offset = 1 + z_dim1; + z__ -= z_offset; + difr_dim1 = *ldu; + difr_offset = 1 + difr_dim1; + difr -= difr_offset; + difl_dim1 = *ldu; + difl_offset = 1 + difl_dim1; + difl -= difl_offset; + vt_dim1 = *ldu; + vt_offset = 1 + vt_dim1; + vt -= vt_offset; + u_dim1 = *ldu; + u_offset = 1 + u_dim1; + u -= u_offset; + --k; + --givptr; + perm_dim1 = *ldgcol; + perm_offset = 1 + perm_dim1; + perm -= perm_offset; + givcol_dim1 = *ldgcol; + givcol_offset = 1 + givcol_dim1; + givcol -= givcol_offset; + --c__; + --s; + --work; + --iwork; + *info = 0; + if (*icompq < 0 || *icompq > 1) { + *info = -1; + } else if (*smlsiz < 3) { + *info = -2; + } else if (*n < *smlsiz) { + *info = -3; + } else if (*nrhs < 1) { + *info = -4; + } else if (*ldb < *n) { + *info = -6; + } else if (*ldbx < *n) { + *info = -8; + } else if (*ldu < *n) { + *info = -10; + } else if (*ldgcol < *n) { + *info = -19; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DLALSA", &i__1, (ftnlen)6); + return 0; + } + inode = 1; + ndiml = inode + *n; + ndimr = ndiml + *n; + dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr], smlsiz); + if (*icompq == 1) { + goto L50; + } + ndb1 = (nd + 1) / 2; + i__1 = nd; + for (i__ = ndb1; i__ <= i__1; ++i__) { + i1 = i__ - 1; + ic = iwork[inode + i1]; + nl = iwork[ndiml + i1]; + nr = iwork[ndimr + i1]; + nlf = ic - nl; + nrf = ic + 1; + dgemm_((char *)"T", (char *)"N", &nl, nrhs, &nl, &c_b7, &u[nlf + u_dim1], ldu, &b[nlf + b_dim1], ldb, &c_b8, + &bx[nlf + bx_dim1], ldbx, (ftnlen)1, (ftnlen)1); + dgemm_((char *)"T", (char *)"N", &nr, nrhs, &nr, &c_b7, &u[nrf + u_dim1], ldu, &b[nrf + b_dim1], ldb, &c_b8, + &bx[nrf + bx_dim1], ldbx, (ftnlen)1, (ftnlen)1); + } + i__1 = nd; + for (i__ = 1; i__ <= i__1; ++i__) { + ic = iwork[inode + i__ - 1]; + dcopy_(nrhs, &b[ic + b_dim1], ldb, &bx[ic + bx_dim1], ldbx); + } + j = pow_lmp_ii(&c__2, &nlvl); + sqre = 0; + for (lvl = nlvl; lvl >= 1; --lvl) { + lvl2 = (lvl << 1) - 1; + 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; + nrf = ic + 1; + --j; + dlals0_(icompq, &nl, &nr, &sqre, nrhs, &bx[nlf + bx_dim1], ldbx, &b[nlf + b_dim1], ldb, + &perm[nlf + lvl * perm_dim1], &givptr[j], &givcol[nlf + lvl2 * givcol_dim1], + ldgcol, &givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 * poles_dim1], + &difl[nlf + lvl * difl_dim1], &difr[nlf + lvl2 * difr_dim1], + &z__[nlf + lvl * z_dim1], &k[j], &c__[j], &s[j], &work[1], info); + } + } + goto L90; +L50: + j = 0; + i__1 = nlvl; + for (lvl = 1; lvl <= i__1; ++lvl) { + lvl2 = (lvl << 1) - 1; + if (lvl == 1) { + lf = 1; + ll = 1; + } else { + i__2 = lvl - 1; + lf = pow_lmp_ii(&c__2, &i__2); + ll = (lf << 1) - 1; + } + i__2 = lf; + for (i__ = ll; i__ >= i__2; --i__) { + im1 = i__ - 1; + ic = iwork[inode + im1]; + nl = iwork[ndiml + im1]; + nr = iwork[ndimr + im1]; + nlf = ic - nl; + nrf = ic + 1; + if (i__ == ll) { + sqre = 0; + } else { + sqre = 1; + } + ++j; + dlals0_(icompq, &nl, &nr, &sqre, nrhs, &b[nlf + b_dim1], ldb, &bx[nlf + bx_dim1], ldbx, + &perm[nlf + lvl * perm_dim1], &givptr[j], &givcol[nlf + lvl2 * givcol_dim1], + ldgcol, &givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 * poles_dim1], + &difl[nlf + lvl * difl_dim1], &difr[nlf + lvl2 * difr_dim1], + &z__[nlf + lvl * z_dim1], &k[j], &c__[j], &s[j], &work[1], info); + } + } + ndb1 = (nd + 1) / 2; + i__1 = nd; + for (i__ = ndb1; i__ <= i__1; ++i__) { + i1 = i__ - 1; + ic = iwork[inode + i1]; + nl = iwork[ndiml + i1]; + nr = iwork[ndimr + i1]; + nlp1 = nl + 1; + if (i__ == nd) { + nrp1 = nr; + } else { + nrp1 = nr + 1; + } + nlf = ic - nl; + nrf = ic + 1; + dgemm_((char *)"T", (char *)"N", &nlp1, nrhs, &nlp1, &c_b7, &vt[nlf + vt_dim1], ldu, &b[nlf + b_dim1], ldb, + &c_b8, &bx[nlf + bx_dim1], ldbx, (ftnlen)1, (ftnlen)1); + dgemm_((char *)"T", (char *)"N", &nrp1, nrhs, &nrp1, &c_b7, &vt[nrf + vt_dim1], ldu, &b[nrf + b_dim1], ldb, + &c_b8, &bx[nrf + bx_dim1], ldbx, (ftnlen)1, (ftnlen)1); + } +L90: + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlalsa.f b/lib/linalg/dlalsa.f deleted file mode 100644 index da8e0fa175..0000000000 --- a/lib/linalg/dlalsa.f +++ /dev/null @@ -1,490 +0,0 @@ -*> \brief \b DLALSA computes the SVD of the coefficient matrix in compact form. Used by sgelsd. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLALSA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, -* LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, -* GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, -* IWORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS, -* $ SMLSIZ -* .. -* .. Array Arguments .. -* INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ), -* $ K( * ), PERM( LDGCOL, * ) -* DOUBLE PRECISION B( LDB, * ), BX( LDBX, * ), C( * ), -* $ DIFL( LDU, * ), DIFR( LDU, * ), -* $ GIVNUM( LDU, * ), POLES( LDU, * ), S( * ), -* $ U( LDU, * ), VT( LDU, * ), WORK( * ), -* $ Z( LDU, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLALSA is an itermediate step in solving the least squares problem -*> by computing the SVD of the coefficient matrix in compact form (The -*> singular vectors are computed as products of simple orthorgonal -*> matrices.). -*> -*> If ICOMPQ = 0, DLALSA applies the inverse of the left singular vector -*> matrix of an upper bidiagonal matrix to the right hand side; and if -*> ICOMPQ = 1, DLALSA applies the right singular vector matrix to the -*> right hand side. The singular vector matrices were generated in -*> compact form by DLALSA. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] ICOMPQ -*> \verbatim -*> ICOMPQ is INTEGER -*> Specifies whether the left or the right singular vector -*> matrix is involved. -*> = 0: Left singular vector matrix -*> = 1: Right singular vector matrix -*> \endverbatim -*> -*> \param[in] SMLSIZ -*> \verbatim -*> SMLSIZ is INTEGER -*> The maximum size of the subproblems at the bottom of the -*> computation tree. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The row and column dimensions of the upper bidiagonal matrix. -*> \endverbatim -*> -*> \param[in] NRHS -*> \verbatim -*> NRHS is INTEGER -*> The number of columns of B and BX. NRHS must be at least 1. -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension ( LDB, NRHS ) -*> On input, B contains the right hand sides of the least -*> squares problem in rows 1 through M. -*> On output, B contains the solution X in rows 1 through N. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of B in the calling subprogram. -*> LDB must be at least max(1,MAX( M, N ) ). -*> \endverbatim -*> -*> \param[out] BX -*> \verbatim -*> BX is DOUBLE PRECISION array, dimension ( LDBX, NRHS ) -*> On exit, the result of applying the left or right singular -*> vector matrix to B. -*> \endverbatim -*> -*> \param[in] LDBX -*> \verbatim -*> LDBX is INTEGER -*> The leading dimension of BX. -*> \endverbatim -*> -*> \param[in] U -*> \verbatim -*> U is DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ). -*> On entry, U contains the left singular vector matrices of all -*> subproblems at the bottom level. -*> \endverbatim -*> -*> \param[in] LDU -*> \verbatim -*> LDU is INTEGER, LDU = > N. -*> The leading dimension of arrays U, VT, DIFL, DIFR, -*> POLES, GIVNUM, and Z. -*> \endverbatim -*> -*> \param[in] VT -*> \verbatim -*> VT is DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ). -*> On entry, VT**T contains the right singular vector matrices of -*> all subproblems at the bottom level. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER array, dimension ( N ). -*> \endverbatim -*> -*> \param[in] DIFL -*> \verbatim -*> DIFL is DOUBLE PRECISION array, dimension ( LDU, NLVL ). -*> where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1. -*> \endverbatim -*> -*> \param[in] DIFR -*> \verbatim -*> DIFR is DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). -*> On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record -*> distances between singular values on the I-th level and -*> singular values on the (I -1)-th level, and DIFR(*, 2 * I) -*> record the normalizing factors of the right singular vectors -*> matrices of subproblems on I-th level. -*> \endverbatim -*> -*> \param[in] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension ( LDU, NLVL ). -*> On entry, Z(1, I) contains the components of the deflation- -*> adjusted updating row vector for subproblems on the I-th -*> level. -*> \endverbatim -*> -*> \param[in] POLES -*> \verbatim -*> POLES is DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). -*> On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old -*> singular values involved in the secular equations on the I-th -*> level. -*> \endverbatim -*> -*> \param[in] GIVPTR -*> \verbatim -*> GIVPTR is INTEGER array, dimension ( N ). -*> On entry, GIVPTR( I ) records the number of Givens -*> rotations performed on the I-th problem on the computation -*> tree. -*> \endverbatim -*> -*> \param[in] GIVCOL -*> \verbatim -*> GIVCOL is INTEGER array, dimension ( LDGCOL, 2 * NLVL ). -*> On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the -*> locations of Givens rotations performed on the I-th level on -*> the computation tree. -*> \endverbatim -*> -*> \param[in] LDGCOL -*> \verbatim -*> LDGCOL is INTEGER, LDGCOL = > N. -*> The leading dimension of arrays GIVCOL and PERM. -*> \endverbatim -*> -*> \param[in] PERM -*> \verbatim -*> PERM is INTEGER array, dimension ( LDGCOL, NLVL ). -*> On entry, PERM(*, I) records permutations done on the I-th -*> level of the computation tree. -*> \endverbatim -*> -*> \param[in] GIVNUM -*> \verbatim -*> GIVNUM is DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). -*> On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S- -*> values of Givens rotations performed on the I-th level on the -*> computation tree. -*> \endverbatim -*> -*> \param[in] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension ( N ). -*> On entry, if the I-th subproblem is not square, -*> C( I ) contains the C-value of a Givens rotation related to -*> the right null space of the I-th subproblem. -*> \endverbatim -*> -*> \param[in] S -*> \verbatim -*> S is DOUBLE PRECISION array, dimension ( N ). -*> On entry, if the I-th subproblem is not square, -*> S( I ) contains the S-value of a Givens rotation related to -*> the right null space of the I-th subproblem. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (N) -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, dimension (3*N) -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit. -*> < 0: if INFO = -i, the i-th argument had an illegal value. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -*> \par Contributors: -* ================== -*> -*> Ming Gu and Ren-Cang Li, Computer Science Division, University of -*> California at Berkeley, USA \n -*> Osni Marques, LBNL/NERSC, USA \n -* -* ===================================================================== - SUBROUTINE DLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, - $ LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, - $ GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, - $ IWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS, - $ SMLSIZ -* .. -* .. Array Arguments .. - INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ), - $ K( * ), PERM( LDGCOL, * ) - DOUBLE PRECISION B( LDB, * ), BX( LDBX, * ), C( * ), - $ DIFL( LDU, * ), DIFR( LDU, * ), - $ GIVNUM( LDU, * ), POLES( LDU, * ), S( * ), - $ U( LDU, * ), VT( LDU, * ), WORK( * ), - $ Z( LDU, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - INTEGER I, I1, IC, IM1, INODE, J, LF, LL, LVL, LVL2, - $ ND, NDB1, NDIML, NDIMR, NL, NLF, NLP1, NLVL, - $ NR, NRF, NRP1, SQRE -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DLALS0, DLASDT, XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN - INFO = -1 - ELSE IF( SMLSIZ.LT.3 ) THEN - INFO = -2 - ELSE IF( N.LT.SMLSIZ ) THEN - INFO = -3 - ELSE IF( NRHS.LT.1 ) THEN - INFO = -4 - ELSE IF( LDB.LT.N ) THEN - INFO = -6 - ELSE IF( LDBX.LT.N ) THEN - INFO = -8 - ELSE IF( LDU.LT.N ) THEN - INFO = -10 - ELSE IF( LDGCOL.LT.N ) THEN - INFO = -19 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLALSA', -INFO ) - RETURN - END IF -* -* Book-keeping and setting up the computation tree. -* - INODE = 1 - NDIML = INODE + N - NDIMR = NDIML + N -* - CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ), - $ IWORK( NDIMR ), SMLSIZ ) -* -* The following code applies back the left singular vector factors. -* For applying back the right singular vector factors, go to 50. -* - IF( ICOMPQ.EQ.1 ) THEN - GO TO 50 - END IF -* -* The nodes on the bottom level of the tree were solved -* by DLASDQ. The corresponding left and right singular vector -* matrices are in explicit form. First apply back the left -* singular vector matrices. -* - NDB1 = ( ND+1 ) / 2 - DO 10 I = NDB1, ND -* -* IC : center row of each node -* NL : number of rows of left subproblem -* NR : number of rows of right subproblem -* NLF: starting row of the left subproblem -* NRF: starting row of the right subproblem -* - I1 = I - 1 - IC = IWORK( INODE+I1 ) - NL = IWORK( NDIML+I1 ) - NR = IWORK( NDIMR+I1 ) - NLF = IC - NL - NRF = IC + 1 - CALL DGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU, - $ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX ) - CALL DGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU, - $ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX ) - 10 CONTINUE -* -* Next copy the rows of B that correspond to unchanged rows -* in the bidiagonal matrix to BX. -* - DO 20 I = 1, ND - IC = IWORK( INODE+I-1 ) - CALL DCOPY( NRHS, B( IC, 1 ), LDB, BX( IC, 1 ), LDBX ) - 20 CONTINUE -* -* Finally go through the left singular vector matrices of all -* the other subproblems bottom-up on the tree. -* - J = 2**NLVL - SQRE = 0 -* - DO 40 LVL = NLVL, 1, -1 - LVL2 = 2*LVL - 1 -* -* find the first node LF and last node LL on -* the current level LVL -* - IF( LVL.EQ.1 ) THEN - LF = 1 - LL = 1 - ELSE - LF = 2**( LVL-1 ) - LL = 2*LF - 1 - END IF - DO 30 I = LF, LL - IM1 = I - 1 - IC = IWORK( INODE+IM1 ) - NL = IWORK( NDIML+IM1 ) - NR = IWORK( NDIMR+IM1 ) - NLF = IC - NL - NRF = IC + 1 - J = J - 1 - CALL DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, BX( NLF, 1 ), LDBX, - $ B( NLF, 1 ), LDB, PERM( NLF, LVL ), - $ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL, - $ GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ), - $ DIFL( NLF, LVL ), DIFR( NLF, LVL2 ), - $ Z( NLF, LVL ), K( J ), C( J ), S( J ), WORK, - $ INFO ) - 30 CONTINUE - 40 CONTINUE - GO TO 90 -* -* ICOMPQ = 1: applying back the right singular vector factors. -* - 50 CONTINUE -* -* First now go through the right singular vector matrices of all -* the tree nodes top-down. -* - J = 0 - DO 70 LVL = 1, NLVL - LVL2 = 2*LVL - 1 -* -* Find the first node LF and last node LL on -* the current level LVL. -* - IF( LVL.EQ.1 ) THEN - LF = 1 - LL = 1 - ELSE - LF = 2**( LVL-1 ) - LL = 2*LF - 1 - END IF - DO 60 I = LL, LF, -1 - IM1 = I - 1 - IC = IWORK( INODE+IM1 ) - NL = IWORK( NDIML+IM1 ) - NR = IWORK( NDIMR+IM1 ) - NLF = IC - NL - NRF = IC + 1 - IF( I.EQ.LL ) THEN - SQRE = 0 - ELSE - SQRE = 1 - END IF - J = J + 1 - CALL DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B( NLF, 1 ), LDB, - $ BX( NLF, 1 ), LDBX, PERM( NLF, LVL ), - $ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL, - $ GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ), - $ DIFL( NLF, LVL ), DIFR( NLF, LVL2 ), - $ Z( NLF, LVL ), K( J ), C( J ), S( J ), WORK, - $ INFO ) - 60 CONTINUE - 70 CONTINUE -* -* The nodes on the bottom level of the tree were solved -* by DLASDQ. The corresponding right singular vector -* matrices are in explicit form. Apply them back. -* - NDB1 = ( ND+1 ) / 2 - DO 80 I = NDB1, ND - I1 = I - 1 - IC = IWORK( INODE+I1 ) - NL = IWORK( NDIML+I1 ) - NR = IWORK( NDIMR+I1 ) - NLP1 = NL + 1 - IF( I.EQ.ND ) THEN - NRP1 = NR - ELSE - NRP1 = NR + 1 - END IF - NLF = IC - NL - NRF = IC + 1 - CALL DGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU, - $ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX ) - CALL DGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU, - $ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX ) - 80 CONTINUE -* - 90 CONTINUE -* - RETURN -* -* End of DLALSA -* - END diff --git a/lib/linalg/dlalsd.cpp b/lib/linalg/dlalsd.cpp new file mode 100644 index 0000000000..a68eb9b93e --- /dev/null +++ b/lib/linalg/dlalsd.cpp @@ -0,0 +1,292 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +static doublereal c_b6 = 0.; +static integer c__0 = 0; +static doublereal c_b11 = 1.; +int dlalsd_(char *uplo, integer *smlsiz, integer *n, integer *nrhs, doublereal *d__, doublereal *e, + doublereal *b, integer *ldb, doublereal *rcond, integer *rank, doublereal *work, + integer *iwork, integer *info, ftnlen uplo_len) +{ + integer b_dim1, b_offset, i__1, i__2; + doublereal d__1; + double log(doublereal), d_lmp_sign(doublereal *, doublereal *); + integer c__, i__, j, k; + doublereal r__; + integer s, u, z__; + doublereal cs; + integer bx; + doublereal sn; + integer st, vt, nm1, st1; + doublereal eps; + integer iwk; + doublereal tol; + integer difl, difr; + doublereal rcnd; + integer perm, nsub; + extern int drot_(integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, + doublereal *); + integer nlvl, sqre, bxst; + extern int dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, + ftnlen, ftnlen), + dcopy_(integer *, doublereal *, integer *, doublereal *, integer *); + integer poles, sizei, nsize, nwork, icmpq1, icmpq2; + 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 *), + dlalsa_(integer *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, + integer *, 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); + extern integer idamax_(integer *, doublereal *, integer *); + extern int dlasdq_(char *, integer *, integer *, integer *, integer *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, integer *, ftnlen), + dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *, + ftnlen), + dlartg_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *), + dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, + ftnlen), + xerbla_(char *, integer *, ftnlen); + integer givcol; + extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *, ftnlen); + extern int dlasrt_(char *, integer *, doublereal *, integer *, ftnlen); + doublereal orgnrm; + integer givnum, givptr, smlszp; + --d__; + --e; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + --work; + --iwork; + *info = 0; + if (*n < 0) { + *info = -3; + } else if (*nrhs < 1) { + *info = -4; + } else if (*ldb < 1 || *ldb < *n) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DLALSD", &i__1, (ftnlen)6); + return 0; + } + eps = dlamch_((char *)"Epsilon", (ftnlen)7); + if (*rcond <= 0. || *rcond >= 1.) { + rcnd = eps; + } else { + rcnd = *rcond; + } + *rank = 0; + if (*n == 0) { + return 0; + } else if (*n == 1) { + if (d__[1] == 0.) { + dlaset_((char *)"A", &c__1, nrhs, &c_b6, &c_b6, &b[b_offset], ldb, (ftnlen)1); + } else { + *rank = 1; + dlascl_((char *)"G", &c__0, &c__0, &d__[1], &c_b11, &c__1, nrhs, &b[b_offset], ldb, info, + (ftnlen)1); + d__[1] = abs(d__[1]); + } + return 0; + } + if (*(unsigned char *)uplo == 'L') { + 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 (*nrhs == 1) { + drot_(&c__1, &b[i__ + b_dim1], &c__1, &b[i__ + 1 + b_dim1], &c__1, &cs, &sn); + } else { + work[(i__ << 1) - 1] = cs; + work[i__ * 2] = sn; + } + } + if (*nrhs > 1) { + i__1 = *nrhs; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n - 1; + for (j = 1; j <= i__2; ++j) { + cs = work[(j << 1) - 1]; + sn = work[j * 2]; + drot_(&c__1, &b[j + i__ * b_dim1], &c__1, &b[j + 1 + i__ * b_dim1], &c__1, &cs, + &sn); + } + } + } + } + nm1 = *n - 1; + orgnrm = dlanst_((char *)"M", n, &d__[1], &e[1], (ftnlen)1); + if (orgnrm == 0.) { + dlaset_((char *)"A", n, nrhs, &c_b6, &c_b6, &b[b_offset], ldb, (ftnlen)1); + return 0; + } + dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b11, n, &c__1, &d__[1], n, info, (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b11, &nm1, &c__1, &e[1], &nm1, info, (ftnlen)1); + if (*n <= *smlsiz) { + nwork = *n * *n + 1; + dlaset_((char *)"A", n, n, &c_b6, &c_b11, &work[1], n, (ftnlen)1); + dlasdq_((char *)"U", &c__0, n, n, &c__0, nrhs, &d__[1], &e[1], &work[1], n, &work[1], n, + &b[b_offset], ldb, &work[nwork], info, (ftnlen)1); + if (*info != 0) { + return 0; + } + tol = rcnd * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1)); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (d__[i__] <= tol) { + dlaset_((char *)"A", &c__1, nrhs, &c_b6, &c_b6, &b[i__ + b_dim1], ldb, (ftnlen)1); + } else { + dlascl_((char *)"G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &b[i__ + b_dim1], ldb, + info, (ftnlen)1); + ++(*rank); + } + } + dgemm_((char *)"T", (char *)"N", n, nrhs, n, &c_b11, &work[1], n, &b[b_offset], ldb, &c_b6, &work[nwork], n, + (ftnlen)1, (ftnlen)1); + dlacpy_((char *)"A", n, nrhs, &work[nwork], n, &b[b_offset], ldb, (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, info, (ftnlen)1); + dlasrt_((char *)"D", n, &d__[1], info, (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], ldb, info, (ftnlen)1); + return 0; + } + nlvl = (integer)(log((doublereal)(*n) / (doublereal)(*smlsiz + 1)) / log(2.)) + 1; + smlszp = *smlsiz + 1; + u = 1; + vt = *smlsiz * *n + 1; + difl = vt + smlszp * *n; + difr = difl + nlvl * *n; + z__ = difr + (nlvl * *n << 1); + c__ = z__ + nlvl * *n; + s = c__ + *n; + poles = s + *n; + givnum = poles + (nlvl << 1) * *n; + bx = givnum + (nlvl << 1) * *n; + nwork = bx + *n * *nrhs; + sizei = *n + 1; + k = sizei + *n; + givptr = k + *n; + perm = givptr + *n; + givcol = perm + nlvl * *n; + iwk = givcol + (nlvl * *n << 1); + st = 1; + sqre = 0; + icmpq1 = 1; + icmpq2 = 0; + nsub = 0; + 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__]); + } + } + i__1 = nm1; + for (i__ = 1; i__ <= i__1; ++i__) { + if ((d__1 = e[i__], abs(d__1)) < eps || i__ == nm1) { + ++nsub; + iwork[nsub] = st; + if (i__ < nm1) { + nsize = i__ - st + 1; + iwork[sizei + nsub - 1] = nsize; + } else if ((d__1 = e[i__], abs(d__1)) >= eps) { + nsize = *n - st + 1; + iwork[sizei + nsub - 1] = nsize; + } else { + nsize = i__ - st + 1; + iwork[sizei + nsub - 1] = nsize; + ++nsub; + iwork[nsub] = *n; + iwork[sizei + nsub - 1] = 1; + dcopy_(nrhs, &b[*n + b_dim1], ldb, &work[bx + nm1], n); + } + st1 = st - 1; + if (nsize == 1) { + dcopy_(nrhs, &b[st + b_dim1], ldb, &work[bx + st1], n); + } else if (nsize <= *smlsiz) { + dlaset_((char *)"A", &nsize, &nsize, &c_b6, &c_b11, &work[vt + st1], n, (ftnlen)1); + dlasdq_((char *)"U", &c__0, &nsize, &nsize, &c__0, nrhs, &d__[st], &e[st], &work[vt + st1], + n, &work[nwork], n, &b[st + b_dim1], ldb, &work[nwork], info, (ftnlen)1); + if (*info != 0) { + return 0; + } + dlacpy_((char *)"A", &nsize, nrhs, &b[st + b_dim1], ldb, &work[bx + st1], n, (ftnlen)1); + } else { + dlasda_(&icmpq1, smlsiz, &nsize, &sqre, &d__[st], &e[st], &work[u + st1], n, + &work[vt + st1], &iwork[k + st1], &work[difl + st1], &work[difr + st1], + &work[z__ + st1], &work[poles + st1], &iwork[givptr + st1], + &iwork[givcol + st1], n, &iwork[perm + st1], &work[givnum + st1], + &work[c__ + st1], &work[s + st1], &work[nwork], &iwork[iwk], info); + if (*info != 0) { + return 0; + } + bxst = bx + st1; + dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &b[st + b_dim1], ldb, &work[bxst], n, + &work[u + st1], n, &work[vt + st1], &iwork[k + st1], &work[difl + st1], + &work[difr + st1], &work[z__ + st1], &work[poles + st1], + &iwork[givptr + st1], &iwork[givcol + st1], n, &iwork[perm + st1], + &work[givnum + st1], &work[c__ + st1], &work[s + st1], &work[nwork], + &iwork[iwk], info); + if (*info != 0) { + return 0; + } + } + st = i__ + 1; + } + } + tol = rcnd * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1)); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if ((d__1 = d__[i__], abs(d__1)) <= tol) { + dlaset_((char *)"A", &c__1, nrhs, &c_b6, &c_b6, &work[bx + i__ - 1], n, (ftnlen)1); + } else { + ++(*rank); + dlascl_((char *)"G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &work[bx + i__ - 1], n, info, + (ftnlen)1); + } + d__[i__] = (d__1 = d__[i__], abs(d__1)); + } + icmpq2 = 1; + i__1 = nsub; + for (i__ = 1; i__ <= i__1; ++i__) { + st = iwork[i__]; + st1 = st - 1; + nsize = iwork[sizei + i__ - 1]; + bxst = bx + st1; + if (nsize == 1) { + dcopy_(nrhs, &work[bxst], n, &b[st + b_dim1], ldb); + } else if (nsize <= *smlsiz) { + dgemm_((char *)"T", (char *)"N", &nsize, nrhs, &nsize, &c_b11, &work[vt + st1], n, &work[bxst], n, + &c_b6, &b[st + b_dim1], ldb, (ftnlen)1, (ftnlen)1); + } else { + dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &work[bxst], n, &b[st + b_dim1], ldb, + &work[u + st1], n, &work[vt + st1], &iwork[k + st1], &work[difl + st1], + &work[difr + st1], &work[z__ + st1], &work[poles + st1], &iwork[givptr + st1], + &iwork[givcol + st1], n, &iwork[perm + st1], &work[givnum + st1], + &work[c__ + st1], &work[s + st1], &work[nwork], &iwork[iwk], info); + if (*info != 0) { + return 0; + } + } + } + dlascl_((char *)"G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, info, (ftnlen)1); + dlasrt_((char *)"D", n, &d__[1], info, (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], ldb, info, (ftnlen)1); + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlalsd.f b/lib/linalg/dlalsd.f deleted file mode 100644 index d22c45dc6e..0000000000 --- a/lib/linalg/dlalsd.f +++ /dev/null @@ -1,520 +0,0 @@ -*> \brief \b DLALSD uses the singular value decomposition of A to solve the least squares problem. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLALSD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, -* RANK, WORK, IWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, LDB, N, NRHS, RANK, SMLSIZ -* DOUBLE PRECISION RCOND -* .. -* .. Array Arguments .. -* INTEGER IWORK( * ) -* DOUBLE PRECISION B( LDB, * ), D( * ), E( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLALSD uses the singular value decomposition of A to solve the least -*> squares problem of finding X to minimize the Euclidean norm of each -*> column of A*X-B, where A is N-by-N upper bidiagonal, and X and B -*> are N-by-NRHS. The solution X overwrites B. -*> -*> The singular values of A smaller than RCOND times the largest -*> singular value are treated as zero in solving the least squares -*> problem; in this case a minimum norm solution is returned. -*> The actual singular values are returned in D in ascending order. -*> -*> This code makes very mild assumptions about floating point -*> arithmetic. It will work on machines with a guard digit in -*> add/subtract, or on those binary machines without guard digits -*> which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. -*> It could conceivably fail on hexadecimal or decimal machines -*> without guard digits, but we know of none. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': D and E define an upper bidiagonal matrix. -*> = 'L': D and E define a lower bidiagonal matrix. -*> \endverbatim -*> -*> \param[in] SMLSIZ -*> \verbatim -*> SMLSIZ is INTEGER -*> The maximum size of the subproblems at the bottom of the -*> computation tree. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The dimension of the bidiagonal matrix. N >= 0. -*> \endverbatim -*> -*> \param[in] NRHS -*> \verbatim -*> NRHS is INTEGER -*> The number of columns of B. NRHS must be at least 1. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry D contains the main diagonal of the bidiagonal -*> matrix. On exit, if INFO = 0, D contains its singular values. -*> \endverbatim -*> -*> \param[in,out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N-1) -*> Contains the super-diagonal entries of the bidiagonal matrix. -*> On exit, E has been destroyed. -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) -*> On input, B contains the right hand sides of the least -*> squares problem. On output, B contains the solution X. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of B in the calling subprogram. -*> LDB must be at least max(1,N). -*> \endverbatim -*> -*> \param[in] RCOND -*> \verbatim -*> RCOND is DOUBLE PRECISION -*> The singular values of A less than or equal to RCOND times -*> the largest singular value are treated as zero in solving -*> the least squares problem. If RCOND is negative, -*> machine precision is used instead. -*> For example, if diag(S)*X=B were the least squares problem, -*> where diag(S) is a diagonal matrix of singular values, the -*> solution would be X(i) = B(i) / S(i) if S(i) is greater than -*> RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to -*> RCOND*max(S). -*> \endverbatim -*> -*> \param[out] RANK -*> \verbatim -*> RANK is INTEGER -*> The number of singular values of A greater than RCOND times -*> the largest singular value. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension at least -*> (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2), -*> where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1). -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, dimension at least -*> (3*N*NLVL + 11*N) -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit. -*> < 0: if INFO = -i, the i-th argument had an illegal value. -*> > 0: The algorithm failed to compute a singular value while -*> working on the submatrix lying in rows and columns -*> INFO/(N+1) through MOD(INFO,N+1). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -*> \par Contributors: -* ================== -*> -*> Ming Gu and Ren-Cang Li, Computer Science Division, University of -*> California at Berkeley, USA \n -*> Osni Marques, LBNL/NERSC, USA \n -* -* ===================================================================== - SUBROUTINE DLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, - $ RANK, WORK, IWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDB, N, NRHS, RANK, SMLSIZ - DOUBLE PRECISION RCOND -* .. -* .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION B( LDB, * ), D( * ), E( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) -* .. -* .. Local Scalars .. - INTEGER BX, BXST, C, DIFL, DIFR, GIVCOL, GIVNUM, - $ GIVPTR, I, ICMPQ1, ICMPQ2, IWK, J, K, NLVL, - $ NM1, NSIZE, NSUB, NWORK, PERM, POLES, S, SIZEI, - $ SMLSZP, SQRE, ST, ST1, U, VT, Z - DOUBLE PRECISION CS, EPS, ORGNRM, R, RCND, SN, TOL -* .. -* .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH, DLANST - EXTERNAL IDAMAX, DLAMCH, DLANST -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DLACPY, DLALSA, DLARTG, DLASCL, - $ DLASDA, DLASDQ, DLASET, DLASRT, DROT, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, LOG, SIGN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( NRHS.LT.1 ) THEN - INFO = -4 - ELSE IF( ( LDB.LT.1 ) .OR. ( LDB.LT.N ) ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLALSD', -INFO ) - RETURN - END IF -* - EPS = DLAMCH( 'Epsilon' ) -* -* Set up the tolerance. -* - IF( ( RCOND.LE.ZERO ) .OR. ( RCOND.GE.ONE ) ) THEN - RCND = EPS - ELSE - RCND = RCOND - END IF -* - RANK = 0 -* -* Quick return if possible. -* - IF( N.EQ.0 ) THEN - RETURN - ELSE IF( N.EQ.1 ) THEN - IF( D( 1 ).EQ.ZERO ) THEN - CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, B, LDB ) - ELSE - RANK = 1 - CALL DLASCL( 'G', 0, 0, D( 1 ), ONE, 1, NRHS, B, LDB, INFO ) - D( 1 ) = ABS( D( 1 ) ) - END IF - RETURN - END IF -* -* Rotate the matrix if it is lower bidiagonal. -* - IF( UPLO.EQ.'L' ) THEN - DO 10 I = 1, N - 1 - CALL 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( NRHS.EQ.1 ) THEN - CALL DROT( 1, B( I, 1 ), 1, B( I+1, 1 ), 1, CS, SN ) - ELSE - WORK( I*2-1 ) = CS - WORK( I*2 ) = SN - END IF - 10 CONTINUE - IF( NRHS.GT.1 ) THEN - DO 30 I = 1, NRHS - DO 20 J = 1, N - 1 - CS = WORK( J*2-1 ) - SN = WORK( J*2 ) - CALL DROT( 1, B( J, I ), 1, B( J+1, I ), 1, CS, SN ) - 20 CONTINUE - 30 CONTINUE - END IF - END IF -* -* Scale. -* - NM1 = N - 1 - ORGNRM = DLANST( 'M', N, D, E ) - IF( ORGNRM.EQ.ZERO ) THEN - CALL DLASET( 'A', N, NRHS, ZERO, ZERO, B, LDB ) - RETURN - END IF -* - CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO ) - CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, INFO ) -* -* If N is smaller than the minimum divide size SMLSIZ, then solve -* the problem with another solver. -* - IF( N.LE.SMLSIZ ) THEN - NWORK = 1 + N*N - CALL DLASET( 'A', N, N, ZERO, ONE, WORK, N ) - CALL DLASDQ( 'U', 0, N, N, 0, NRHS, D, E, WORK, N, WORK, N, B, - $ LDB, WORK( NWORK ), INFO ) - IF( INFO.NE.0 ) THEN - RETURN - END IF - TOL = RCND*ABS( D( IDAMAX( N, D, 1 ) ) ) - DO 40 I = 1, N - IF( D( I ).LE.TOL ) THEN - CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB ) - ELSE - CALL DLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS, B( I, 1 ), - $ LDB, INFO ) - RANK = RANK + 1 - END IF - 40 CONTINUE - CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, WORK, N, B, LDB, ZERO, - $ WORK( NWORK ), N ) - CALL DLACPY( 'A', N, NRHS, WORK( NWORK ), N, B, LDB ) -* -* Unscale. -* - CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO ) - CALL DLASRT( 'D', N, D, INFO ) - CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO ) -* - RETURN - END IF -* -* Book-keeping and setting up some constants. -* - NLVL = INT( LOG( DBLE( N ) / DBLE( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1 -* - SMLSZP = SMLSIZ + 1 -* - U = 1 - VT = 1 + SMLSIZ*N - DIFL = VT + SMLSZP*N - DIFR = DIFL + NLVL*N - Z = DIFR + NLVL*N*2 - C = Z + NLVL*N - S = C + N - POLES = S + N - GIVNUM = POLES + 2*NLVL*N - BX = GIVNUM + 2*NLVL*N - NWORK = BX + N*NRHS -* - SIZEI = 1 + N - K = SIZEI + N - GIVPTR = K + N - PERM = GIVPTR + N - GIVCOL = PERM + NLVL*N - IWK = GIVCOL + NLVL*N*2 -* - ST = 1 - SQRE = 0 - ICMPQ1 = 1 - ICMPQ2 = 0 - NSUB = 0 -* - DO 50 I = 1, N - IF( ABS( D( I ) ).LT.EPS ) THEN - D( I ) = SIGN( EPS, D( I ) ) - END IF - 50 CONTINUE -* - DO 60 I = 1, NM1 - IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN - NSUB = NSUB + 1 - IWORK( NSUB ) = ST -* -* Subproblem found. First determine its size and then -* apply divide and conquer on it. -* - IF( I.LT.NM1 ) THEN -* -* A subproblem with E(I) small for I < NM1. -* - NSIZE = I - ST + 1 - IWORK( SIZEI+NSUB-1 ) = NSIZE - ELSE IF( ABS( E( I ) ).GE.EPS ) THEN -* -* A subproblem with E(NM1) not too small but I = NM1. -* - NSIZE = N - ST + 1 - IWORK( SIZEI+NSUB-1 ) = NSIZE - ELSE -* -* A subproblem with E(NM1) small. This implies an -* 1-by-1 subproblem at D(N), which is not solved -* explicitly. -* - NSIZE = I - ST + 1 - IWORK( SIZEI+NSUB-1 ) = NSIZE - NSUB = NSUB + 1 - IWORK( NSUB ) = N - IWORK( SIZEI+NSUB-1 ) = 1 - CALL DCOPY( NRHS, B( N, 1 ), LDB, WORK( BX+NM1 ), N ) - END IF - ST1 = ST - 1 - IF( NSIZE.EQ.1 ) THEN -* -* This is a 1-by-1 subproblem and is not solved -* explicitly. -* - CALL DCOPY( NRHS, B( ST, 1 ), LDB, WORK( BX+ST1 ), N ) - ELSE IF( NSIZE.LE.SMLSIZ ) THEN -* -* This is a small subproblem and is solved by DLASDQ. -* - CALL DLASET( 'A', NSIZE, NSIZE, ZERO, ONE, - $ WORK( VT+ST1 ), N ) - CALL DLASDQ( 'U', 0, NSIZE, NSIZE, 0, NRHS, D( ST ), - $ E( ST ), WORK( VT+ST1 ), N, WORK( NWORK ), - $ N, B( ST, 1 ), LDB, WORK( NWORK ), INFO ) - IF( INFO.NE.0 ) THEN - RETURN - END IF - CALL DLACPY( 'A', NSIZE, NRHS, B( ST, 1 ), LDB, - $ WORK( BX+ST1 ), N ) - ELSE -* -* A large problem. Solve it using divide and conquer. -* - CALL DLASDA( ICMPQ1, SMLSIZ, NSIZE, SQRE, D( ST ), - $ E( ST ), WORK( U+ST1 ), N, WORK( VT+ST1 ), - $ IWORK( K+ST1 ), WORK( DIFL+ST1 ), - $ WORK( DIFR+ST1 ), WORK( Z+ST1 ), - $ WORK( POLES+ST1 ), IWORK( GIVPTR+ST1 ), - $ IWORK( GIVCOL+ST1 ), N, IWORK( PERM+ST1 ), - $ WORK( GIVNUM+ST1 ), WORK( C+ST1 ), - $ WORK( S+ST1 ), WORK( NWORK ), IWORK( IWK ), - $ INFO ) - IF( INFO.NE.0 ) THEN - RETURN - END IF - BXST = BX + ST1 - CALL DLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, B( ST, 1 ), - $ LDB, WORK( BXST ), N, WORK( U+ST1 ), N, - $ WORK( VT+ST1 ), IWORK( K+ST1 ), - $ WORK( DIFL+ST1 ), WORK( DIFR+ST1 ), - $ WORK( Z+ST1 ), WORK( POLES+ST1 ), - $ IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N, - $ IWORK( PERM+ST1 ), WORK( GIVNUM+ST1 ), - $ WORK( C+ST1 ), WORK( S+ST1 ), WORK( NWORK ), - $ IWORK( IWK ), INFO ) - IF( INFO.NE.0 ) THEN - RETURN - END IF - END IF - ST = I + 1 - END IF - 60 CONTINUE -* -* Apply the singular values and treat the tiny ones as zero. -* - TOL = RCND*ABS( D( IDAMAX( N, D, 1 ) ) ) -* - DO 70 I = 1, N -* -* Some of the elements in D can be negative because 1-by-1 -* subproblems were not solved explicitly. -* - IF( ABS( D( I ) ).LE.TOL ) THEN - CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, WORK( BX+I-1 ), N ) - ELSE - RANK = RANK + 1 - CALL DLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS, - $ WORK( BX+I-1 ), N, INFO ) - END IF - D( I ) = ABS( D( I ) ) - 70 CONTINUE -* -* Now apply back the right singular vectors. -* - ICMPQ2 = 1 - DO 80 I = 1, NSUB - ST = IWORK( I ) - ST1 = ST - 1 - NSIZE = IWORK( SIZEI+I-1 ) - BXST = BX + ST1 - IF( NSIZE.EQ.1 ) THEN - CALL DCOPY( NRHS, WORK( BXST ), N, B( ST, 1 ), LDB ) - ELSE IF( NSIZE.LE.SMLSIZ ) THEN - CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE, - $ WORK( VT+ST1 ), N, WORK( BXST ), N, ZERO, - $ B( ST, 1 ), LDB ) - ELSE - CALL DLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, WORK( BXST ), N, - $ B( ST, 1 ), LDB, WORK( U+ST1 ), N, - $ WORK( VT+ST1 ), IWORK( K+ST1 ), - $ WORK( DIFL+ST1 ), WORK( DIFR+ST1 ), - $ WORK( Z+ST1 ), WORK( POLES+ST1 ), - $ IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N, - $ IWORK( PERM+ST1 ), WORK( GIVNUM+ST1 ), - $ WORK( C+ST1 ), WORK( S+ST1 ), WORK( NWORK ), - $ IWORK( IWK ), INFO ) - IF( INFO.NE.0 ) THEN - RETURN - END IF - END IF - 80 CONTINUE -* -* Unscale and sort the singular values. -* - CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO ) - CALL DLASRT( 'D', N, D, INFO ) - CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO ) -* - RETURN -* -* End of DLALSD -* - END diff --git a/lib/linalg/dlamc3.cpp b/lib/linalg/dlamc3.cpp new file mode 100644 index 0000000000..0c33327867 --- /dev/null +++ b/lib/linalg/dlamc3.cpp @@ -0,0 +1,13 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +doublereal dlamc3_(doublereal *a, doublereal *b) +{ + doublereal ret_val; + ret_val = *a + *b; + return ret_val; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlamch.cpp b/lib/linalg/dlamch.cpp new file mode 100644 index 0000000000..277096e6f3 --- /dev/null +++ b/lib/linalg/dlamch.cpp @@ -0,0 +1,45 @@ + +#include +#include + +extern "C" { + +#include "lmp_f2c.h" + +// undefine conflicting f2c macros +#undef min +#undef max + +doublereal dlamch_(const char *cmach) +{ + if (!cmach) return 0.0; + char select = toupper(*cmach); + + // BLAS assumes rounding not truncation => epsilon is half + const double eps = 0.5 * std::numeric_limits::epsilon(); + if (select == 'E') return eps; + + double min = std::numeric_limits::min(); + const double max = std::numeric_limits::max(); + double small = 1.0 / max; + if (small >= min) min = small * (1.0 + eps); + if (select == 'S') return min; + + const double radix = std::numeric_limits::radix; + if (select == 'B') return radix; + + if (select == 'P') return eps * radix; + + if (select == 'N') return std::numeric_limits::digits; + + if (select == 'M') return std::numeric_limits::min_exponent; + + if (select == 'U') return min; + + if (select == 'L') return std::numeric_limits::max_exponent; + + if (select == 'O') return max; + + return 0.0; +} +} diff --git a/lib/linalg/dlamch.f b/lib/linalg/dlamch.f deleted file mode 100644 index 76f875cef6..0000000000 --- a/lib/linalg/dlamch.f +++ /dev/null @@ -1,189 +0,0 @@ -*> \brief \b DLAMCH -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAMCH determines double precision machine parameters. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] CMACH -*> \verbatim -*> Specifies the value to be returned by DLAMCH: -*> = 'E' or 'e', DLAMCH := eps -*> = 'S' or 's , DLAMCH := sfmin -*> = 'B' or 'b', DLAMCH := base -*> = 'P' or 'p', DLAMCH := eps*base -*> = 'N' or 'n', DLAMCH := t -*> = 'R' or 'r', DLAMCH := rnd -*> = 'M' or 'm', DLAMCH := emin -*> = 'U' or 'u', DLAMCH := rmin -*> = 'L' or 'l', DLAMCH := emax -*> = 'O' or 'o', DLAMCH := rmax -*> where -*> eps = relative machine precision -*> sfmin = safe minimum, such that 1/sfmin does not overflow -*> base = base of the machine -*> prec = eps*base -*> t = number of (base) digits in the mantissa -*> rnd = 1.0 when rounding occurs in addition, 0.0 otherwise -*> emin = minimum exponent before (gradual) underflow -*> rmin = underflow threshold - base**(emin-1) -*> emax = largest exponent before overflow -*> rmax = overflow threshold - (base**emax)*(1-eps) -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date December 2016 -* -*> \ingroup auxOTHERauxiliary -* -* ===================================================================== - DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) -* -* -- LAPACK auxiliary routine (version 3.7.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - CHARACTER CMACH -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION RND, EPS, SFMIN, SMALL, RMACH -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC DIGITS, EPSILON, HUGE, MAXEXPONENT, - $ MINEXPONENT, RADIX, TINY -* .. -* .. Executable Statements .. -* -* -* Assume rounding, not chopping. Always. -* - RND = ONE -* - IF( ONE.EQ.RND ) THEN - EPS = EPSILON(ZERO) * 0.5 - ELSE - EPS = EPSILON(ZERO) - END IF -* - IF( LSAME( CMACH, 'E' ) ) THEN - RMACH = EPS - ELSE IF( LSAME( CMACH, 'S' ) ) THEN - SFMIN = TINY(ZERO) - SMALL = ONE / HUGE(ZERO) - IF( SMALL.GE.SFMIN ) THEN -* -* Use SMALL plus a bit, to avoid the possibility of rounding -* causing overflow when computing 1/sfmin. -* - SFMIN = SMALL*( ONE+EPS ) - END IF - RMACH = SFMIN - ELSE IF( LSAME( CMACH, 'B' ) ) THEN - RMACH = RADIX(ZERO) - ELSE IF( LSAME( CMACH, 'P' ) ) THEN - RMACH = EPS * RADIX(ZERO) - ELSE IF( LSAME( CMACH, 'N' ) ) THEN - RMACH = DIGITS(ZERO) - ELSE IF( LSAME( CMACH, 'R' ) ) THEN - RMACH = RND - ELSE IF( LSAME( CMACH, 'M' ) ) THEN - RMACH = MINEXPONENT(ZERO) - ELSE IF( LSAME( CMACH, 'U' ) ) THEN - RMACH = tiny(zero) - ELSE IF( LSAME( CMACH, 'L' ) ) THEN - RMACH = MAXEXPONENT(ZERO) - ELSE IF( LSAME( CMACH, 'O' ) ) THEN - RMACH = HUGE(ZERO) - ELSE - RMACH = ZERO - END IF -* - DLAMCH = RMACH - RETURN -* -* End of DLAMCH -* - END -************************************************************************ -*> \brief \b DLAMC3 -*> \details -*> \b Purpose: -*> \verbatim -*> DLAMC3 is intended to force A and B to be stored prior to doing -*> the addition of A and B , for use in situations where optimizers -*> might hold one of these in a register. -*> \endverbatim -*> \author LAPACK is a software package provided by Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. -*> \date December 2016 -*> \ingroup auxOTHERauxiliary -*> -*> \param[in] A -*> \verbatim -*> A is a DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in] B -*> \verbatim -*> B is a DOUBLE PRECISION -*> The values A and B. -*> \endverbatim -*> - DOUBLE PRECISION FUNCTION DLAMC3( A, B ) -* -* -- LAPACK auxiliary routine (version 3.7.0) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2010 -* -* .. Scalar Arguments .. - DOUBLE PRECISION A, B -* .. -* ===================================================================== -* -* .. Executable Statements .. -* - DLAMC3 = A + B -* - RETURN -* -* End of DLAMC3 -* - END -* -************************************************************************ diff --git a/lib/linalg/dlamrg.cpp b/lib/linalg/dlamrg.cpp new file mode 100644 index 0000000000..cb4d918840 --- /dev/null +++ b/lib/linalg/dlamrg.cpp @@ -0,0 +1,58 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dlamrg_(integer *n1, integer *n2, doublereal *a, integer *dtrd1, integer *dtrd2, integer *index) +{ + integer i__1; + integer i__, ind1, ind2, n1sv, n2sv; + --index; + --a; + n1sv = *n1; + n2sv = *n2; + if (*dtrd1 > 0) { + ind1 = 1; + } else { + ind1 = *n1; + } + if (*dtrd2 > 0) { + ind2 = *n1 + 1; + } else { + ind2 = *n1 + *n2; + } + i__ = 1; +L10: + if (n1sv > 0 && n2sv > 0) { + if (a[ind1] <= a[ind2]) { + index[i__] = ind1; + ++i__; + ind1 += *dtrd1; + --n1sv; + } else { + index[i__] = ind2; + ++i__; + ind2 += *dtrd2; + --n2sv; + } + goto L10; + } + if (n1sv == 0) { + i__1 = n2sv; + for (n1sv = 1; n1sv <= i__1; ++n1sv) { + index[i__] = ind2; + ++i__; + ind2 += *dtrd2; + } + } else { + i__1 = n1sv; + for (n2sv = 1; n2sv <= i__1; ++n2sv) { + index[i__] = ind1; + ++i__; + ind1 += *dtrd1; + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlamrg.f b/lib/linalg/dlamrg.f deleted file mode 100644 index 80bd354b97..0000000000 --- a/lib/linalg/dlamrg.f +++ /dev/null @@ -1,168 +0,0 @@ -*> \brief \b DLAMRG creates a permutation list to merge the entries of two independently sorted sets into a single set sorted in ascending order. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAMRG + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX ) -* -* .. Scalar Arguments .. -* INTEGER DTRD1, DTRD2, N1, N2 -* .. -* .. Array Arguments .. -* INTEGER INDEX( * ) -* DOUBLE PRECISION A( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAMRG will create a permutation list which will merge the elements -*> of A (which is composed of two independently sorted sets) into a -*> single set which is sorted in ascending order. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N1 -*> \verbatim -*> N1 is INTEGER -*> \endverbatim -*> -*> \param[in] N2 -*> \verbatim -*> N2 is INTEGER -*> These arguments contain the respective lengths of the two -*> sorted lists to be merged. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (N1+N2) -*> The first N1 elements of A contain a list of numbers which -*> are sorted in either ascending or descending order. Likewise -*> for the final N2 elements. -*> \endverbatim -*> -*> \param[in] DTRD1 -*> \verbatim -*> DTRD1 is INTEGER -*> \endverbatim -*> -*> \param[in] DTRD2 -*> \verbatim -*> DTRD2 is INTEGER -*> These are the strides to be taken through the array A. -*> Allowable strides are 1 and -1. They indicate whether a -*> subset of A is sorted in ascending (DTRDx = 1) or descending -*> (DTRDx = -1) order. -*> \endverbatim -*> -*> \param[out] INDEX -*> \verbatim -*> INDEX is INTEGER array, dimension (N1+N2) -*> On exit this array will contain a permutation such that -*> if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be -*> sorted in ascending order. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -* ===================================================================== - SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER DTRD1, DTRD2, N1, N2 -* .. -* .. Array Arguments .. - INTEGER INDEX( * ) - DOUBLE PRECISION A( * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, IND1, IND2, N1SV, N2SV -* .. -* .. Executable Statements .. -* - N1SV = N1 - N2SV = N2 - IF( DTRD1.GT.0 ) THEN - IND1 = 1 - ELSE - IND1 = N1 - END IF - IF( DTRD2.GT.0 ) THEN - IND2 = 1 + N1 - ELSE - IND2 = N1 + N2 - END IF - I = 1 -* while ( (N1SV > 0) & (N2SV > 0) ) - 10 CONTINUE - IF( N1SV.GT.0 .AND. N2SV.GT.0 ) THEN - IF( A( IND1 ).LE.A( IND2 ) ) THEN - INDEX( I ) = IND1 - I = I + 1 - IND1 = IND1 + DTRD1 - N1SV = N1SV - 1 - ELSE - INDEX( I ) = IND2 - I = I + 1 - IND2 = IND2 + DTRD2 - N2SV = N2SV - 1 - END IF - GO TO 10 - END IF -* end while - IF( N1SV.EQ.0 ) THEN - DO 20 N1SV = 1, N2SV - INDEX( I ) = IND2 - I = I + 1 - IND2 = IND2 + DTRD2 - 20 CONTINUE - ELSE -* N2SV .EQ. 0 - DO 30 N2SV = 1, N1SV - INDEX( I ) = IND1 - I = I + 1 - IND1 = IND1 + DTRD1 - 30 CONTINUE - END IF -* - RETURN -* -* End of DLAMRG -* - END diff --git a/lib/linalg/dlange.cpp b/lib/linalg/dlange.cpp new file mode 100644 index 0000000000..f6ef58d0b2 --- /dev/null +++ b/lib/linalg/dlange.cpp @@ -0,0 +1,83 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +doublereal dlange_(char *norm, integer *m, integer *n, doublereal *a, integer *lda, + doublereal *work, ftnlen norm_len) +{ + integer a_dim1, a_offset, i__1, i__2; + doublereal ret_val, d__1; + double sqrt(doublereal); + integer i__, j; + doublereal sum, temp, scale; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + doublereal value; + extern logical disnan_(doublereal *); + extern int dlassq_(integer *, doublereal *, integer *, doublereal *, doublereal *); + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --work; + if (min(*m, *n) == 0) { + value = 0.; + } else if (lsame_(norm, (char *)"M", (ftnlen)1, (ftnlen)1)) { + value = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + } + } else if (lsame_(norm, (char *)"O", (ftnlen)1, (ftnlen)1) || *(unsigned char *)norm == '1') { + value = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = 0.; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + sum += (d__1 = a[i__ + j * a_dim1], abs(d__1)); + } + if (value < sum || disnan_(&sum)) { + value = sum; + } + } + } else if (lsame_(norm, (char *)"I", (ftnlen)1, (ftnlen)1)) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)); + } + } + value = 0.; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = work[i__]; + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + } else if (lsame_(norm, (char *)"F", (ftnlen)1, (ftnlen)1) || lsame_(norm, (char *)"E", (ftnlen)1, (ftnlen)1)) { + scale = 0.; + sum = 1.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + dlassq_(m, &a[j * a_dim1 + 1], &c__1, &scale, &sum); + } + value = scale * sqrt(sum); + } + ret_val = value; + return ret_val; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlange.f b/lib/linalg/dlange.f deleted file mode 100644 index 9d214cb542..0000000000 --- a/lib/linalg/dlange.f +++ /dev/null @@ -1,208 +0,0 @@ -*> \brief \b DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of a general rectangular matrix. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLANGE + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) -* -* .. Scalar Arguments .. -* CHARACTER NORM -* INTEGER LDA, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLANGE returns the value of the one norm, or the Frobenius norm, or -*> the infinity norm, or the element of largest absolute value of a -*> real matrix A. -*> \endverbatim -*> -*> \return DLANGE -*> \verbatim -*> -*> DLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' -*> ( -*> ( norm1(A), NORM = '1', 'O' or 'o' -*> ( -*> ( normI(A), NORM = 'I' or 'i' -*> ( -*> ( normF(A), NORM = 'F', 'f', 'E' or 'e' -*> -*> where norm1 denotes the one norm of a matrix (maximum column sum), -*> normI denotes the infinity norm of a matrix (maximum row sum) and -*> normF denotes the Frobenius norm of a matrix (square root of sum of -*> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] NORM -*> \verbatim -*> NORM is CHARACTER*1 -*> Specifies the value to be returned in DLANGE as described -*> above. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. M >= 0. When M = 0, -*> DLANGE is set to zero. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. N >= 0. When N = 0, -*> DLANGE is set to zero. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> The m by n matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(M,1). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), -*> where LWORK >= M when NORM = 'I'; otherwise, WORK is not -*> referenced. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleGEauxiliary -* -* ===================================================================== - DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER NORM - INTEGER LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J - DOUBLE PRECISION SCALE, SUM, VALUE, TEMP -* .. -* .. External Subroutines .. - EXTERNAL DLASSQ -* .. -* .. External Functions .. - LOGICAL LSAME, DISNAN - EXTERNAL LSAME, DISNAN -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MIN, SQRT -* .. -* .. Executable Statements .. -* - IF( MIN( M, N ).EQ.0 ) THEN - VALUE = ZERO - ELSE IF( LSAME( NORM, 'M' ) ) THEN -* -* Find max(abs(A(i,j))). -* - VALUE = ZERO - DO 20 J = 1, N - DO 10 I = 1, M - TEMP = ABS( A( I, J ) ) - IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP - 10 CONTINUE - 20 CONTINUE - ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN -* -* Find norm1(A). -* - VALUE = ZERO - DO 40 J = 1, N - SUM = ZERO - DO 30 I = 1, M - SUM = SUM + ABS( A( I, J ) ) - 30 CONTINUE - IF( VALUE.LT.SUM .OR. DISNAN( SUM ) ) VALUE = SUM - 40 CONTINUE - ELSE IF( LSAME( NORM, 'I' ) ) THEN -* -* Find normI(A). -* - DO 50 I = 1, M - WORK( I ) = ZERO - 50 CONTINUE - DO 70 J = 1, N - DO 60 I = 1, M - WORK( I ) = WORK( I ) + ABS( A( I, J ) ) - 60 CONTINUE - 70 CONTINUE - VALUE = ZERO - DO 80 I = 1, M - TEMP = WORK( I ) - IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP - 80 CONTINUE - ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN -* -* Find normF(A). -* - SCALE = ZERO - SUM = ONE - DO 90 J = 1, N - CALL DLASSQ( M, A( 1, J ), 1, SCALE, SUM ) - 90 CONTINUE - VALUE = SCALE*SQRT( SUM ) - END IF -* - DLANGE = VALUE - RETURN -* -* End of DLANGE -* - END diff --git a/lib/linalg/dlanst.cpp b/lib/linalg/dlanst.cpp new file mode 100644 index 0000000000..5b401bd0d9 --- /dev/null +++ b/lib/linalg/dlanst.cpp @@ -0,0 +1,69 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +doublereal dlanst_(char *norm, integer *n, doublereal *d__, doublereal *e, ftnlen norm_len) +{ + integer i__1; + doublereal ret_val, d__1, d__2, d__3; + double sqrt(doublereal); + integer i__; + doublereal sum, scale; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + doublereal anorm; + extern logical disnan_(doublereal *); + extern int dlassq_(integer *, doublereal *, integer *, doublereal *, doublereal *); + --e; + --d__; + if (*n <= 0) { + anorm = 0.; + } else if (lsame_(norm, (char *)"M", (ftnlen)1, (ftnlen)1)) { + anorm = (d__1 = d__[*n], abs(d__1)); + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = (d__1 = d__[i__], abs(d__1)); + if (anorm < sum || disnan_(&sum)) { + anorm = sum; + } + sum = (d__1 = e[i__], abs(d__1)); + if (anorm < sum || disnan_(&sum)) { + anorm = sum; + } + } + } else if (lsame_(norm, (char *)"O", (ftnlen)1, (ftnlen)1) || *(unsigned char *)norm == '1' || + lsame_(norm, (char *)"I", (ftnlen)1, (ftnlen)1)) { + if (*n == 1) { + anorm = abs(d__[1]); + } else { + anorm = abs(d__[1]) + abs(e[1]); + sum = (d__1 = e[*n - 1], abs(d__1)) + (d__2 = d__[*n], abs(d__2)); + if (anorm < sum || disnan_(&sum)) { + anorm = sum; + } + i__1 = *n - 1; + for (i__ = 2; i__ <= i__1; ++i__) { + sum = (d__1 = d__[i__], abs(d__1)) + (d__2 = e[i__], abs(d__2)) + + (d__3 = e[i__ - 1], abs(d__3)); + if (anorm < sum || disnan_(&sum)) { + anorm = sum; + } + } + } + } else if (lsame_(norm, (char *)"F", (ftnlen)1, (ftnlen)1) || lsame_(norm, (char *)"E", (ftnlen)1, (ftnlen)1)) { + scale = 0.; + sum = 1.; + if (*n > 1) { + i__1 = *n - 1; + dlassq_(&i__1, &e[1], &c__1, &scale, &sum); + sum *= 2; + } + dlassq_(n, &d__[1], &c__1, &scale, &sum); + anorm = scale * sqrt(sum); + } + ret_val = anorm; + return ret_val; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlanst.f b/lib/linalg/dlanst.f deleted file mode 100644 index c5bc7ea038..0000000000 --- a/lib/linalg/dlanst.f +++ /dev/null @@ -1,183 +0,0 @@ -*> \brief \b DLANST returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric tridiagonal matrix. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLANST + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) -* -* .. Scalar Arguments .. -* CHARACTER NORM -* INTEGER N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION D( * ), E( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLANST returns the value of the one norm, or the Frobenius norm, or -*> the infinity norm, or the element of largest absolute value of a -*> real symmetric tridiagonal matrix A. -*> \endverbatim -*> -*> \return DLANST -*> \verbatim -*> -*> DLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm' -*> ( -*> ( norm1(A), NORM = '1', 'O' or 'o' -*> ( -*> ( normI(A), NORM = 'I' or 'i' -*> ( -*> ( normF(A), NORM = 'F', 'f', 'E' or 'e' -*> -*> where norm1 denotes the one norm of a matrix (maximum column sum), -*> normI denotes the infinity norm of a matrix (maximum row sum) and -*> normF denotes the Frobenius norm of a matrix (square root of sum of -*> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] NORM -*> \verbatim -*> NORM is CHARACTER*1 -*> Specifies the value to be returned in DLANST as described -*> above. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. When N = 0, DLANST is -*> set to zero. -*> \endverbatim -*> -*> \param[in] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> The diagonal elements of A. -*> \endverbatim -*> -*> \param[in] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N-1) -*> The (n-1) sub-diagonal or super-diagonal elements of A. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER NORM - INTEGER N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), E( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I - DOUBLE PRECISION ANORM, SCALE, SUM -* .. -* .. External Functions .. - LOGICAL LSAME, DISNAN - EXTERNAL LSAME, DISNAN -* .. -* .. External Subroutines .. - EXTERNAL DLASSQ -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -* .. -* .. Executable Statements .. -* - IF( N.LE.0 ) THEN - ANORM = ZERO - ELSE IF( LSAME( NORM, 'M' ) ) THEN -* -* Find max(abs(A(i,j))). -* - ANORM = ABS( D( N ) ) - DO 10 I = 1, N - 1 - SUM = ABS( D( I ) ) - IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM - SUM = ABS( E( I ) ) - IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM - 10 CONTINUE - ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR. - $ LSAME( NORM, 'I' ) ) THEN -* -* Find norm1(A). -* - IF( N.EQ.1 ) THEN - ANORM = ABS( D( 1 ) ) - ELSE - ANORM = ABS( D( 1 ) )+ABS( E( 1 ) ) - SUM = ABS( E( N-1 ) )+ABS( D( N ) ) - IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM - DO 20 I = 2, N - 1 - SUM = ABS( D( I ) )+ABS( E( I ) )+ABS( E( I-1 ) ) - IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM - 20 CONTINUE - END IF - ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN -* -* Find normF(A). -* - SCALE = ZERO - SUM = ONE - IF( N.GT.1 ) THEN - CALL DLASSQ( N-1, E, 1, SCALE, SUM ) - SUM = 2*SUM - END IF - CALL DLASSQ( N, D, 1, SCALE, SUM ) - ANORM = SCALE*SQRT( SUM ) - END IF -* - DLANST = ANORM - RETURN -* -* End of DLANST -* - END diff --git a/lib/linalg/dlansy.cpp b/lib/linalg/dlansy.cpp new file mode 100644 index 0000000000..296605e896 --- /dev/null +++ b/lib/linalg/dlansy.cpp @@ -0,0 +1,116 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +doublereal dlansy_(char *norm, char *uplo, integer *n, doublereal *a, integer *lda, + doublereal *work, ftnlen norm_len, ftnlen uplo_len) +{ + integer a_dim1, a_offset, i__1, i__2; + doublereal ret_val, d__1; + double sqrt(doublereal); + integer i__, j; + doublereal sum, absa, scale; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + doublereal value; + extern logical disnan_(doublereal *); + extern int dlassq_(integer *, doublereal *, integer *, doublereal *, doublereal *); + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --work; + if (*n == 0) { + value = 0.; + } else if (lsame_(norm, (char *)"M", (ftnlen)1, (ftnlen)1)) { + value = 0.; + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + sum = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + if (value < sum || disnan_(&sum)) { + value = sum; + } + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + sum = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + if (value < sum || disnan_(&sum)) { + value = sum; + } + } + } + } + } else if (lsame_(norm, (char *)"I", (ftnlen)1, (ftnlen)1) || lsame_(norm, (char *)"O", (ftnlen)1, (ftnlen)1) || + *(unsigned char *)norm == '1') { + value = 0.; + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = 0.; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + absa = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + sum += absa; + work[i__] += absa; + } + work[j] = sum + (d__1 = a[j + j * a_dim1], abs(d__1)); + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = work[i__]; + if (value < sum || disnan_(&sum)) { + value = sum; + } + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = work[j] + (d__1 = a[j + j * a_dim1], abs(d__1)); + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + absa = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + sum += absa; + work[i__] += absa; + } + if (value < sum || disnan_(&sum)) { + value = sum; + } + } + } + } else if (lsame_(norm, (char *)"F", (ftnlen)1, (ftnlen)1) || lsame_(norm, (char *)"E", (ftnlen)1, (ftnlen)1)) { + scale = 0.; + sum = 1.; + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + i__2 = j - 1; + dlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum); + } + } else { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = *n - j; + dlassq_(&i__2, &a[j + 1 + j * a_dim1], &c__1, &scale, &sum); + } + } + sum *= 2; + i__1 = *lda + 1; + dlassq_(n, &a[a_offset], &i__1, &scale, &sum); + value = scale * sqrt(sum); + } + ret_val = value; + return ret_val; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlansy.f b/lib/linalg/dlansy.f deleted file mode 100644 index 949c5535a2..0000000000 --- a/lib/linalg/dlansy.f +++ /dev/null @@ -1,238 +0,0 @@ -*> \brief \b DLANSY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric matrix. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLANSY + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK ) -* -* .. Scalar Arguments .. -* CHARACTER NORM, UPLO -* INTEGER LDA, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLANSY returns the value of the one norm, or the Frobenius norm, or -*> the infinity norm, or the element of largest absolute value of a -*> real symmetric matrix A. -*> \endverbatim -*> -*> \return DLANSY -*> \verbatim -*> -*> DLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm' -*> ( -*> ( norm1(A), NORM = '1', 'O' or 'o' -*> ( -*> ( normI(A), NORM = 'I' or 'i' -*> ( -*> ( normF(A), NORM = 'F', 'f', 'E' or 'e' -*> -*> where norm1 denotes the one norm of a matrix (maximum column sum), -*> normI denotes the infinity norm of a matrix (maximum row sum) and -*> normF denotes the Frobenius norm of a matrix (square root of sum of -*> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] NORM -*> \verbatim -*> NORM is CHARACTER*1 -*> Specifies the value to be returned in DLANSY as described -*> above. -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> Specifies whether the upper or lower triangular part of the -*> symmetric matrix A is to be referenced. -*> = 'U': Upper triangular part of A is referenced -*> = 'L': Lower triangular part of A is referenced -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. When N = 0, DLANSY is -*> set to zero. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> The symmetric matrix A. If UPLO = 'U', the leading n by n -*> upper triangular part of A contains the upper triangular part -*> of the matrix A, and the strictly lower triangular part of A -*> is not referenced. If UPLO = 'L', the leading n by n lower -*> triangular part of A contains the lower triangular part of -*> the matrix A, and the strictly upper triangular part of A is -*> not referenced. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(N,1). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), -*> where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, -*> WORK is not referenced. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleSYauxiliary -* -* ===================================================================== - DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER NORM, UPLO - INTEGER LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J - DOUBLE PRECISION ABSA, SCALE, SUM, VALUE -* .. -* .. External Subroutines .. - EXTERNAL DLASSQ -* .. -* .. External Functions .. - LOGICAL LSAME, DISNAN - EXTERNAL LSAME, DISNAN -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -* .. -* .. Executable Statements .. -* - IF( N.EQ.0 ) THEN - VALUE = ZERO - ELSE IF( LSAME( NORM, 'M' ) ) THEN -* -* Find max(abs(A(i,j))). -* - VALUE = ZERO - IF( LSAME( UPLO, 'U' ) ) THEN - DO 20 J = 1, N - DO 10 I = 1, J - SUM = ABS( A( I, J ) ) - IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1, N - DO 30 I = J, N - SUM = ABS( A( I, J ) ) - IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM - 30 CONTINUE - 40 CONTINUE - END IF - ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. - $ ( NORM.EQ.'1' ) ) THEN -* -* Find normI(A) ( = norm1(A), since A is symmetric). -* - VALUE = ZERO - IF( LSAME( UPLO, 'U' ) ) THEN - DO 60 J = 1, N - SUM = ZERO - DO 50 I = 1, J - 1 - ABSA = ABS( A( I, J ) ) - SUM = SUM + ABSA - WORK( I ) = WORK( I ) + ABSA - 50 CONTINUE - WORK( J ) = SUM + ABS( A( J, J ) ) - 60 CONTINUE - DO 70 I = 1, N - SUM = WORK( I ) - IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM - 70 CONTINUE - ELSE - DO 80 I = 1, N - WORK( I ) = ZERO - 80 CONTINUE - DO 100 J = 1, N - SUM = WORK( J ) + ABS( A( J, J ) ) - DO 90 I = J + 1, N - ABSA = ABS( A( I, J ) ) - SUM = SUM + ABSA - WORK( I ) = WORK( I ) + ABSA - 90 CONTINUE - IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM - 100 CONTINUE - END IF - ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN -* -* Find normF(A). -* - SCALE = ZERO - SUM = ONE - IF( LSAME( UPLO, 'U' ) ) THEN - DO 110 J = 2, N - CALL DLASSQ( J-1, A( 1, J ), 1, SCALE, SUM ) - 110 CONTINUE - ELSE - DO 120 J = 1, N - 1 - CALL DLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM ) - 120 CONTINUE - END IF - SUM = 2*SUM - CALL DLASSQ( N, A, LDA+1, SCALE, SUM ) - VALUE = SCALE*SQRT( SUM ) - END IF -* - DLANSY = VALUE - RETURN -* -* End of DLANSY -* - END diff --git a/lib/linalg/dlapy2.cpp b/lib/linalg/dlapy2.cpp new file mode 100644 index 0000000000..996878faaa --- /dev/null +++ b/lib/linalg/dlapy2.cpp @@ -0,0 +1,39 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +doublereal dlapy2_(doublereal *x, doublereal *y) +{ + doublereal ret_val, d__1; + double sqrt(doublereal); + logical x_is_nan__, y_is_nan__; + doublereal w, z__, xabs, yabs; + extern doublereal dlamch_(char *, ftnlen); + extern logical disnan_(doublereal *); + doublereal hugeval; + x_is_nan__ = disnan_(x); + y_is_nan__ = disnan_(y); + if (x_is_nan__) { + ret_val = *x; + } + if (y_is_nan__) { + ret_val = *y; + } + hugeval = dlamch_((char *)"Overflow", (ftnlen)8); + if (!(x_is_nan__ || y_is_nan__)) { + xabs = abs(*x); + yabs = abs(*y); + w = max(xabs, yabs); + z__ = min(xabs, yabs); + if (z__ == 0. || w > hugeval) { + ret_val = w; + } else { + d__1 = z__ / w; + ret_val = w * sqrt(d__1 * d__1 + 1.); + } + } + return ret_val; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlapy2.f b/lib/linalg/dlapy2.f deleted file mode 100644 index 1f63193bb7..0000000000 --- a/lib/linalg/dlapy2.f +++ /dev/null @@ -1,117 +0,0 @@ -*> \brief \b DLAPY2 returns sqrt(x2+y2). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAPY2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION X, Y -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary -*> overflow and unnecessary underflow. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] X -*> \verbatim -*> X is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in] Y -*> \verbatim -*> Y is DOUBLE PRECISION -*> X and Y specify the values x and y. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION X, Y -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION W, XABS, YABS, Z, HUGEVAL - LOGICAL X_IS_NAN, Y_IS_NAN -* .. -* .. External Functions .. - LOGICAL DISNAN - EXTERNAL DISNAN -* .. -* .. External Subroutines .. - DOUBLE PRECISION DLAMCH -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - X_IS_NAN = DISNAN( X ) - Y_IS_NAN = DISNAN( Y ) - IF ( X_IS_NAN ) DLAPY2 = X - IF ( Y_IS_NAN ) DLAPY2 = Y - HUGEVAL = DLAMCH( 'Overflow' ) -* - IF ( .NOT.( X_IS_NAN.OR.Y_IS_NAN ) ) THEN - XABS = ABS( X ) - YABS = ABS( Y ) - W = MAX( XABS, YABS ) - Z = MIN( XABS, YABS ) - IF( Z.EQ.ZERO .OR. W.GT.HUGEVAL ) THEN - DLAPY2 = W - ELSE - DLAPY2 = W*SQRT( ONE+( Z / W )**2 ) - END IF - END IF - RETURN -* -* End of DLAPY2 -* - END diff --git a/lib/linalg/dlapy3.cpp b/lib/linalg/dlapy3.cpp new file mode 100644 index 0000000000..c6fd054f4a --- /dev/null +++ b/lib/linalg/dlapy3.cpp @@ -0,0 +1,30 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +doublereal dlapy3_(doublereal *x, doublereal *y, doublereal *z__) +{ + doublereal ret_val, d__1, d__2, d__3; + double sqrt(doublereal); + doublereal w, xabs, yabs, zabs; + extern doublereal dlamch_(char *, ftnlen); + doublereal hugeval; + hugeval = dlamch_((char *)"Overflow", (ftnlen)8); + xabs = abs(*x); + yabs = abs(*y); + zabs = abs(*z__); + d__1 = max(xabs, yabs); + w = max(d__1, zabs); + if (w == 0. || w > hugeval) { + ret_val = xabs + yabs + zabs; + } else { + d__1 = xabs / w; + d__2 = yabs / w; + d__3 = zabs / w; + ret_val = w * sqrt(d__1 * d__1 + d__2 * d__2 + d__3 * d__3); + } + return ret_val; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlapy3.f b/lib/linalg/dlapy3.f deleted file mode 100644 index 230a65cdb2..0000000000 --- a/lib/linalg/dlapy3.f +++ /dev/null @@ -1,112 +0,0 @@ -*> \brief \b DLAPY3 returns sqrt(x2+y2+z2). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAPY3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z ) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION X, Y, Z -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause -*> unnecessary overflow and unnecessary underflow. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] X -*> \verbatim -*> X is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in] Y -*> \verbatim -*> Y is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in] Z -*> \verbatim -*> Z is DOUBLE PRECISION -*> X, Y and Z specify the values x, y and z. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION X, Y, Z -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION W, XABS, YABS, ZABS, HUGEVAL -* .. -* .. External Subroutines .. - DOUBLE PRECISION DLAMCH -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -* .. -* .. Executable Statements .. -* - HUGEVAL = DLAMCH( 'Overflow' ) - XABS = ABS( X ) - YABS = ABS( Y ) - ZABS = ABS( Z ) - W = MAX( XABS, YABS, ZABS ) - IF( W.EQ.ZERO .OR. W.GT.HUGEVAL ) THEN -* W can be zero for max(0,nan,0) -* adding all three entries together will make sure -* NaN will not disappear. - DLAPY3 = XABS + YABS + ZABS - ELSE - DLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+ - $ ( ZABS / W )**2 ) - END IF - RETURN -* -* End of DLAPY3 -* - END diff --git a/lib/linalg/dlarf.cpp b/lib/linalg/dlarf.cpp new file mode 100644 index 0000000000..8fcb290abb --- /dev/null +++ b/lib/linalg/dlarf.cpp @@ -0,0 +1,71 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static doublereal c_b4 = 1.; +static doublereal c_b5 = 0.; +static integer c__1 = 1; +int dlarf_(char *side, integer *m, integer *n, doublereal *v, integer *incv, doublereal *tau, + doublereal *c__, integer *ldc, doublereal *work, ftnlen side_len) +{ + integer c_dim1, c_offset; + doublereal d__1; + integer i__; + logical applyleft; + extern int dger_(integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, integer *); + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern int dgemv_(char *, integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, ftnlen); + integer lastc, lastv; + extern integer iladlc_(integer *, integer *, doublereal *, integer *), + iladlr_(integer *, integer *, doublereal *, integer *); + --v; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --work; + applyleft = lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1); + lastv = 0; + lastc = 0; + if (*tau != 0.) { + if (applyleft) { + lastv = *m; + } else { + lastv = *n; + } + if (*incv > 0) { + i__ = (lastv - 1) * *incv + 1; + } else { + i__ = 1; + } + while (lastv > 0 && v[i__] == 0.) { + --lastv; + i__ -= *incv; + } + if (applyleft) { + lastc = iladlc_(&lastv, n, &c__[c_offset], ldc); + } else { + lastc = iladlr_(m, &lastv, &c__[c_offset], ldc); + } + } + if (applyleft) { + if (lastv > 0) { + dgemv_((char *)"Transpose", &lastv, &lastc, &c_b4, &c__[c_offset], ldc, &v[1], incv, &c_b5, + &work[1], &c__1, (ftnlen)9); + d__1 = -(*tau); + dger_(&lastv, &lastc, &d__1, &v[1], incv, &work[1], &c__1, &c__[c_offset], ldc); + } + } else { + if (lastv > 0) { + dgemv_((char *)"No transpose", &lastc, &lastv, &c_b4, &c__[c_offset], ldc, &v[1], incv, &c_b5, + &work[1], &c__1, (ftnlen)12); + d__1 = -(*tau); + dger_(&lastc, &lastv, &d__1, &work[1], &c__1, &v[1], incv, &c__[c_offset], ldc); + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlarf.f b/lib/linalg/dlarf.f deleted file mode 100644 index ed21638645..0000000000 --- a/lib/linalg/dlarf.f +++ /dev/null @@ -1,224 +0,0 @@ -*> \brief \b DLARF applies an elementary reflector to a general rectangular matrix. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLARF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) -* -* .. Scalar Arguments .. -* CHARACTER SIDE -* INTEGER INCV, LDC, M, N -* DOUBLE PRECISION TAU -* .. -* .. Array Arguments .. -* DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLARF applies a real elementary reflector H to a real m by n matrix -*> C, from either the left or the right. H is represented in the form -*> -*> H = I - tau * v * v**T -*> -*> where tau is a real scalar and v is a real vector. -*> -*> If tau = 0, then H is taken to be the unit matrix. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': form H * C -*> = 'R': form C * H -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. -*> \endverbatim -*> -*> \param[in] V -*> \verbatim -*> V is DOUBLE PRECISION array, dimension -*> (1 + (M-1)*abs(INCV)) if SIDE = 'L' -*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R' -*> The vector v in the representation of H. V is not used if -*> TAU = 0. -*> \endverbatim -*> -*> \param[in] INCV -*> \verbatim -*> INCV is INTEGER -*> The increment between elements of v. INCV <> 0. -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION -*> The value tau in the representation of H. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension (LDC,N) -*> On entry, the m by n matrix C. -*> On exit, C is overwritten by the matrix H * C if SIDE = 'L', -*> or C * H if SIDE = 'R'. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension -*> (N) if SIDE = 'L' -*> or (M) if SIDE = 'R' -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER SIDE - INTEGER INCV, LDC, M, N - DOUBLE PRECISION TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL APPLYLEFT - INTEGER I, LASTV, LASTC -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DGER -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILADLR, ILADLC - EXTERNAL LSAME, ILADLR, ILADLC -* .. -* .. Executable Statements .. -* - APPLYLEFT = LSAME( SIDE, 'L' ) - LASTV = 0 - LASTC = 0 - IF( TAU.NE.ZERO ) THEN -! Set up variables for scanning V. LASTV begins pointing to the end -! of V. - IF( APPLYLEFT ) THEN - LASTV = M - ELSE - LASTV = N - END IF - IF( INCV.GT.0 ) THEN - I = 1 + (LASTV-1) * INCV - ELSE - I = 1 - END IF -! Look for the last non-zero row in V. - DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) - LASTV = LASTV - 1 - I = I - INCV - END DO - IF( APPLYLEFT ) THEN -! Scan for the last non-zero column in C(1:lastv,:). - LASTC = ILADLC(LASTV, N, C, LDC) - ELSE -! Scan for the last non-zero row in C(:,1:lastv). - LASTC = ILADLR(M, LASTV, C, LDC) - END IF - END IF -! Note that lastc.eq.0 renders the BLAS operations null; no special -! case is needed at this level. - IF( APPLYLEFT ) THEN -* -* Form H * C -* - IF( LASTV.GT.0 ) THEN -* -* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1) -* - CALL DGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V, INCV, - $ ZERO, WORK, 1 ) -* -* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**T -* - CALL DGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC ) - END IF - ELSE -* -* Form C * H -* - IF( LASTV.GT.0 ) THEN -* -* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) -* - CALL DGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC, - $ V, INCV, ZERO, WORK, 1 ) -* -* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**T -* - CALL DGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC ) - END IF - END IF - RETURN -* -* End of DLARF -* - END diff --git a/lib/linalg/dlarfb.cpp b/lib/linalg/dlarfb.cpp new file mode 100644 index 0000000000..83f301f9d2 --- /dev/null +++ b/lib/linalg/dlarfb.cpp @@ -0,0 +1,311 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +static doublereal c_b14 = 1.; +static doublereal c_b25 = -1.; +int dlarfb_(char *side, char *trans, char *direct, char *storev, integer *m, integer *n, integer *k, + doublereal *v, integer *ldv, doublereal *t, integer *ldt, doublereal *c__, integer *ldc, + doublereal *work, integer *ldwork, ftnlen side_len, ftnlen trans_len, ftnlen direct_len, + ftnlen storev_len) +{ + integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, work_offset, i__1, + i__2; + integer i__, j; + 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 dcopy_(integer *, doublereal *, integer *, doublereal *, integer *), + dtrmm_(char *, char *, char *, char *, integer *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); + char transt[1]; + v_dim1 = *ldv; + v_offset = 1 + v_dim1; + v -= v_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + work_dim1 = *ldwork; + work_offset = 1 + work_dim1; + work -= work_offset; + if (*m <= 0 || *n <= 0) { + return 0; + } + if (lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1)) { + *(unsigned char *)transt = 'T'; + } else { + *(unsigned char *)transt = 'N'; + } + if (lsame_(storev, (char *)"C", (ftnlen)1, (ftnlen)1)) { + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); + } + dtrmm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", n, k, &c_b14, &v[v_offset], ldv, + &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); + if (*m > *k) { + i__1 = *m - *k; + dgemm_((char *)"Transpose", (char *)"No transpose", n, k, &i__1, &c_b14, &c__[*k + 1 + c_dim1], + ldc, &v[*k + 1 + v_dim1], ldv, &c_b14, &work[work_offset], ldwork, + (ftnlen)9, (ftnlen)12); + } + dtrmm_((char *)"Right", (char *)"Upper", transt, (char *)"Non-unit", n, k, &c_b14, &t[t_offset], ldt, + &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)1, (ftnlen)8); + if (*m > *k) { + i__1 = *m - *k; + dgemm_((char *)"No transpose", (char *)"Transpose", &i__1, n, k, &c_b25, &v[*k + 1 + v_dim1], + ldv, &work[work_offset], ldwork, &c_b14, &c__[*k + 1 + c_dim1], ldc, + (ftnlen)12, (ftnlen)9); + } + dtrmm_((char *)"Right", (char *)"Lower", (char *)"Transpose", (char *)"Unit", n, k, &c_b14, &v[v_offset], ldv, + &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)9, (ftnlen)4); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1]; + } + } + } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &c__1); + } + dtrmm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", m, k, &c_b14, &v[v_offset], ldv, + &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); + if (*n > *k) { + i__1 = *n - *k; + dgemm_((char *)"No transpose", (char *)"No transpose", m, k, &i__1, &c_b14, + &c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k + 1 + v_dim1], ldv, &c_b14, + &work[work_offset], ldwork, (ftnlen)12, (ftnlen)12); + } + dtrmm_((char *)"Right", (char *)"Upper", trans, (char *)"Non-unit", m, k, &c_b14, &t[t_offset], ldt, + &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)1, (ftnlen)8); + if (*n > *k) { + i__1 = *n - *k; + dgemm_((char *)"No transpose", (char *)"Transpose", m, &i__1, k, &c_b25, &work[work_offset], + ldwork, &v[*k + 1 + v_dim1], ldv, &c_b14, &c__[(*k + 1) * c_dim1 + 1], + ldc, (ftnlen)12, (ftnlen)9); + } + dtrmm_((char *)"Right", (char *)"Lower", (char *)"Transpose", (char *)"Unit", m, k, &c_b14, &v[v_offset], ldv, + &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)9, (ftnlen)4); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1]; + } + } + } + } else { + if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); + } + dtrmm_((char *)"Right", (char *)"Upper", (char *)"No transpose", (char *)"Unit", n, k, &c_b14, + &v[*m - *k + 1 + v_dim1], ldv, &work[work_offset], ldwork, (ftnlen)5, + (ftnlen)5, (ftnlen)12, (ftnlen)4); + if (*m > *k) { + i__1 = *m - *k; + dgemm_((char *)"Transpose", (char *)"No transpose", n, k, &i__1, &c_b14, &c__[c_offset], ldc, + &v[v_offset], ldv, &c_b14, &work[work_offset], ldwork, (ftnlen)9, + (ftnlen)12); + } + dtrmm_((char *)"Right", (char *)"Lower", transt, (char *)"Non-unit", n, k, &c_b14, &t[t_offset], ldt, + &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)1, (ftnlen)8); + if (*m > *k) { + i__1 = *m - *k; + dgemm_((char *)"No transpose", (char *)"Transpose", &i__1, n, k, &c_b25, &v[v_offset], ldv, + &work[work_offset], ldwork, &c_b14, &c__[c_offset], ldc, (ftnlen)12, + (ftnlen)9); + } + dtrmm_((char *)"Right", (char *)"Upper", (char *)"Transpose", (char *)"Unit", n, k, &c_b14, + &v[*m - *k + 1 + v_dim1], ldv, &work[work_offset], ldwork, (ftnlen)5, + (ftnlen)5, (ftnlen)9, (ftnlen)4); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[*m - *k + j + i__ * c_dim1] -= work[i__ + j * work_dim1]; + } + } + } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], + &c__1); + } + dtrmm_((char *)"Right", (char *)"Upper", (char *)"No transpose", (char *)"Unit", m, k, &c_b14, + &v[*n - *k + 1 + v_dim1], ldv, &work[work_offset], ldwork, (ftnlen)5, + (ftnlen)5, (ftnlen)12, (ftnlen)4); + if (*n > *k) { + i__1 = *n - *k; + dgemm_((char *)"No transpose", (char *)"No transpose", m, k, &i__1, &c_b14, &c__[c_offset], ldc, + &v[v_offset], ldv, &c_b14, &work[work_offset], ldwork, (ftnlen)12, + (ftnlen)12); + } + dtrmm_((char *)"Right", (char *)"Lower", trans, (char *)"Non-unit", m, k, &c_b14, &t[t_offset], ldt, + &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)1, (ftnlen)8); + if (*n > *k) { + i__1 = *n - *k; + dgemm_((char *)"No transpose", (char *)"Transpose", m, &i__1, k, &c_b25, &work[work_offset], + ldwork, &v[v_offset], ldv, &c_b14, &c__[c_offset], ldc, (ftnlen)12, + (ftnlen)9); + } + dtrmm_((char *)"Right", (char *)"Upper", (char *)"Transpose", (char *)"Unit", m, k, &c_b14, + &v[*n - *k + 1 + v_dim1], ldv, &work[work_offset], ldwork, (ftnlen)5, + (ftnlen)5, (ftnlen)9, (ftnlen)4); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + (*n - *k + j) * c_dim1] -= work[i__ + j * work_dim1]; + } + } + } + } + } else if (lsame_(storev, (char *)"R", (ftnlen)1, (ftnlen)1)) { + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); + } + dtrmm_((char *)"Right", (char *)"Upper", (char *)"Transpose", (char *)"Unit", n, k, &c_b14, &v[v_offset], ldv, + &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)9, (ftnlen)4); + if (*m > *k) { + i__1 = *m - *k; + dgemm_((char *)"Transpose", (char *)"Transpose", n, k, &i__1, &c_b14, &c__[*k + 1 + c_dim1], + ldc, &v[(*k + 1) * v_dim1 + 1], ldv, &c_b14, &work[work_offset], ldwork, + (ftnlen)9, (ftnlen)9); + } + dtrmm_((char *)"Right", (char *)"Upper", transt, (char *)"Non-unit", n, k, &c_b14, &t[t_offset], ldt, + &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)1, (ftnlen)8); + if (*m > *k) { + i__1 = *m - *k; + dgemm_((char *)"Transpose", (char *)"Transpose", &i__1, n, k, &c_b25, &v[(*k + 1) * v_dim1 + 1], + ldv, &work[work_offset], ldwork, &c_b14, &c__[*k + 1 + c_dim1], ldc, + (ftnlen)9, (ftnlen)9); + } + dtrmm_((char *)"Right", (char *)"Upper", (char *)"No transpose", (char *)"Unit", n, k, &c_b14, &v[v_offset], ldv, + &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1]; + } + } + } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &c__1); + } + dtrmm_((char *)"Right", (char *)"Upper", (char *)"Transpose", (char *)"Unit", m, k, &c_b14, &v[v_offset], ldv, + &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)9, (ftnlen)4); + if (*n > *k) { + i__1 = *n - *k; + dgemm_((char *)"No transpose", (char *)"Transpose", m, k, &i__1, &c_b14, + &c__[(*k + 1) * c_dim1 + 1], ldc, &v[(*k + 1) * v_dim1 + 1], ldv, &c_b14, + &work[work_offset], ldwork, (ftnlen)12, (ftnlen)9); + } + dtrmm_((char *)"Right", (char *)"Upper", trans, (char *)"Non-unit", m, k, &c_b14, &t[t_offset], ldt, + &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)1, (ftnlen)8); + if (*n > *k) { + i__1 = *n - *k; + dgemm_((char *)"No transpose", (char *)"No transpose", m, &i__1, k, &c_b25, &work[work_offset], + ldwork, &v[(*k + 1) * v_dim1 + 1], ldv, &c_b14, + &c__[(*k + 1) * c_dim1 + 1], ldc, (ftnlen)12, (ftnlen)12); + } + dtrmm_((char *)"Right", (char *)"Upper", (char *)"No transpose", (char *)"Unit", m, k, &c_b14, &v[v_offset], ldv, + &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1]; + } + } + } + } else { + if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); + } + dtrmm_((char *)"Right", (char *)"Lower", (char *)"Transpose", (char *)"Unit", n, k, &c_b14, + &v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[work_offset], ldwork, (ftnlen)5, + (ftnlen)5, (ftnlen)9, (ftnlen)4); + if (*m > *k) { + i__1 = *m - *k; + dgemm_((char *)"Transpose", (char *)"Transpose", n, k, &i__1, &c_b14, &c__[c_offset], ldc, + &v[v_offset], ldv, &c_b14, &work[work_offset], ldwork, (ftnlen)9, + (ftnlen)9); + } + dtrmm_((char *)"Right", (char *)"Lower", transt, (char *)"Non-unit", n, k, &c_b14, &t[t_offset], ldt, + &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)1, (ftnlen)8); + if (*m > *k) { + i__1 = *m - *k; + dgemm_((char *)"Transpose", (char *)"Transpose", &i__1, n, k, &c_b25, &v[v_offset], ldv, + &work[work_offset], ldwork, &c_b14, &c__[c_offset], ldc, (ftnlen)9, + (ftnlen)9); + } + dtrmm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", n, k, &c_b14, + &v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[work_offset], ldwork, (ftnlen)5, + (ftnlen)5, (ftnlen)12, (ftnlen)4); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[*m - *k + j + i__ * c_dim1] -= work[i__ + j * work_dim1]; + } + } + } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], + &c__1); + } + dtrmm_((char *)"Right", (char *)"Lower", (char *)"Transpose", (char *)"Unit", m, k, &c_b14, + &v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[work_offset], ldwork, (ftnlen)5, + (ftnlen)5, (ftnlen)9, (ftnlen)4); + if (*n > *k) { + i__1 = *n - *k; + dgemm_((char *)"No transpose", (char *)"Transpose", m, k, &i__1, &c_b14, &c__[c_offset], ldc, + &v[v_offset], ldv, &c_b14, &work[work_offset], ldwork, (ftnlen)12, + (ftnlen)9); + } + dtrmm_((char *)"Right", (char *)"Lower", trans, (char *)"Non-unit", m, k, &c_b14, &t[t_offset], ldt, + &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)1, (ftnlen)8); + if (*n > *k) { + i__1 = *n - *k; + dgemm_((char *)"No transpose", (char *)"No transpose", m, &i__1, k, &c_b25, &work[work_offset], + ldwork, &v[v_offset], ldv, &c_b14, &c__[c_offset], ldc, (ftnlen)12, + (ftnlen)12); + } + dtrmm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", m, k, &c_b14, + &v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[work_offset], ldwork, (ftnlen)5, + (ftnlen)5, (ftnlen)12, (ftnlen)4); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + (*n - *k + j) * c_dim1] -= work[i__ + j * work_dim1]; + } + } + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlarfb.f b/lib/linalg/dlarfb.f deleted file mode 100644 index a3fa083b43..0000000000 --- a/lib/linalg/dlarfb.f +++ /dev/null @@ -1,709 +0,0 @@ -*> \brief \b DLARFB applies a block reflector or its transpose to a general rectangular matrix. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLARFB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, -* T, LDT, C, LDC, WORK, LDWORK ) -* -* .. Scalar Arguments .. -* CHARACTER DIRECT, SIDE, STOREV, TRANS -* INTEGER K, LDC, LDT, LDV, LDWORK, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), -* $ WORK( LDWORK, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLARFB applies a real block reflector H or its transpose H**T to a -*> real m by n matrix C, from either the left or the right. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': apply H or H**T from the Left -*> = 'R': apply H or H**T from the Right -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> = 'N': apply H (No transpose) -*> = 'T': apply H**T (Transpose) -*> \endverbatim -*> -*> \param[in] DIRECT -*> \verbatim -*> DIRECT is CHARACTER*1 -*> Indicates how H is formed from a product of elementary -*> reflectors -*> = 'F': H = H(1) H(2) . . . H(k) (Forward) -*> = 'B': H = H(k) . . . H(2) H(1) (Backward) -*> \endverbatim -*> -*> \param[in] STOREV -*> \verbatim -*> STOREV is CHARACTER*1 -*> Indicates how the vectors which define the elementary -*> reflectors are stored: -*> = 'C': Columnwise -*> = 'R': Rowwise -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The order of the matrix T (= the number of elementary -*> reflectors whose product defines the block reflector). -*> If SIDE = 'L', M >= K >= 0; -*> if SIDE = 'R', N >= K >= 0. -*> \endverbatim -*> -*> \param[in] V -*> \verbatim -*> V is DOUBLE PRECISION array, dimension -*> (LDV,K) if STOREV = 'C' -*> (LDV,M) if STOREV = 'R' and SIDE = 'L' -*> (LDV,N) if STOREV = 'R' and SIDE = 'R' -*> The matrix V. See Further Details. -*> \endverbatim -*> -*> \param[in] LDV -*> \verbatim -*> LDV is INTEGER -*> The leading dimension of the array V. -*> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); -*> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); -*> if STOREV = 'R', LDV >= K. -*> \endverbatim -*> -*> \param[in] T -*> \verbatim -*> T is DOUBLE PRECISION array, dimension (LDT,K) -*> The triangular k by k matrix T in the representation of the -*> block reflector. -*> \endverbatim -*> -*> \param[in] LDT -*> \verbatim -*> LDT is INTEGER -*> The leading dimension of the array T. LDT >= K. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension (LDC,N) -*> On entry, the m by n matrix C. -*> On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (LDWORK,K) -*> \endverbatim -*> -*> \param[in] LDWORK -*> \verbatim -*> LDWORK is INTEGER -*> The leading dimension of the array WORK. -*> If SIDE = 'L', LDWORK >= max(1,N); -*> if SIDE = 'R', LDWORK >= max(1,M). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The shape of the matrix V and the storage of the vectors which define -*> the H(i) is best illustrated by the following example with n = 5 and -*> k = 3. The elements equal to 1 are not stored; the corresponding -*> array elements are modified but restored on exit. The rest of the -*> array is not used. -*> -*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': -*> -*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) -*> ( v1 1 ) ( 1 v2 v2 v2 ) -*> ( v1 v2 1 ) ( 1 v3 v3 ) -*> ( v1 v2 v3 ) -*> ( v1 v2 v3 ) -*> -*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': -*> -*> V = ( v1 v2 v3 ) V = ( v1 v1 1 ) -*> ( v1 v2 v3 ) ( v2 v2 v2 1 ) -*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) -*> ( 1 v3 ) -*> ( 1 ) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, - $ T, LDT, C, LDC, WORK, LDWORK ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER DIRECT, SIDE, STOREV, TRANS - INTEGER K, LDC, LDT, LDV, LDWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), - $ WORK( LDWORK, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - CHARACTER TRANST - INTEGER I, J -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DTRMM -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( M.LE.0 .OR. N.LE.0 ) - $ RETURN -* - IF( LSAME( TRANS, 'N' ) ) THEN - TRANST = 'T' - ELSE - TRANST = 'N' - END IF -* - IF( LSAME( STOREV, 'C' ) ) THEN -* - IF( LSAME( DIRECT, 'F' ) ) THEN -* -* Let V = ( V1 ) (first K rows) -* ( V2 ) -* where V1 is unit lower triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**T * C where C = ( C1 ) -* ( C2 ) -* -* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK) -* -* W := C1**T -* - DO 10 J = 1, K - CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - 10 CONTINUE -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, - $ K, ONE, V, LDV, WORK, LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C2**T * V2 -* - CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, - $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T**T or W * T -* - CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V * W**T -* - IF( M.GT.K ) THEN -* -* C2 := C2 - V2 * W**T -* - CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, - $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, - $ C( K+1, 1 ), LDC ) - END IF -* -* W := W * V1**T -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, - $ ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W**T -* - DO 30 J = 1, K - DO 20 I = 1, N - C( J, I ) = C( J, I ) - WORK( I, J ) - 20 CONTINUE - 30 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**T where C = ( C1 C2 ) -* -* W := C * V = (C1*V1 + C2*V2) (stored in WORK) -* -* W := C1 -* - DO 40 J = 1, K - CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) - 40 CONTINUE -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, - $ K, ONE, V, LDV, WORK, LDWORK ) - IF( N.GT.K ) THEN -* -* W := W + C2 * V2 -* - CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, - $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T**T -* - CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V**T -* - IF( N.GT.K ) THEN -* -* C2 := C2 - W * V2**T -* - CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, - $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, - $ C( 1, K+1 ), LDC ) - END IF -* -* W := W * V1**T -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, - $ ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 60 J = 1, K - DO 50 I = 1, M - C( I, J ) = C( I, J ) - WORK( I, J ) - 50 CONTINUE - 60 CONTINUE - END IF -* - ELSE -* -* Let V = ( V1 ) -* ( V2 ) (last K rows) -* where V2 is unit upper triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**T * C where C = ( C1 ) -* ( C2 ) -* -* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK) -* -* W := C2**T -* - DO 70 J = 1, K - CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) - 70 CONTINUE -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, - $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C1**T * V1 -* - CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, - $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) - END IF -* -* W := W * T**T or W * T -* - CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V * W**T -* - IF( M.GT.K ) THEN -* -* C1 := C1 - V1 * W**T -* - CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, - $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) - END IF -* -* W := W * V2**T -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, - $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) -* -* C2 := C2 - W**T -* - DO 90 J = 1, K - DO 80 I = 1, N - C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) - 80 CONTINUE - 90 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**T where C = ( C1 C2 ) -* -* W := C * V = (C1*V1 + C2*V2) (stored in WORK) -* -* W := C2 -* - DO 100 J = 1, K - CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) - 100 CONTINUE -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, - $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) - IF( N.GT.K ) THEN -* -* W := W + C1 * V1 -* - CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, - $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T**T -* - CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V**T -* - IF( N.GT.K ) THEN -* -* C1 := C1 - W * V1**T -* - CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, - $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) - END IF -* -* W := W * V2**T -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, - $ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) -* -* C2 := C2 - W -* - DO 120 J = 1, K - DO 110 I = 1, M - C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) - 110 CONTINUE - 120 CONTINUE - END IF - END IF -* - ELSE IF( LSAME( STOREV, 'R' ) ) THEN -* - IF( LSAME( DIRECT, 'F' ) ) THEN -* -* Let V = ( V1 V2 ) (V1: first K columns) -* where V1 is unit upper triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**T * C where C = ( C1 ) -* ( C2 ) -* -* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK) -* -* W := C1**T -* - DO 130 J = 1, K - CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - 130 CONTINUE -* -* W := W * V1**T -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, - $ ONE, V, LDV, WORK, LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C2**T * V2**T -* - CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, - $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, - $ WORK, LDWORK ) - END IF -* -* W := W * T**T or W * T -* - CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V**T * W**T -* - IF( M.GT.K ) THEN -* -* C2 := C2 - V2**T * W**T -* - CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, - $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE, - $ C( K+1, 1 ), LDC ) - END IF -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, - $ K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W**T -* - DO 150 J = 1, K - DO 140 I = 1, N - C( J, I ) = C( J, I ) - WORK( I, J ) - 140 CONTINUE - 150 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**T where C = ( C1 C2 ) -* -* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) -* -* W := C1 -* - DO 160 J = 1, K - CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) - 160 CONTINUE -* -* W := W * V1**T -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, - $ ONE, V, LDV, WORK, LDWORK ) - IF( N.GT.K ) THEN -* -* W := W + C2 * V2**T -* - CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, - $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T**T -* - CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V -* - IF( N.GT.K ) THEN -* -* C2 := C2 - W * V2 -* - CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, - $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, - $ C( 1, K+1 ), LDC ) - END IF -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, - $ K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 180 J = 1, K - DO 170 I = 1, M - C( I, J ) = C( I, J ) - WORK( I, J ) - 170 CONTINUE - 180 CONTINUE -* - END IF -* - ELSE -* -* Let V = ( V1 V2 ) (V2: last K columns) -* where V2 is unit lower triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**T * C where C = ( C1 ) -* ( C2 ) -* -* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK) -* -* W := C2**T -* - DO 190 J = 1, K - CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) - 190 CONTINUE -* -* W := W * V2**T -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, - $ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C1**T * V1**T -* - CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, - $ C, LDC, V, LDV, ONE, WORK, LDWORK ) - END IF -* -* W := W * T**T or W * T -* - CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V**T * W**T -* - IF( M.GT.K ) THEN -* -* C1 := C1 - V1**T * W**T -* - CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, - $ V, LDV, WORK, LDWORK, ONE, C, LDC ) - END IF -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, - $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) -* -* C2 := C2 - W**T -* - DO 210 J = 1, K - DO 200 I = 1, N - C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) - 200 CONTINUE - 210 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H' where C = ( C1 C2 ) -* -* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) -* -* W := C2 -* - DO 220 J = 1, K - CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) - 220 CONTINUE -* -* W := W * V2**T -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, - $ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) - IF( N.GT.K ) THEN -* -* W := W + C1 * V1**T -* - CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, - $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T**T -* - CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V -* - IF( N.GT.K ) THEN -* -* C1 := C1 - W * V1 -* - CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, - $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) - END IF -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, - $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 240 J = 1, K - DO 230 I = 1, M - C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) - 230 CONTINUE - 240 CONTINUE -* - END IF -* - END IF - END IF -* - RETURN -* -* End of DLARFB -* - END diff --git a/lib/linalg/dlarfg.cpp b/lib/linalg/dlarfg.cpp new file mode 100644 index 0000000000..1dbdd82f66 --- /dev/null +++ b/lib/linalg/dlarfg.cpp @@ -0,0 +1,61 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dlarfg_(integer *n, doublereal *alpha, doublereal *x, integer *incx, doublereal *tau) +{ + integer i__1; + doublereal d__1; + double d_lmp_sign(doublereal *, doublereal *); + integer j, knt; + doublereal beta; + extern doublereal dnrm2_(integer *, doublereal *, integer *); + extern int dscal_(integer *, doublereal *, doublereal *, integer *); + doublereal xnorm; + extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, ftnlen); + doublereal safmin, rsafmn; + --x; + if (*n <= 1) { + *tau = 0.; + return 0; + } + i__1 = *n - 1; + xnorm = dnrm2_(&i__1, &x[1], incx); + if (xnorm == 0.) { + *tau = 0.; + } else { + d__1 = dlapy2_(alpha, &xnorm); + beta = -d_lmp_sign(&d__1, alpha); + safmin = dlamch_((char *)"S", (ftnlen)1) / dlamch_((char *)"E", (ftnlen)1); + knt = 0; + if (abs(beta) < safmin) { + rsafmn = 1. / safmin; + L10: + ++knt; + i__1 = *n - 1; + dscal_(&i__1, &rsafmn, &x[1], incx); + beta *= rsafmn; + *alpha *= rsafmn; + if (abs(beta) < safmin && knt < 20) { + goto L10; + } + i__1 = *n - 1; + xnorm = dnrm2_(&i__1, &x[1], incx); + d__1 = dlapy2_(alpha, &xnorm); + beta = -d_lmp_sign(&d__1, alpha); + } + *tau = (beta - *alpha) / beta; + i__1 = *n - 1; + d__1 = 1. / (*alpha - beta); + dscal_(&i__1, &d__1, &x[1], incx); + i__1 = knt; + for (j = 1; j <= i__1; ++j) { + beta *= safmin; + } + *alpha = beta; + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlarfg.f b/lib/linalg/dlarfg.f deleted file mode 100644 index 9bfb45a6b0..0000000000 --- a/lib/linalg/dlarfg.f +++ /dev/null @@ -1,193 +0,0 @@ -*> \brief \b DLARFG generates an elementary reflector (Householder matrix). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLARFG + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) -* -* .. Scalar Arguments .. -* INTEGER INCX, N -* DOUBLE PRECISION ALPHA, TAU -* .. -* .. Array Arguments .. -* DOUBLE PRECISION X( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLARFG generates a real elementary reflector H of order n, such -*> that -*> -*> H * ( alpha ) = ( beta ), H**T * H = I. -*> ( x ) ( 0 ) -*> -*> where alpha and beta are scalars, and x is an (n-1)-element real -*> vector. H is represented in the form -*> -*> H = I - tau * ( 1 ) * ( 1 v**T ) , -*> ( v ) -*> -*> where tau is a real scalar and v is a real (n-1)-element -*> vector. -*> -*> If the elements of x are all zero, then tau = 0 and H is taken to be -*> the unit matrix. -*> -*> Otherwise 1 <= tau <= 2. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the elementary reflector. -*> \endverbatim -*> -*> \param[in,out] ALPHA -*> \verbatim -*> ALPHA is DOUBLE PRECISION -*> On entry, the value alpha. -*> On exit, it is overwritten with the value beta. -*> \endverbatim -*> -*> \param[in,out] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension -*> (1+(N-2)*abs(INCX)) -*> On entry, the vector x. -*> On exit, it is overwritten with the vector v. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> The increment between elements of X. INCX > 0. -*> \endverbatim -*> -*> \param[out] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION -*> The value tau. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX, N - DOUBLE PRECISION ALPHA, TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION X( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER J, KNT - DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 - EXTERNAL DLAMCH, DLAPY2, DNRM2 -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SIGN -* .. -* .. External Subroutines .. - EXTERNAL DSCAL -* .. -* .. Executable Statements .. -* - IF( N.LE.1 ) THEN - TAU = ZERO - RETURN - END IF -* - XNORM = DNRM2( N-1, X, INCX ) -* - IF( XNORM.EQ.ZERO ) THEN -* -* H = I -* - TAU = ZERO - ELSE -* -* general case -* - BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) - SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) - KNT = 0 - IF( ABS( BETA ).LT.SAFMIN ) THEN -* -* XNORM, BETA may be inaccurate; scale X and recompute them -* - RSAFMN = ONE / SAFMIN - 10 CONTINUE - KNT = KNT + 1 - CALL DSCAL( N-1, RSAFMN, X, INCX ) - BETA = BETA*RSAFMN - ALPHA = ALPHA*RSAFMN - IF( (ABS( BETA ).LT.SAFMIN) .AND. (KNT .LT. 20) ) - $ GO TO 10 -* -* New BETA is at most 1, at least SAFMIN -* - XNORM = DNRM2( N-1, X, INCX ) - BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) - END IF - TAU = ( BETA-ALPHA ) / BETA - CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) -* -* If ALPHA is subnormal, it may lose relative accuracy -* - DO 20 J = 1, KNT - BETA = BETA*SAFMIN - 20 CONTINUE - ALPHA = BETA - END IF -* - RETURN -* -* End of DLARFG -* - END diff --git a/lib/linalg/dlarft.cpp b/lib/linalg/dlarft.cpp new file mode 100644 index 0000000000..79881a08a4 --- /dev/null +++ b/lib/linalg/dlarft.cpp @@ -0,0 +1,157 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +static doublereal c_b7 = 1.; +int dlarft_(char *direct, char *storev, integer *n, integer *k, doublereal *v, integer *ldv, + doublereal *tau, doublereal *t, integer *ldt, ftnlen direct_len, ftnlen storev_len) +{ + integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3; + doublereal d__1; + integer i__, j, prevlastv; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern int dgemv_(char *, integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, ftnlen); + integer lastv; + extern int dtrmv_(char *, char *, char *, integer *, doublereal *, integer *, doublereal *, + integer *, ftnlen, ftnlen, ftnlen); + v_dim1 = *ldv; + v_offset = 1 + v_dim1; + v -= v_offset; + --tau; + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; + if (*n == 0) { + return 0; + } + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + prevlastv = *n; + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + prevlastv = max(i__, prevlastv); + if (tau[i__] == 0.) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + t[j + i__ * t_dim1] = 0.; + } + } else { + if (lsame_(storev, (char *)"C", (ftnlen)1, (ftnlen)1)) { + i__2 = i__ + 1; + for (lastv = *n; lastv >= i__2; --lastv) { + if (v[lastv + i__ * v_dim1] != 0.) { + goto L219; + } + } + L219: + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + t[j + i__ * t_dim1] = -tau[i__] * v[i__ + j * v_dim1]; + } + j = min(lastv, prevlastv); + i__2 = j - i__; + i__3 = i__ - 1; + d__1 = -tau[i__]; + dgemv_((char *)"Transpose", &i__2, &i__3, &d__1, &v[i__ + 1 + v_dim1], ldv, + &v[i__ + 1 + i__ * v_dim1], &c__1, &c_b7, &t[i__ * t_dim1 + 1], &c__1, + (ftnlen)9); + } else { + i__2 = i__ + 1; + for (lastv = *n; lastv >= i__2; --lastv) { + if (v[i__ + lastv * v_dim1] != 0.) { + goto L235; + } + } + L235: + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + t[j + i__ * t_dim1] = -tau[i__] * v[j + i__ * v_dim1]; + } + j = min(lastv, prevlastv); + i__2 = i__ - 1; + i__3 = j - i__; + d__1 = -tau[i__]; + dgemv_((char *)"No transpose", &i__2, &i__3, &d__1, &v[(i__ + 1) * v_dim1 + 1], ldv, + &v[i__ + (i__ + 1) * v_dim1], ldv, &c_b7, &t[i__ * t_dim1 + 1], &c__1, + (ftnlen)12); + } + 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__]; + if (i__ > 1) { + prevlastv = max(prevlastv, lastv); + } else { + prevlastv = lastv; + } + } + } + } else { + prevlastv = 1; + for (i__ = *k; i__ >= 1; --i__) { + if (tau[i__] == 0.) { + i__1 = *k; + for (j = i__; j <= i__1; ++j) { + t[j + i__ * t_dim1] = 0.; + } + } else { + if (i__ < *k) { + if (lsame_(storev, (char *)"C", (ftnlen)1, (ftnlen)1)) { + i__1 = i__ - 1; + for (lastv = 1; lastv <= i__1; ++lastv) { + if (v[lastv + i__ * v_dim1] != 0.) { + goto L280; + } + } + L280: + i__1 = *k; + for (j = i__ + 1; j <= i__1; ++j) { + t[j + i__ * t_dim1] = -tau[i__] * v[*n - *k + i__ + j * v_dim1]; + } + j = max(lastv, prevlastv); + i__1 = *n - *k + i__ - j; + i__2 = *k - i__; + d__1 = -tau[i__]; + dgemv_((char *)"Transpose", &i__1, &i__2, &d__1, &v[j + (i__ + 1) * v_dim1], ldv, + &v[j + i__ * v_dim1], &c__1, &c_b7, &t[i__ + 1 + i__ * t_dim1], + &c__1, (ftnlen)9); + } else { + i__1 = i__ - 1; + for (lastv = 1; lastv <= i__1; ++lastv) { + if (v[i__ + lastv * v_dim1] != 0.) { + goto L296; + } + } + L296: + i__1 = *k; + for (j = i__ + 1; j <= i__1; ++j) { + t[j + i__ * t_dim1] = -tau[i__] * v[j + (*n - *k + i__) * v_dim1]; + } + j = max(lastv, prevlastv); + i__1 = *k - i__; + i__2 = *n - *k + i__ - j; + d__1 = -tau[i__]; + dgemv_((char *)"No transpose", &i__1, &i__2, &d__1, &v[i__ + 1 + j * v_dim1], ldv, + &v[i__ + j * v_dim1], ldv, &c_b7, &t[i__ + 1 + i__ * t_dim1], &c__1, + (ftnlen)12); + } + i__1 = *k - i__; + dtrmv_((char *)"Lower", (char *)"No transpose", (char *)"Non-unit", &i__1, + &t[i__ + 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * t_dim1], &c__1, + (ftnlen)5, (ftnlen)12, (ftnlen)8); + if (i__ > 1) { + prevlastv = min(prevlastv, lastv); + } else { + prevlastv = lastv; + } + } + t[i__ + i__ * t_dim1] = tau[i__]; + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlarft.f b/lib/linalg/dlarft.f deleted file mode 100644 index a8d9de61f1..0000000000 --- a/lib/linalg/dlarft.f +++ /dev/null @@ -1,323 +0,0 @@ -*> \brief \b DLARFT forms the triangular factor T of a block reflector H = I - vtvH -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLARFT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) -* -* .. Scalar Arguments .. -* CHARACTER DIRECT, STOREV -* INTEGER K, LDT, LDV, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLARFT forms the triangular factor T of a real block reflector H -*> of order n, which is defined as a product of k elementary reflectors. -*> -*> If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; -*> -*> If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. -*> -*> If STOREV = 'C', the vector which defines the elementary reflector -*> H(i) is stored in the i-th column of the array V, and -*> -*> H = I - V * T * V**T -*> -*> If STOREV = 'R', the vector which defines the elementary reflector -*> H(i) is stored in the i-th row of the array V, and -*> -*> H = I - V**T * T * V -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] DIRECT -*> \verbatim -*> DIRECT is CHARACTER*1 -*> Specifies the order in which the elementary reflectors are -*> multiplied to form the block reflector: -*> = 'F': H = H(1) H(2) . . . H(k) (Forward) -*> = 'B': H = H(k) . . . H(2) H(1) (Backward) -*> \endverbatim -*> -*> \param[in] STOREV -*> \verbatim -*> STOREV is CHARACTER*1 -*> Specifies how the vectors which define the elementary -*> reflectors are stored (see also Further Details): -*> = 'C': columnwise -*> = 'R': rowwise -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the block reflector H. N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The order of the triangular factor T (= the number of -*> elementary reflectors). K >= 1. -*> \endverbatim -*> -*> \param[in] V -*> \verbatim -*> V is DOUBLE PRECISION array, dimension -*> (LDV,K) if STOREV = 'C' -*> (LDV,N) if STOREV = 'R' -*> The matrix V. See further details. -*> \endverbatim -*> -*> \param[in] LDV -*> \verbatim -*> LDV is INTEGER -*> The leading dimension of the array V. -*> If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i). -*> \endverbatim -*> -*> \param[out] T -*> \verbatim -*> T is DOUBLE PRECISION array, dimension (LDT,K) -*> The k by k triangular factor T of the block reflector. -*> If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is -*> lower triangular. The rest of the array is not used. -*> \endverbatim -*> -*> \param[in] LDT -*> \verbatim -*> LDT is INTEGER -*> The leading dimension of the array T. LDT >= K. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The shape of the matrix V and the storage of the vectors which define -*> the H(i) is best illustrated by the following example with n = 5 and -*> k = 3. The elements equal to 1 are not stored. -*> -*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': -*> -*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) -*> ( v1 1 ) ( 1 v2 v2 v2 ) -*> ( v1 v2 1 ) ( 1 v3 v3 ) -*> ( v1 v2 v3 ) -*> ( v1 v2 v3 ) -*> -*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': -*> -*> V = ( v1 v2 v3 ) V = ( v1 v1 1 ) -*> ( v1 v2 v3 ) ( v2 v2 v2 1 ) -*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) -*> ( 1 v3 ) -*> ( 1 ) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER DIRECT, STOREV - INTEGER K, LDT, LDV, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J, PREVLASTV, LASTV -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DTRMV -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( LSAME( DIRECT, 'F' ) ) THEN - PREVLASTV = N - DO I = 1, K - PREVLASTV = MAX( I, PREVLASTV ) - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO J = 1, I - T( J, I ) = ZERO - END DO - ELSE -* -* general case -* - IF( LSAME( STOREV, 'C' ) ) THEN -* Skip any trailing zeros. - DO LASTV = N, I+1, -1 - IF( V( LASTV, I ).NE.ZERO ) EXIT - END DO - DO J = 1, I-1 - T( J, I ) = -TAU( I ) * V( I , J ) - END DO - J = MIN( LASTV, PREVLASTV ) -* -* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i) -* - CALL DGEMV( 'Transpose', J-I, I-1, -TAU( I ), - $ V( I+1, 1 ), LDV, V( I+1, I ), 1, ONE, - $ T( 1, I ), 1 ) - ELSE -* Skip any trailing zeros. - DO LASTV = N, I+1, -1 - IF( V( I, LASTV ).NE.ZERO ) EXIT - END DO - DO J = 1, I-1 - T( J, I ) = -TAU( I ) * V( J , I ) - END DO - J = MIN( LASTV, PREVLASTV ) -* -* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T -* - CALL DGEMV( 'No transpose', I-1, J-I, -TAU( I ), - $ V( 1, I+1 ), LDV, V( I, I+1 ), LDV, ONE, - $ T( 1, I ), 1 ) - END IF -* -* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) -* - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, - $ LDT, T( 1, I ), 1 ) - T( I, I ) = TAU( I ) - IF( I.GT.1 ) THEN - PREVLASTV = MAX( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF - END IF - END DO - ELSE - PREVLASTV = 1 - DO I = K, 1, -1 - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO J = I, K - T( J, I ) = ZERO - END DO - ELSE -* -* general case -* - IF( I.LT.K ) THEN - IF( LSAME( STOREV, 'C' ) ) THEN -* Skip any leading zeros. - DO LASTV = 1, I-1 - IF( V( LASTV, I ).NE.ZERO ) EXIT - END DO - DO J = I+1, K - T( J, I ) = -TAU( I ) * V( N-K+I , J ) - END DO - J = MAX( LASTV, PREVLASTV ) -* -* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**T * V(j:n-k+i,i) -* - CALL DGEMV( 'Transpose', N-K+I-J, K-I, -TAU( I ), - $ V( J, I+1 ), LDV, V( J, I ), 1, ONE, - $ T( I+1, I ), 1 ) - ELSE -* Skip any leading zeros. - DO LASTV = 1, I-1 - IF( V( I, LASTV ).NE.ZERO ) EXIT - END DO - DO J = I+1, K - T( J, I ) = -TAU( I ) * V( J, N-K+I ) - END DO - J = MAX( LASTV, PREVLASTV ) -* -* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**T -* - CALL DGEMV( 'No transpose', K-I, N-K+I-J, - $ -TAU( I ), V( I+1, J ), LDV, V( I, J ), LDV, - $ ONE, T( I+1, I ), 1 ) - END IF -* -* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) -* - CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, - $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) - IF( I.GT.1 ) THEN - PREVLASTV = MIN( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF - END IF - T( I, I ) = TAU( I ) - END IF - END DO - END IF - RETURN -* -* End of DLARFT -* - END diff --git a/lib/linalg/dlartg.cpp b/lib/linalg/dlartg.cpp new file mode 100644 index 0000000000..c388e3b2d4 --- /dev/null +++ b/lib/linalg/dlartg.cpp @@ -0,0 +1,92 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dlartg_(doublereal *f, doublereal *g, doublereal *cs, doublereal *sn, doublereal *r__) +{ + integer i__1; + doublereal d__1, d__2; + double log(doublereal), pow_lmp_di(doublereal *, integer *), sqrt(doublereal); + integer i__; + doublereal f1, g1, eps, scale; + integer count; + doublereal safmn2, safmx2; + extern doublereal dlamch_(char *, ftnlen); + doublereal safmin; + safmin = dlamch_((char *)"S", (ftnlen)1); + eps = dlamch_((char *)"E", (ftnlen)1); + d__1 = dlamch_((char *)"B", (ftnlen)1); + i__1 = (integer)(log(safmin / eps) / log(dlamch_((char *)"B", (ftnlen)1)) / 2.); + safmn2 = pow_lmp_di(&d__1, &i__1); + safmx2 = 1. / safmn2; + if (*g == 0.) { + *cs = 1.; + *sn = 0.; + *r__ = *f; + } else if (*f == 0.) { + *cs = 0.; + *sn = 1.; + *r__ = *g; + } else { + f1 = *f; + g1 = *g; + d__1 = abs(f1), d__2 = abs(g1); + scale = max(d__1, d__2); + if (scale >= safmx2) { + count = 0; + L10: + ++count; + f1 *= safmn2; + g1 *= safmn2; + d__1 = abs(f1), d__2 = abs(g1); + scale = max(d__1, d__2); + if (scale >= safmx2) { + goto L10; + } + d__1 = f1; + d__2 = g1; + *r__ = sqrt(d__1 * d__1 + d__2 * d__2); + *cs = f1 / *r__; + *sn = g1 / *r__; + i__1 = count; + for (i__ = 1; i__ <= i__1; ++i__) { + *r__ *= safmx2; + } + } else if (scale <= safmn2) { + count = 0; + L30: + ++count; + f1 *= safmx2; + g1 *= safmx2; + d__1 = abs(f1), d__2 = abs(g1); + scale = max(d__1, d__2); + if (scale <= safmn2) { + goto L30; + } + d__1 = f1; + d__2 = g1; + *r__ = sqrt(d__1 * d__1 + d__2 * d__2); + *cs = f1 / *r__; + *sn = g1 / *r__; + i__1 = count; + for (i__ = 1; i__ <= i__1; ++i__) { + *r__ *= safmn2; + } + } else { + d__1 = f1; + d__2 = g1; + *r__ = sqrt(d__1 * d__1 + d__2 * d__2); + *cs = f1 / *r__; + *sn = g1 / *r__; + } + if (abs(*f) > abs(*g) && *cs < 0.) { + *cs = -(*cs); + *sn = -(*sn); + *r__ = -(*r__); + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlartg.f b/lib/linalg/dlartg.f deleted file mode 100644 index 1c7c46f638..0000000000 --- a/lib/linalg/dlartg.f +++ /dev/null @@ -1,204 +0,0 @@ -*> \brief \b DLARTG generates a plane rotation with real cosine and real sine. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLARTG + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLARTG( F, G, CS, SN, R ) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION CS, F, G, R, SN -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLARTG generate a plane rotation so that -*> -*> [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. -*> [ -SN CS ] [ G ] [ 0 ] -*> -*> This is a slower, more accurate version of the BLAS1 routine DROTG, -*> with the following other differences: -*> F and G are unchanged on return. -*> If G=0, then CS=1 and SN=0. -*> If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any -*> floating point operations (saves work in DBDSQR when -*> there are zeros on the diagonal). -*> -*> If F exceeds G in magnitude, CS will be positive. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] F -*> \verbatim -*> F is DOUBLE PRECISION -*> The first component of vector to be rotated. -*> \endverbatim -*> -*> \param[in] G -*> \verbatim -*> G is DOUBLE PRECISION -*> The second component of vector to be rotated. -*> \endverbatim -*> -*> \param[out] CS -*> \verbatim -*> CS is DOUBLE PRECISION -*> The cosine of the rotation. -*> \endverbatim -*> -*> \param[out] SN -*> \verbatim -*> SN is DOUBLE PRECISION -*> The sine of the rotation. -*> \endverbatim -*> -*> \param[out] R -*> \verbatim -*> R is DOUBLE PRECISION -*> The nonzero component of the rotated vector. -*> -*> This version has a few statements commented out for thread safety -*> (machine parameters are computed on each entry). 10 feb 03, SJH. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date December 2016 -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLARTG( F, G, CS, SN, R ) -* -* -- LAPACK auxiliary routine (version 3.7.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - DOUBLE PRECISION CS, F, G, R, SN -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.0D0 ) -* .. -* .. Local Scalars .. -* LOGICAL FIRST - INTEGER COUNT, I - DOUBLE PRECISION EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, INT, LOG, MAX, SQRT -* .. -* .. Save statement .. -* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 -* .. -* .. Data statements .. -* DATA FIRST / .TRUE. / -* .. -* .. Executable Statements .. -* -* IF( FIRST ) THEN - SAFMIN = DLAMCH( 'S' ) - EPS = DLAMCH( 'E' ) - SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / - $ LOG( DLAMCH( 'B' ) ) / TWO ) - SAFMX2 = ONE / SAFMN2 -* FIRST = .FALSE. -* END IF - IF( G.EQ.ZERO ) THEN - CS = ONE - SN = ZERO - R = F - ELSE IF( F.EQ.ZERO ) THEN - CS = ZERO - SN = ONE - R = G - ELSE - F1 = F - G1 = G - SCALE = MAX( ABS( F1 ), ABS( G1 ) ) - IF( SCALE.GE.SAFMX2 ) THEN - COUNT = 0 - 10 CONTINUE - COUNT = COUNT + 1 - F1 = F1*SAFMN2 - G1 = G1*SAFMN2 - SCALE = MAX( ABS( F1 ), ABS( G1 ) ) - IF( SCALE.GE.SAFMX2 ) - $ GO TO 10 - R = SQRT( F1**2+G1**2 ) - CS = F1 / R - SN = G1 / R - DO 20 I = 1, COUNT - R = R*SAFMX2 - 20 CONTINUE - ELSE IF( SCALE.LE.SAFMN2 ) THEN - COUNT = 0 - 30 CONTINUE - COUNT = COUNT + 1 - F1 = F1*SAFMX2 - G1 = G1*SAFMX2 - SCALE = MAX( ABS( F1 ), ABS( G1 ) ) - IF( SCALE.LE.SAFMN2 ) - $ GO TO 30 - R = SQRT( F1**2+G1**2 ) - CS = F1 / R - SN = G1 / R - DO 40 I = 1, COUNT - R = R*SAFMN2 - 40 CONTINUE - ELSE - R = SQRT( F1**2+G1**2 ) - CS = F1 / R - SN = G1 / R - END IF - IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN - CS = -CS - SN = -SN - R = -R - END IF - END IF - RETURN -* -* End of DLARTG -* - END diff --git a/lib/linalg/dlas2.cpp b/lib/linalg/dlas2.cpp new file mode 100644 index 0000000000..4271202477 --- /dev/null +++ b/lib/linalg/dlas2.cpp @@ -0,0 +1,53 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dlas2_(doublereal *f, doublereal *g, doublereal *h__, doublereal *ssmin, doublereal *ssmax) +{ + doublereal d__1, d__2; + double sqrt(doublereal); + doublereal c__, fa, ga, ha, as, at, au, fhmn, fhmx; + fa = abs(*f); + ga = abs(*g); + ha = abs(*h__); + fhmn = min(fa, ha); + fhmx = max(fa, ha); + if (fhmn == 0.) { + *ssmin = 0.; + if (fhmx == 0.) { + *ssmax = ga; + } else { + d__1 = min(fhmx, ga) / max(fhmx, ga); + *ssmax = max(fhmx, ga) * sqrt(d__1 * d__1 + 1.); + } + } else { + if (ga < fhmx) { + as = fhmn / fhmx + 1.; + at = (fhmx - fhmn) / fhmx; + d__1 = ga / fhmx; + au = d__1 * d__1; + c__ = 2. / (sqrt(as * as + au) + sqrt(at * at + au)); + *ssmin = fhmn * c__; + *ssmax = fhmx / c__; + } else { + au = fhmx / ga; + if (au == 0.) { + *ssmin = fhmn * fhmx / ga; + *ssmax = ga; + } else { + as = fhmn / fhmx + 1.; + at = (fhmx - fhmn) / fhmx; + d__1 = as * au; + d__2 = at * au; + c__ = 1. / (sqrt(d__1 * d__1 + 1.) + sqrt(d__2 * d__2 + 1.)); + *ssmin = fhmn * c__ * au; + *ssmin += *ssmin; + *ssmax = ga / (c__ + c__); + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlas2.f b/lib/linalg/dlas2.f deleted file mode 100644 index ea929e86f7..0000000000 --- a/lib/linalg/dlas2.f +++ /dev/null @@ -1,180 +0,0 @@ -*> \brief \b DLAS2 computes singular values of a 2-by-2 triangular matrix. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLAS2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX ) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION F, G, H, SSMAX, SSMIN -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLAS2 computes the singular values of the 2-by-2 matrix -*> [ F G ] -*> [ 0 H ]. -*> On return, SSMIN is the smaller singular value and SSMAX is the -*> larger singular value. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] F -*> \verbatim -*> F is DOUBLE PRECISION -*> The (1,1) element of the 2-by-2 matrix. -*> \endverbatim -*> -*> \param[in] G -*> \verbatim -*> G is DOUBLE PRECISION -*> The (1,2) element of the 2-by-2 matrix. -*> \endverbatim -*> -*> \param[in] H -*> \verbatim -*> H is DOUBLE PRECISION -*> The (2,2) element of the 2-by-2 matrix. -*> \endverbatim -*> -*> \param[out] SSMIN -*> \verbatim -*> SSMIN is DOUBLE PRECISION -*> The smaller singular value. -*> \endverbatim -*> -*> \param[out] SSMAX -*> \verbatim -*> SSMAX is DOUBLE PRECISION -*> The larger singular value. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Barring over/underflow, all output quantities are correct to within -*> a few units in the last place (ulps), even in the absence of a guard -*> digit in addition/subtraction. -*> -*> In IEEE arithmetic, the code works correctly if one matrix element is -*> infinite. -*> -*> Overflow will not occur unless the largest singular value itself -*> overflows, or is within a few ulps of overflow. (On machines with -*> partial overflow, like the Cray, overflow may occur if the largest -*> singular value is within a factor of 2 of overflow.) -*> -*> Underflow is harmless if underflow is gradual. Otherwise, results -*> may correspond to a matrix modified by perturbations of size near -*> the underflow threshold. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION F, G, H, SSMAX, SSMIN -* .. -* -* ==================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.0D0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION AS, AT, AU, C, FA, FHMN, FHMX, GA, HA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - FA = ABS( F ) - GA = ABS( G ) - HA = ABS( H ) - FHMN = MIN( FA, HA ) - FHMX = MAX( FA, HA ) - IF( FHMN.EQ.ZERO ) THEN - SSMIN = ZERO - IF( FHMX.EQ.ZERO ) THEN - SSMAX = GA - ELSE - SSMAX = MAX( FHMX, GA )*SQRT( ONE+ - $ ( MIN( FHMX, GA ) / MAX( FHMX, GA ) )**2 ) - END IF - ELSE - IF( GA.LT.FHMX ) THEN - AS = ONE + FHMN / FHMX - AT = ( FHMX-FHMN ) / FHMX - AU = ( GA / FHMX )**2 - C = TWO / ( SQRT( AS*AS+AU )+SQRT( AT*AT+AU ) ) - SSMIN = FHMN*C - SSMAX = FHMX / C - ELSE - AU = FHMX / GA - IF( AU.EQ.ZERO ) THEN -* -* Avoid possible harmful underflow if exponent range -* asymmetric (true SSMIN may not underflow even if -* AU underflows) -* - SSMIN = ( FHMN*FHMX ) / GA - SSMAX = GA - ELSE - AS = ONE + FHMN / FHMX - AT = ( FHMX-FHMN ) / FHMX - C = ONE / ( SQRT( ONE+( AS*AU )**2 )+ - $ SQRT( ONE+( AT*AU )**2 ) ) - SSMIN = ( FHMN*C )*AU - SSMIN = SSMIN + SSMIN - SSMAX = GA / ( C+C ) - END IF - END IF - END IF - RETURN -* -* End of DLAS2 -* - END diff --git a/lib/linalg/dlascl.cpp b/lib/linalg/dlascl.cpp new file mode 100644 index 0000000000..3248e1b8a9 --- /dev/null +++ b/lib/linalg/dlascl.cpp @@ -0,0 +1,185 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dlascl_(char *type__, integer *kl, integer *ku, doublereal *cfrom, doublereal *cto, integer *m, + integer *n, doublereal *a, integer *lda, integer *info, ftnlen type_len) +{ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + integer i__, j, k1, k2, k3, k4; + doublereal mul, cto1; + logical done; + doublereal ctoc; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + integer itype; + doublereal cfrom1; + extern doublereal dlamch_(char *, ftnlen); + doublereal cfromc; + extern logical disnan_(doublereal *); + extern int xerbla_(char *, integer *, ftnlen); + doublereal bignum, smlnum; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + *info = 0; + if (lsame_(type__, (char *)"G", (ftnlen)1, (ftnlen)1)) { + itype = 0; + } else if (lsame_(type__, (char *)"L", (ftnlen)1, (ftnlen)1)) { + itype = 1; + } else if (lsame_(type__, (char *)"U", (ftnlen)1, (ftnlen)1)) { + itype = 2; + } else if (lsame_(type__, (char *)"H", (ftnlen)1, (ftnlen)1)) { + itype = 3; + } else if (lsame_(type__, (char *)"B", (ftnlen)1, (ftnlen)1)) { + itype = 4; + } else if (lsame_(type__, (char *)"Q", (ftnlen)1, (ftnlen)1)) { + itype = 5; + } else if (lsame_(type__, (char *)"Z", (ftnlen)1, (ftnlen)1)) { + itype = 6; + } else { + itype = -1; + } + if (itype == -1) { + *info = -1; + } else if (*cfrom == 0. || disnan_(cfrom)) { + *info = -4; + } else if (disnan_(cto)) { + *info = -5; + } else if (*m < 0) { + *info = -6; + } else if (*n < 0 || itype == 4 && *n != *m || itype == 5 && *n != *m) { + *info = -7; + } else if (itype <= 3 && *lda < max(1, *m)) { + *info = -9; + } else if (itype >= 4) { + i__1 = *m - 1; + if (*kl < 0 || *kl > max(i__1, 0)) { + *info = -2; + } else { + i__1 = *n - 1; + if (*ku < 0 || *ku > max(i__1, 0) || (itype == 4 || itype == 5) && *kl != *ku) { + *info = -3; + } else if (itype == 4 && *lda < *kl + 1 || itype == 5 && *lda < *ku + 1 || + itype == 6 && *lda < (*kl << 1) + *ku + 1) { + *info = -9; + } + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DLASCL", &i__1, (ftnlen)6); + return 0; + } + if (*n == 0 || *m == 0) { + return 0; + } + smlnum = dlamch_((char *)"S", (ftnlen)1); + bignum = 1. / smlnum; + cfromc = *cfrom; + ctoc = *cto; +L10: + cfrom1 = cfromc * smlnum; + if (cfrom1 == cfromc) { + mul = ctoc / cfromc; + done = TRUE_; + cto1 = ctoc; + } else { + cto1 = ctoc / bignum; + if (cto1 == ctoc) { + mul = ctoc; + done = TRUE_; + cfromc = 1.; + } else if (abs(cfrom1) > abs(ctoc) && ctoc != 0.) { + mul = smlnum; + done = FALSE_; + cfromc = cfrom1; + } else if (abs(cto1) > abs(cfromc)) { + mul = bignum; + done = FALSE_; + ctoc = cto1; + } else { + mul = ctoc / cfromc; + done = TRUE_; + if (mul == 1.) { + return 0; + } + } + } + if (itype == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] *= mul; + } + } + } else if (itype == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] *= mul; + } + } + } else if (itype == 2) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = min(j, *m); + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] *= mul; + } + } + } else if (itype == 3) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__3 = j + 1; + i__2 = min(i__3, *m); + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] *= mul; + } + } + } else if (itype == 4) { + k3 = *kl + 1; + k4 = *n + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__3 = k3, i__4 = k4 - j; + i__2 = min(i__3, i__4); + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] *= mul; + } + } + } else if (itype == 5) { + k1 = *ku + 2; + k3 = *ku + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = k1 - j; + i__3 = k3; + for (i__ = max(i__2, 1); i__ <= i__3; ++i__) { + a[i__ + j * a_dim1] *= mul; + } + } + } else if (itype == 6) { + k1 = *kl + *ku + 2; + k2 = *kl + 1; + k3 = (*kl << 1) + *ku + 1; + k4 = *kl + *ku + 1 + *m; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__3 = k1 - j; + i__4 = k3, i__5 = k4 - j; + i__2 = min(i__4, i__5); + for (i__ = max(i__3, k2); i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] *= mul; + } + } + } + if (!done) { + goto L10; + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlascl.f b/lib/linalg/dlascl.f deleted file mode 100644 index 0a4bf21ce1..0000000000 --- a/lib/linalg/dlascl.f +++ /dev/null @@ -1,367 +0,0 @@ -*> \brief \b DLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASCL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER TYPE -* INTEGER INFO, KL, KU, LDA, M, N -* DOUBLE PRECISION CFROM, CTO -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLASCL multiplies the M by N real matrix A by the real scalar -*> CTO/CFROM. This is done without over/underflow as long as the final -*> result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that -*> A may be full, upper triangular, lower triangular, upper Hessenberg, -*> or banded. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] TYPE -*> \verbatim -*> TYPE is CHARACTER*1 -*> TYPE indices the storage type of the input matrix. -*> = 'G': A is a full matrix. -*> = 'L': A is a lower triangular matrix. -*> = 'U': A is an upper triangular matrix. -*> = 'H': A is an upper Hessenberg matrix. -*> = 'B': A is a symmetric band matrix with lower bandwidth KL -*> and upper bandwidth KU and with the only the lower -*> half stored. -*> = 'Q': A is a symmetric band matrix with lower bandwidth KL -*> and upper bandwidth KU and with the only the upper -*> half stored. -*> = 'Z': A is a band matrix with lower bandwidth KL and upper -*> bandwidth KU. See DGBTRF for storage details. -*> \endverbatim -*> -*> \param[in] KL -*> \verbatim -*> KL is INTEGER -*> The lower bandwidth of A. Referenced only if TYPE = 'B', -*> 'Q' or 'Z'. -*> \endverbatim -*> -*> \param[in] KU -*> \verbatim -*> KU is INTEGER -*> The upper bandwidth of A. Referenced only if TYPE = 'B', -*> 'Q' or 'Z'. -*> \endverbatim -*> -*> \param[in] CFROM -*> \verbatim -*> CFROM is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in] CTO -*> \verbatim -*> CTO is DOUBLE PRECISION -*> -*> The matrix A is multiplied by CTO/CFROM. A(I,J) is computed -*> without over/underflow if the final result CTO*A(I,J)/CFROM -*> can be represented without over/underflow. CFROM must be -*> nonzero. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> The matrix to be multiplied by CTO/CFROM. See TYPE for the -*> storage type. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. -*> If TYPE = 'G', 'L', 'U', 'H', LDA >= max(1,M); -*> TYPE = 'B', LDA >= KL+1; -*> TYPE = 'Q', LDA >= KU+1; -*> TYPE = 'Z', LDA >= 2*KL+KU+1. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> 0 - successful exit -*> <0 - if INFO = -i, the i-th argument had an illegal value. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER TYPE - INTEGER INFO, KL, KU, LDA, M, N - DOUBLE PRECISION CFROM, CTO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL DONE - INTEGER I, ITYPE, J, K1, K2, K3, K4 - DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM -* .. -* .. External Functions .. - LOGICAL LSAME, DISNAN - DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, DLAMCH, DISNAN -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 -* - IF( LSAME( TYPE, 'G' ) ) THEN - ITYPE = 0 - ELSE IF( LSAME( TYPE, 'L' ) ) THEN - ITYPE = 1 - ELSE IF( LSAME( TYPE, 'U' ) ) THEN - ITYPE = 2 - ELSE IF( LSAME( TYPE, 'H' ) ) THEN - ITYPE = 3 - ELSE IF( LSAME( TYPE, 'B' ) ) THEN - ITYPE = 4 - ELSE IF( LSAME( TYPE, 'Q' ) ) THEN - ITYPE = 5 - ELSE IF( LSAME( TYPE, 'Z' ) ) THEN - ITYPE = 6 - ELSE - ITYPE = -1 - END IF -* - IF( ITYPE.EQ.-1 ) THEN - INFO = -1 - ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN - INFO = -4 - ELSE IF( DISNAN(CTO) ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. - $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN - INFO = -7 - ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN - INFO = -9 - ELSE IF( ITYPE.GE.4 ) THEN - IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN - INFO = -2 - ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. - $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) - $ THEN - INFO = -3 - ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. - $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. - $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN - INFO = -9 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLASCL', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. M.EQ.0 ) - $ RETURN -* -* Get machine parameters -* - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM -* - CFROMC = CFROM - CTOC = CTO -* - 10 CONTINUE - CFROM1 = CFROMC*SMLNUM - IF( CFROM1.EQ.CFROMC ) THEN -! CFROMC is an inf. Multiply by a correctly signed zero for -! finite CTOC, or a NaN if CTOC is infinite. - MUL = CTOC / CFROMC - DONE = .TRUE. - CTO1 = CTOC - ELSE - CTO1 = CTOC / BIGNUM - IF( CTO1.EQ.CTOC ) THEN -! CTOC is either 0 or an inf. In both cases, CTOC itself -! serves as the correct multiplication factor. - MUL = CTOC - DONE = .TRUE. - CFROMC = ONE - ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN - MUL = SMLNUM - DONE = .FALSE. - CFROMC = CFROM1 - ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN - MUL = BIGNUM - DONE = .FALSE. - CTOC = CTO1 - ELSE - MUL = CTOC / CFROMC - DONE = .TRUE. - IF (MUL .EQ. ONE) - $ RETURN - END IF - END IF -* - IF( ITYPE.EQ.0 ) THEN -* -* Full matrix -* - DO 30 J = 1, N - DO 20 I = 1, M - A( I, J ) = A( I, J )*MUL - 20 CONTINUE - 30 CONTINUE -* - ELSE IF( ITYPE.EQ.1 ) THEN -* -* Lower triangular matrix -* - DO 50 J = 1, N - DO 40 I = J, M - A( I, J ) = A( I, J )*MUL - 40 CONTINUE - 50 CONTINUE -* - ELSE IF( ITYPE.EQ.2 ) THEN -* -* Upper triangular matrix -* - DO 70 J = 1, N - DO 60 I = 1, MIN( J, M ) - A( I, J ) = A( I, J )*MUL - 60 CONTINUE - 70 CONTINUE -* - ELSE IF( ITYPE.EQ.3 ) THEN -* -* Upper Hessenberg matrix -* - DO 90 J = 1, N - DO 80 I = 1, MIN( J+1, M ) - A( I, J ) = A( I, J )*MUL - 80 CONTINUE - 90 CONTINUE -* - ELSE IF( ITYPE.EQ.4 ) THEN -* -* Lower half of a symmetric band matrix -* - K3 = KL + 1 - K4 = N + 1 - DO 110 J = 1, N - DO 100 I = 1, MIN( K3, K4-J ) - A( I, J ) = A( I, J )*MUL - 100 CONTINUE - 110 CONTINUE -* - ELSE IF( ITYPE.EQ.5 ) THEN -* -* Upper half of a symmetric band matrix -* - K1 = KU + 2 - K3 = KU + 1 - DO 130 J = 1, N - DO 120 I = MAX( K1-J, 1 ), K3 - A( I, J ) = A( I, J )*MUL - 120 CONTINUE - 130 CONTINUE -* - ELSE IF( ITYPE.EQ.6 ) THEN -* -* Band matrix -* - K1 = KL + KU + 2 - K2 = KL + 1 - K3 = 2*KL + KU + 1 - K4 = KL + KU + 1 + M - DO 150 J = 1, N - DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) - A( I, J ) = A( I, J )*MUL - 140 CONTINUE - 150 CONTINUE -* - END IF -* - IF( .NOT.DONE ) - $ GO TO 10 -* - RETURN -* -* End of DLASCL -* - END diff --git a/lib/linalg/dlasd4.cpp b/lib/linalg/dlasd4.cpp new file mode 100644 index 0000000000..c51c15370e --- /dev/null +++ b/lib/linalg/dlasd4.cpp @@ -0,0 +1,695 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dlasd4_(integer *n, integer *i__, doublereal *d__, doublereal *z__, doublereal *delta, + doublereal *rho, doublereal *sigma, doublereal *work, integer *info) +{ + integer i__1; + doublereal d__1; + double sqrt(doublereal); + doublereal a, b, c__; + integer j; + doublereal w, dd[3]; + integer ii; + doublereal dw, zz[3]; + integer ip1; + doublereal sq2, eta, phi, eps, tau, psi; + integer iim1, iip1; + doublereal tau2, dphi, sglb, dpsi, sgub; + integer iter; + doublereal temp, prew, temp1, temp2, dtiim, delsq, dtiip; + integer niter; + doublereal dtisq; + logical swtch; + doublereal dtnsq; + extern int dlaed6_(integer *, logical *, doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *), + dlasd5_(integer *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *); + doublereal delsq2, dtnsq1; + logical swtch3; + extern doublereal dlamch_(char *, ftnlen); + logical orgati; + doublereal erretm, dtipsq, rhoinv; + logical geomavg; + --work; + --delta; + --z__; + --d__; + *info = 0; + if (*n == 1) { + *sigma = sqrt(d__[1] * d__[1] + *rho * z__[1] * z__[1]); + delta[1] = 1.; + work[1] = 1.; + return 0; + } + if (*n == 2) { + dlasd5_(i__, &d__[1], &z__[1], &delta[1], rho, sigma, &work[1]); + return 0; + } + eps = dlamch_((char *)"Epsilon", (ftnlen)7); + rhoinv = 1. / *rho; + tau2 = 0.; + if (*i__ == *n) { + ii = *n - 1; + niter = 1; + temp = *rho / 2.; + temp1 = temp / (d__[*n] + sqrt(d__[*n] * d__[*n] + temp)); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + work[j] = d__[j] + d__[*n] + temp1; + delta[j] = d__[j] - d__[*n] - temp1; + } + psi = 0.; + i__1 = *n - 2; + for (j = 1; j <= i__1; ++j) { + psi += z__[j] * z__[j] / (delta[j] * work[j]); + } + c__ = rhoinv + psi; + w = c__ + z__[ii] * z__[ii] / (delta[ii] * work[ii]) + + z__[*n] * z__[*n] / (delta[*n] * work[*n]); + if (w <= 0.) { + temp1 = sqrt(d__[*n] * d__[*n] + *rho); + temp = + z__[*n - 1] * z__[*n - 1] / + ((d__[*n - 1] + temp1) * (d__[*n] - d__[*n - 1] + *rho / (d__[*n] + temp1))) + + z__[*n] * z__[*n] / *rho; + if (c__ <= temp) { + tau = *rho; + } else { + delsq = (d__[*n] - d__[*n - 1]) * (d__[*n] + d__[*n - 1]); + a = -c__ * delsq + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n]; + b = z__[*n] * z__[*n] * delsq; + if (a < 0.) { + tau2 = b * 2. / (sqrt(a * a + b * 4. * c__) - a); + } else { + tau2 = (a + sqrt(a * a + b * 4. * c__)) / (c__ * 2.); + } + tau = tau2 / (d__[*n] + sqrt(d__[*n] * d__[*n] + tau2)); + } + } else { + delsq = (d__[*n] - d__[*n - 1]) * (d__[*n] + d__[*n - 1]); + a = -c__ * delsq + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n]; + b = z__[*n] * z__[*n] * delsq; + if (a < 0.) { + tau2 = b * 2. / (sqrt(a * a + b * 4. * c__) - a); + } else { + tau2 = (a + sqrt(a * a + b * 4. * c__)) / (c__ * 2.); + } + tau = tau2 / (d__[*n] + sqrt(d__[*n] * d__[*n] + tau2)); + } + *sigma = d__[*n] + tau; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] = d__[j] - d__[*n] - tau; + work[j] = d__[j] + d__[*n] + tau; + } + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = ii; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / (delta[j] * work[j]); + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; + } + erretm = abs(erretm); + temp = z__[*n] / (delta[*n] * work[*n]); + phi = z__[*n] * temp; + dphi = temp * temp; + erretm = (-phi - psi) * 8. + erretm - phi + rhoinv; + w = rhoinv + phi + psi; + if (abs(w) <= eps * erretm) { + goto L240; + } + ++niter; + dtnsq1 = work[*n - 1] * delta[*n - 1]; + dtnsq = work[*n] * delta[*n]; + c__ = w - dtnsq1 * dpsi - dtnsq * dphi; + a = (dtnsq + dtnsq1) * w - dtnsq * dtnsq1 * (dpsi + dphi); + b = dtnsq * dtnsq1 * w; + if (c__ < 0.) { + c__ = abs(c__); + } + if (c__ == 0.) { + eta = *rho - *sigma * *sigma; + } else if (a >= 0.) { + eta = (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ * 2.); + } else { + eta = b * 2. / (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))); + } + if (w * eta > 0.) { + eta = -w / (dpsi + dphi); + } + temp = eta - dtnsq; + if (temp > *rho) { + eta = *rho + dtnsq; + } + eta /= *sigma + sqrt(eta + *sigma * *sigma); + tau += eta; + *sigma += eta; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] -= eta; + work[j] += eta; + } + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = ii; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / (work[j] * delta[j]); + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; + } + erretm = abs(erretm); + tau2 = work[*n] * delta[*n]; + temp = z__[*n] / tau2; + phi = z__[*n] * temp; + dphi = temp * temp; + erretm = (-phi - psi) * 8. + erretm - phi + rhoinv; + w = rhoinv + phi + psi; + iter = niter + 1; + for (niter = iter; niter <= 400; ++niter) { + if (abs(w) <= eps * erretm) { + goto L240; + } + dtnsq1 = work[*n - 1] * delta[*n - 1]; + dtnsq = work[*n] * delta[*n]; + c__ = w - dtnsq1 * dpsi - dtnsq * dphi; + a = (dtnsq + dtnsq1) * w - dtnsq1 * dtnsq * (dpsi + dphi); + b = dtnsq1 * dtnsq * w; + if (a >= 0.) { + eta = (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ * 2.); + } else { + eta = b * 2. / (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))); + } + if (w * eta > 0.) { + eta = -w / (dpsi + dphi); + } + temp = eta - dtnsq; + if (temp <= 0.) { + eta /= 2.; + } + eta /= *sigma + sqrt(eta + *sigma * *sigma); + tau += eta; + *sigma += eta; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] -= eta; + work[j] += eta; + } + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = ii; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / (work[j] * delta[j]); + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; + } + erretm = abs(erretm); + tau2 = work[*n] * delta[*n]; + temp = z__[*n] / tau2; + phi = z__[*n] * temp; + dphi = temp * temp; + erretm = (-phi - psi) * 8. + erretm - phi + rhoinv; + w = rhoinv + phi + psi; + } + *info = 1; + goto L240; + } else { + niter = 1; + ip1 = *i__ + 1; + delsq = (d__[ip1] - d__[*i__]) * (d__[ip1] + d__[*i__]); + delsq2 = delsq / 2.; + sq2 = sqrt((d__[*i__] * d__[*i__] + d__[ip1] * d__[ip1]) / 2.); + temp = delsq2 / (d__[*i__] + sq2); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + work[j] = d__[j] + d__[*i__] + temp; + delta[j] = d__[j] - d__[*i__] - temp; + } + psi = 0.; + i__1 = *i__ - 1; + for (j = 1; j <= i__1; ++j) { + psi += z__[j] * z__[j] / (work[j] * delta[j]); + } + phi = 0.; + i__1 = *i__ + 2; + for (j = *n; j >= i__1; --j) { + phi += z__[j] * z__[j] / (work[j] * delta[j]); + } + c__ = rhoinv + psi + phi; + w = c__ + z__[*i__] * z__[*i__] / (work[*i__] * delta[*i__]) + + z__[ip1] * z__[ip1] / (work[ip1] * delta[ip1]); + geomavg = FALSE_; + if (w > 0.) { + orgati = TRUE_; + ii = *i__; + sglb = 0.; + sgub = delsq2 / (d__[*i__] + sq2); + a = c__ * delsq + z__[*i__] * z__[*i__] + z__[ip1] * z__[ip1]; + b = z__[*i__] * z__[*i__] * delsq; + if (a > 0.) { + tau2 = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))); + } else { + tau2 = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ * 2.); + } + tau = tau2 / (d__[*i__] + sqrt(d__[*i__] * d__[*i__] + tau2)); + temp = sqrt(eps); + if (d__[*i__] <= temp * d__[ip1] && (d__1 = z__[*i__], abs(d__1)) <= temp && + d__[*i__] > 0.) { + d__1 = d__[*i__] * 10.; + tau = min(d__1, sgub); + geomavg = TRUE_; + } + } else { + orgati = FALSE_; + ii = ip1; + sglb = -delsq2 / (d__[ii] + sq2); + sgub = 0.; + a = c__ * delsq - z__[*i__] * z__[*i__] - z__[ip1] * z__[ip1]; + b = z__[ip1] * z__[ip1] * delsq; + if (a < 0.) { + tau2 = b * 2. / (a - sqrt((d__1 = a * a + b * 4. * c__, abs(d__1)))); + } else { + tau2 = -(a + sqrt((d__1 = a * a + b * 4. * c__, abs(d__1)))) / (c__ * 2.); + } + tau = tau2 / (d__[ip1] + sqrt((d__1 = d__[ip1] * d__[ip1] + tau2, abs(d__1)))); + } + *sigma = d__[ii] + tau; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + work[j] = d__[j] + d__[ii] + tau; + delta[j] = d__[j] - d__[ii] - tau; + } + iim1 = ii - 1; + iip1 = ii + 1; + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = iim1; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / (work[j] * delta[j]); + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; + } + erretm = abs(erretm); + dphi = 0.; + phi = 0.; + i__1 = iip1; + for (j = *n; j >= i__1; --j) { + temp = z__[j] / (work[j] * delta[j]); + phi += z__[j] * temp; + dphi += temp * temp; + erretm += phi; + } + w = rhoinv + phi + psi; + swtch3 = FALSE_; + if (orgati) { + if (w < 0.) { + swtch3 = TRUE_; + } + } else { + if (w > 0.) { + swtch3 = TRUE_; + } + } + if (ii == 1 || ii == *n) { + swtch3 = FALSE_; + } + temp = z__[ii] / (work[ii] * delta[ii]); + dw = dpsi + dphi + temp * temp; + temp = z__[ii] * temp; + w += temp; + erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3.; + if (abs(w) <= eps * erretm) { + goto L240; + } + if (w <= 0.) { + sglb = max(sglb, tau); + } else { + sgub = min(sgub, tau); + } + ++niter; + if (!swtch3) { + dtipsq = work[ip1] * delta[ip1]; + dtisq = work[*i__] * delta[*i__]; + if (orgati) { + d__1 = z__[*i__] / dtisq; + c__ = w - dtipsq * dw + delsq * (d__1 * d__1); + } else { + d__1 = z__[ip1] / dtipsq; + c__ = w - dtisq * dw - delsq * (d__1 * d__1); + } + a = (dtipsq + dtisq) * w - dtipsq * dtisq * dw; + b = dtipsq * dtisq * w; + if (c__ == 0.) { + if (a == 0.) { + if (orgati) { + a = z__[*i__] * z__[*i__] + dtipsq * dtipsq * (dpsi + dphi); + } else { + a = z__[ip1] * z__[ip1] + dtisq * dtisq * (dpsi + dphi); + } + } + eta = b / a; + } else if (a <= 0.) { + eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ * 2.); + } else { + eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))); + } + } else { + dtiim = work[iim1] * delta[iim1]; + dtiip = work[iip1] * delta[iip1]; + temp = rhoinv + psi + phi; + if (orgati) { + temp1 = z__[iim1] / dtiim; + temp1 *= temp1; + c__ = temp - dtiip * (dpsi + dphi) - + (d__[iim1] - d__[iip1]) * (d__[iim1] + d__[iip1]) * temp1; + zz[0] = z__[iim1] * z__[iim1]; + if (dpsi < temp1) { + zz[2] = dtiip * dtiip * dphi; + } else { + zz[2] = dtiip * dtiip * (dpsi - temp1 + dphi); + } + } else { + temp1 = z__[iip1] / dtiip; + temp1 *= temp1; + c__ = temp - dtiim * (dpsi + dphi) - + (d__[iip1] - d__[iim1]) * (d__[iim1] + d__[iip1]) * temp1; + if (dphi < temp1) { + zz[0] = dtiim * dtiim * dpsi; + } else { + zz[0] = dtiim * dtiim * (dpsi + (dphi - temp1)); + } + zz[2] = z__[iip1] * z__[iip1]; + } + zz[1] = z__[ii] * z__[ii]; + dd[0] = dtiim; + dd[1] = delta[ii] * work[ii]; + dd[2] = dtiip; + dlaed6_(&niter, &orgati, &c__, dd, zz, &w, &eta, info); + if (*info != 0) { + swtch3 = FALSE_; + *info = 0; + dtipsq = work[ip1] * delta[ip1]; + dtisq = work[*i__] * delta[*i__]; + if (orgati) { + d__1 = z__[*i__] / dtisq; + c__ = w - dtipsq * dw + delsq * (d__1 * d__1); + } else { + d__1 = z__[ip1] / dtipsq; + c__ = w - dtisq * dw - delsq * (d__1 * d__1); + } + a = (dtipsq + dtisq) * w - dtipsq * dtisq * dw; + b = dtipsq * dtisq * w; + if (c__ == 0.) { + if (a == 0.) { + if (orgati) { + a = z__[*i__] * z__[*i__] + dtipsq * dtipsq * (dpsi + dphi); + } else { + a = z__[ip1] * z__[ip1] + dtisq * dtisq * (dpsi + dphi); + } + } + eta = b / a; + } else if (a <= 0.) { + eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ * 2.); + } else { + eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))); + } + } + } + if (w * eta >= 0.) { + eta = -w / dw; + } + eta /= *sigma + sqrt(*sigma * *sigma + eta); + temp = tau + eta; + if (temp > sgub || temp < sglb) { + if (w < 0.) { + eta = (sgub - tau) / 2.; + } else { + eta = (sglb - tau) / 2.; + } + if (geomavg) { + if (w < 0.) { + if (tau > 0.) { + eta = sqrt(sgub * tau) - tau; + } + } else { + if (sglb > 0.) { + eta = sqrt(sglb * tau) - tau; + } + } + } + } + prew = w; + tau += eta; + *sigma += eta; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + work[j] += eta; + delta[j] -= eta; + } + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = iim1; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / (work[j] * delta[j]); + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; + } + erretm = abs(erretm); + dphi = 0.; + phi = 0.; + i__1 = iip1; + for (j = *n; j >= i__1; --j) { + temp = z__[j] / (work[j] * delta[j]); + phi += z__[j] * temp; + dphi += temp * temp; + erretm += phi; + } + tau2 = work[ii] * delta[ii]; + temp = z__[ii] / tau2; + dw = dpsi + dphi + temp * temp; + temp = z__[ii] * temp; + w = rhoinv + phi + psi + temp; + erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3.; + swtch = FALSE_; + if (orgati) { + if (-w > abs(prew) / 10.) { + swtch = TRUE_; + } + } else { + if (w > abs(prew) / 10.) { + swtch = TRUE_; + } + } + iter = niter + 1; + for (niter = iter; niter <= 400; ++niter) { + if (abs(w) <= eps * erretm) { + goto L240; + } + if (w <= 0.) { + sglb = max(sglb, tau); + } else { + sgub = min(sgub, tau); + } + if (!swtch3) { + dtipsq = work[ip1] * delta[ip1]; + dtisq = work[*i__] * delta[*i__]; + if (!swtch) { + if (orgati) { + d__1 = z__[*i__] / dtisq; + c__ = w - dtipsq * dw + delsq * (d__1 * d__1); + } else { + d__1 = z__[ip1] / dtipsq; + c__ = w - dtisq * dw - delsq * (d__1 * d__1); + } + } else { + temp = z__[ii] / (work[ii] * delta[ii]); + if (orgati) { + dpsi += temp * temp; + } else { + dphi += temp * temp; + } + c__ = w - dtisq * dpsi - dtipsq * dphi; + } + a = (dtipsq + dtisq) * w - dtipsq * dtisq * dw; + b = dtipsq * dtisq * w; + if (c__ == 0.) { + if (a == 0.) { + if (!swtch) { + if (orgati) { + a = z__[*i__] * z__[*i__] + dtipsq * dtipsq * (dpsi + dphi); + } else { + a = z__[ip1] * z__[ip1] + dtisq * dtisq * (dpsi + dphi); + } + } else { + a = dtisq * dtisq * dpsi + dtipsq * dtipsq * dphi; + } + } + eta = b / a; + } else if (a <= 0.) { + eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ * 2.); + } else { + eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))); + } + } else { + dtiim = work[iim1] * delta[iim1]; + dtiip = work[iip1] * delta[iip1]; + temp = rhoinv + psi + phi; + if (swtch) { + c__ = temp - dtiim * dpsi - dtiip * dphi; + zz[0] = dtiim * dtiim * dpsi; + zz[2] = dtiip * dtiip * dphi; + } else { + if (orgati) { + temp1 = z__[iim1] / dtiim; + temp1 *= temp1; + temp2 = (d__[iim1] - d__[iip1]) * (d__[iim1] + d__[iip1]) * temp1; + c__ = temp - dtiip * (dpsi + dphi) - temp2; + zz[0] = z__[iim1] * z__[iim1]; + if (dpsi < temp1) { + zz[2] = dtiip * dtiip * dphi; + } else { + zz[2] = dtiip * dtiip * (dpsi - temp1 + dphi); + } + } else { + temp1 = z__[iip1] / dtiip; + temp1 *= temp1; + temp2 = (d__[iip1] - d__[iim1]) * (d__[iim1] + d__[iip1]) * temp1; + c__ = temp - dtiim * (dpsi + dphi) - temp2; + if (dphi < temp1) { + zz[0] = dtiim * dtiim * dpsi; + } else { + zz[0] = dtiim * dtiim * (dpsi + (dphi - temp1)); + } + zz[2] = z__[iip1] * z__[iip1]; + } + } + dd[0] = dtiim; + dd[1] = delta[ii] * work[ii]; + dd[2] = dtiip; + dlaed6_(&niter, &orgati, &c__, dd, zz, &w, &eta, info); + if (*info != 0) { + swtch3 = FALSE_; + *info = 0; + dtipsq = work[ip1] * delta[ip1]; + dtisq = work[*i__] * delta[*i__]; + if (!swtch) { + if (orgati) { + d__1 = z__[*i__] / dtisq; + c__ = w - dtipsq * dw + delsq * (d__1 * d__1); + } else { + d__1 = z__[ip1] / dtipsq; + c__ = w - dtisq * dw - delsq * (d__1 * d__1); + } + } else { + temp = z__[ii] / (work[ii] * delta[ii]); + if (orgati) { + dpsi += temp * temp; + } else { + dphi += temp * temp; + } + c__ = w - dtisq * dpsi - dtipsq * dphi; + } + a = (dtipsq + dtisq) * w - dtipsq * dtisq * dw; + b = dtipsq * dtisq * w; + if (c__ == 0.) { + if (a == 0.) { + if (!swtch) { + if (orgati) { + a = z__[*i__] * z__[*i__] + dtipsq * dtipsq * (dpsi + dphi); + } else { + a = z__[ip1] * z__[ip1] + dtisq * dtisq * (dpsi + dphi); + } + } else { + a = dtisq * dtisq * dpsi + dtipsq * dtipsq * dphi; + } + } + eta = b / a; + } else if (a <= 0.) { + eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ * 2.); + } else { + eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))); + } + } + } + if (w * eta >= 0.) { + eta = -w / dw; + } + eta /= *sigma + sqrt(*sigma * *sigma + eta); + temp = tau + eta; + if (temp > sgub || temp < sglb) { + if (w < 0.) { + eta = (sgub - tau) / 2.; + } else { + eta = (sglb - tau) / 2.; + } + if (geomavg) { + if (w < 0.) { + if (tau > 0.) { + eta = sqrt(sgub * tau) - tau; + } + } else { + if (sglb > 0.) { + eta = sqrt(sglb * tau) - tau; + } + } + } + } + prew = w; + tau += eta; + *sigma += eta; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + work[j] += eta; + delta[j] -= eta; + } + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = iim1; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / (work[j] * delta[j]); + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; + } + erretm = abs(erretm); + dphi = 0.; + phi = 0.; + i__1 = iip1; + for (j = *n; j >= i__1; --j) { + temp = z__[j] / (work[j] * delta[j]); + phi += z__[j] * temp; + dphi += temp * temp; + erretm += phi; + } + tau2 = work[ii] * delta[ii]; + temp = z__[ii] / tau2; + dw = dpsi + dphi + temp * temp; + temp = z__[ii] * temp; + w = rhoinv + phi + psi + temp; + erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3.; + if (w * prew > 0. && abs(w) > abs(prew) / 10.) { + swtch = !swtch; + } + } + *info = 1; + } +L240: + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlasd4.f b/lib/linalg/dlasd4.f deleted file mode 100644 index acfd896b3b..0000000000 --- a/lib/linalg/dlasd4.f +++ /dev/null @@ -1,1058 +0,0 @@ -*> \brief \b DLASD4 computes the square root of the i-th updated eigenvalue of a positive symmetric rank-one modification to a positive diagonal matrix. Used by dbdsdc. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASD4 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER I, INFO, N -* DOUBLE PRECISION RHO, SIGMA -* .. -* .. Array Arguments .. -* DOUBLE PRECISION D( * ), DELTA( * ), WORK( * ), Z( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> This subroutine computes the square root of the I-th updated -*> eigenvalue of a positive symmetric rank-one modification to -*> a positive diagonal matrix whose entries are given as the squares -*> of the corresponding entries in the array d, and that -*> -*> 0 <= D(i) < D(j) for i < j -*> -*> and that RHO > 0. This is arranged by the calling routine, and is -*> no loss in generality. The rank-one modified system is thus -*> -*> diag( D ) * diag( D ) + RHO * Z * Z_transpose. -*> -*> where we assume the Euclidean norm of Z is 1. -*> -*> The method consists of approximating the rational functions in the -*> secular equation by simpler interpolating rational functions. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The length of all arrays. -*> \endverbatim -*> -*> \param[in] I -*> \verbatim -*> I is INTEGER -*> The index of the eigenvalue to be computed. 1 <= I <= N. -*> \endverbatim -*> -*> \param[in] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension ( N ) -*> The original eigenvalues. It is assumed that they are in -*> order, 0 <= D(I) < D(J) for I < J. -*> \endverbatim -*> -*> \param[in] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension ( N ) -*> The components of the updating vector. -*> \endverbatim -*> -*> \param[out] DELTA -*> \verbatim -*> DELTA is DOUBLE PRECISION array, dimension ( N ) -*> If N .ne. 1, DELTA contains (D(j) - sigma_I) in its j-th -*> component. If N = 1, then DELTA(1) = 1. The vector DELTA -*> contains the information necessary to construct the -*> (singular) eigenvectors. -*> \endverbatim -*> -*> \param[in] RHO -*> \verbatim -*> RHO is DOUBLE PRECISION -*> The scalar in the symmetric updating formula. -*> \endverbatim -*> -*> \param[out] SIGMA -*> \verbatim -*> SIGMA is DOUBLE PRECISION -*> The computed sigma_I, the I-th updated eigenvalue. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension ( N ) -*> If N .ne. 1, WORK contains (D(j) + sigma_I) in its j-th -*> component. If N = 1, then WORK( 1 ) = 1. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> > 0: if INFO = 1, the updating process failed. -*> \endverbatim -* -*> \par Internal Parameters: -* ========================= -*> -*> \verbatim -*> Logical variable ORGATI (origin-at-i?) is used for distinguishing -*> whether D(i) or D(i+1) is treated as the origin. -*> -*> ORGATI = .true. origin at i -*> ORGATI = .false. origin at i+1 -*> -*> Logical variable SWTCH3 (switch-for-3-poles?) is for noting -*> if we are working with THREE poles! -*> -*> MAXIT is the maximum number of iterations allowed for each -*> eigenvalue. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -*> \par Contributors: -* ================== -*> -*> Ren-Cang Li, Computer Science Division, University of California -*> at Berkeley, USA -*> -* ===================================================================== - SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER I, INFO, N - DOUBLE PRECISION RHO, SIGMA -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), DELTA( * ), WORK( * ), Z( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - INTEGER MAXIT - PARAMETER ( MAXIT = 400 ) - DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, - $ THREE = 3.0D+0, FOUR = 4.0D+0, EIGHT = 8.0D+0, - $ TEN = 10.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL ORGATI, SWTCH, SWTCH3, GEOMAVG - INTEGER II, IIM1, IIP1, IP1, ITER, J, NITER - DOUBLE PRECISION A, B, C, DELSQ, DELSQ2, SQ2, DPHI, DPSI, DTIIM, - $ DTIIP, DTIPSQ, DTISQ, DTNSQ, DTNSQ1, DW, EPS, - $ ERRETM, ETA, PHI, PREW, PSI, RHOINV, SGLB, - $ SGUB, TAU, TAU2, TEMP, TEMP1, TEMP2, W -* .. -* .. Local Arrays .. - DOUBLE PRECISION DD( 3 ), ZZ( 3 ) -* .. -* .. External Subroutines .. - EXTERNAL DLAED6, DLASD5 -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* -* Since this routine is called in an inner loop, we do no argument -* checking. -* -* Quick return for N=1 and 2. -* - INFO = 0 - IF( N.EQ.1 ) THEN -* -* Presumably, I=1 upon entry -* - SIGMA = SQRT( D( 1 )*D( 1 )+RHO*Z( 1 )*Z( 1 ) ) - DELTA( 1 ) = ONE - WORK( 1 ) = ONE - RETURN - END IF - IF( N.EQ.2 ) THEN - CALL DLASD5( I, D, Z, DELTA, RHO, SIGMA, WORK ) - RETURN - END IF -* -* Compute machine epsilon -* - EPS = DLAMCH( 'Epsilon' ) - RHOINV = ONE / RHO - TAU2= ZERO -* -* The case I = N -* - IF( I.EQ.N ) THEN -* -* Initialize some basic variables -* - II = N - 1 - NITER = 1 -* -* Calculate initial guess -* - TEMP = RHO / TWO -* -* If ||Z||_2 is not one, then TEMP should be set to -* RHO * ||Z||_2^2 / TWO -* - TEMP1 = TEMP / ( D( N )+SQRT( D( N )*D( N )+TEMP ) ) - DO 10 J = 1, N - WORK( J ) = D( J ) + D( N ) + TEMP1 - DELTA( J ) = ( D( J )-D( N ) ) - TEMP1 - 10 CONTINUE -* - PSI = ZERO - DO 20 J = 1, N - 2 - PSI = PSI + Z( J )*Z( J ) / ( DELTA( J )*WORK( J ) ) - 20 CONTINUE -* - C = RHOINV + PSI - W = C + Z( II )*Z( II ) / ( DELTA( II )*WORK( II ) ) + - $ Z( N )*Z( N ) / ( DELTA( N )*WORK( N ) ) -* - IF( W.LE.ZERO ) THEN - TEMP1 = SQRT( D( N )*D( N )+RHO ) - TEMP = Z( N-1 )*Z( N-1 ) / ( ( D( N-1 )+TEMP1 )* - $ ( D( N )-D( N-1 )+RHO / ( D( N )+TEMP1 ) ) ) + - $ Z( N )*Z( N ) / RHO -* -* The following TAU2 is to approximate -* SIGMA_n^2 - D( N )*D( N ) -* - IF( C.LE.TEMP ) THEN - TAU = RHO - ELSE - DELSQ = ( D( N )-D( N-1 ) )*( D( N )+D( N-1 ) ) - A = -C*DELSQ + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N ) - B = Z( N )*Z( N )*DELSQ - IF( A.LT.ZERO ) THEN - TAU2 = TWO*B / ( SQRT( A*A+FOUR*B*C )-A ) - ELSE - TAU2 = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C ) - END IF - TAU = TAU2 / ( D( N )+SQRT( D( N )*D( N )+TAU2 ) ) - END IF -* -* It can be proved that -* D(N)^2+RHO/2 <= SIGMA_n^2 < D(N)^2+TAU2 <= D(N)^2+RHO -* - ELSE - DELSQ = ( D( N )-D( N-1 ) )*( D( N )+D( N-1 ) ) - A = -C*DELSQ + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N ) - B = Z( N )*Z( N )*DELSQ -* -* The following TAU2 is to approximate -* SIGMA_n^2 - D( N )*D( N ) -* - IF( A.LT.ZERO ) THEN - TAU2 = TWO*B / ( SQRT( A*A+FOUR*B*C )-A ) - ELSE - TAU2 = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C ) - END IF - TAU = TAU2 / ( D( N )+SQRT( D( N )*D( N )+TAU2 ) ) - -* -* It can be proved that -* D(N)^2 < D(N)^2+TAU2 < SIGMA(N)^2 < D(N)^2+RHO/2 -* - END IF -* -* The following TAU is to approximate SIGMA_n - D( N ) -* -* TAU = TAU2 / ( D( N )+SQRT( D( N )*D( N )+TAU2 ) ) -* - SIGMA = D( N ) + TAU - DO 30 J = 1, N - DELTA( J ) = ( D( J )-D( N ) ) - TAU - WORK( J ) = D( J ) + D( N ) + TAU - 30 CONTINUE -* -* Evaluate PSI and the derivative DPSI -* - DPSI = ZERO - PSI = ZERO - ERRETM = ZERO - DO 40 J = 1, II - TEMP = Z( J ) / ( DELTA( J )*WORK( J ) ) - PSI = PSI + Z( J )*TEMP - DPSI = DPSI + TEMP*TEMP - ERRETM = ERRETM + PSI - 40 CONTINUE - ERRETM = ABS( ERRETM ) -* -* Evaluate PHI and the derivative DPHI -* - TEMP = Z( N ) / ( DELTA( N )*WORK( N ) ) - PHI = Z( N )*TEMP - DPHI = TEMP*TEMP - ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV -* $ + ABS( TAU2 )*( DPSI+DPHI ) -* - W = RHOINV + PHI + PSI -* -* Test for convergence -* - IF( ABS( W ).LE.EPS*ERRETM ) THEN - GO TO 240 - END IF -* -* Calculate the new step -* - NITER = NITER + 1 - DTNSQ1 = WORK( N-1 )*DELTA( N-1 ) - DTNSQ = WORK( N )*DELTA( N ) - C = W - DTNSQ1*DPSI - DTNSQ*DPHI - A = ( DTNSQ+DTNSQ1 )*W - DTNSQ*DTNSQ1*( DPSI+DPHI ) - B = DTNSQ*DTNSQ1*W - IF( C.LT.ZERO ) - $ C = ABS( C ) - IF( C.EQ.ZERO ) THEN - ETA = RHO - SIGMA*SIGMA - ELSE IF( A.GE.ZERO ) THEN - ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) - ELSE - ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) - END IF -* -* Note, eta should be positive if w is negative, and -* eta should be negative otherwise. However, -* if for some reason caused by roundoff, eta*w > 0, -* we simply use one Newton step instead. This way -* will guarantee eta*w < 0. -* - IF( W*ETA.GT.ZERO ) - $ ETA = -W / ( DPSI+DPHI ) - TEMP = ETA - DTNSQ - IF( TEMP.GT.RHO ) - $ ETA = RHO + DTNSQ -* - ETA = ETA / ( SIGMA+SQRT( ETA+SIGMA*SIGMA ) ) - TAU = TAU + ETA - SIGMA = SIGMA + ETA -* - DO 50 J = 1, N - DELTA( J ) = DELTA( J ) - ETA - WORK( J ) = WORK( J ) + ETA - 50 CONTINUE -* -* Evaluate PSI and the derivative DPSI -* - DPSI = ZERO - PSI = ZERO - ERRETM = ZERO - DO 60 J = 1, II - TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) - PSI = PSI + Z( J )*TEMP - DPSI = DPSI + TEMP*TEMP - ERRETM = ERRETM + PSI - 60 CONTINUE - ERRETM = ABS( ERRETM ) -* -* Evaluate PHI and the derivative DPHI -* - TAU2 = WORK( N )*DELTA( N ) - TEMP = Z( N ) / TAU2 - PHI = Z( N )*TEMP - DPHI = TEMP*TEMP - ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV -* $ + ABS( TAU2 )*( DPSI+DPHI ) -* - W = RHOINV + PHI + PSI -* -* Main loop to update the values of the array DELTA -* - ITER = NITER + 1 -* - DO 90 NITER = ITER, MAXIT -* -* Test for convergence -* - IF( ABS( W ).LE.EPS*ERRETM ) THEN - GO TO 240 - END IF -* -* Calculate the new step -* - DTNSQ1 = WORK( N-1 )*DELTA( N-1 ) - DTNSQ = WORK( N )*DELTA( N ) - C = W - DTNSQ1*DPSI - DTNSQ*DPHI - A = ( DTNSQ+DTNSQ1 )*W - DTNSQ1*DTNSQ*( DPSI+DPHI ) - B = DTNSQ1*DTNSQ*W - IF( A.GE.ZERO ) THEN - ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) - ELSE - ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) - END IF -* -* Note, eta should be positive if w is negative, and -* eta should be negative otherwise. However, -* if for some reason caused by roundoff, eta*w > 0, -* we simply use one Newton step instead. This way -* will guarantee eta*w < 0. -* - IF( W*ETA.GT.ZERO ) - $ ETA = -W / ( DPSI+DPHI ) - TEMP = ETA - DTNSQ - IF( TEMP.LE.ZERO ) - $ ETA = ETA / TWO -* - ETA = ETA / ( SIGMA+SQRT( ETA+SIGMA*SIGMA ) ) - TAU = TAU + ETA - SIGMA = SIGMA + ETA -* - DO 70 J = 1, N - DELTA( J ) = DELTA( J ) - ETA - WORK( J ) = WORK( J ) + ETA - 70 CONTINUE -* -* Evaluate PSI and the derivative DPSI -* - DPSI = ZERO - PSI = ZERO - ERRETM = ZERO - DO 80 J = 1, II - TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) - PSI = PSI + Z( J )*TEMP - DPSI = DPSI + TEMP*TEMP - ERRETM = ERRETM + PSI - 80 CONTINUE - ERRETM = ABS( ERRETM ) -* -* Evaluate PHI and the derivative DPHI -* - TAU2 = WORK( N )*DELTA( N ) - TEMP = Z( N ) / TAU2 - PHI = Z( N )*TEMP - DPHI = TEMP*TEMP - ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV -* $ + ABS( TAU2 )*( DPSI+DPHI ) -* - W = RHOINV + PHI + PSI - 90 CONTINUE -* -* Return with INFO = 1, NITER = MAXIT and not converged -* - INFO = 1 - GO TO 240 -* -* End for the case I = N -* - ELSE -* -* The case for I < N -* - NITER = 1 - IP1 = I + 1 -* -* Calculate initial guess -* - DELSQ = ( D( IP1 )-D( I ) )*( D( IP1 )+D( I ) ) - DELSQ2 = DELSQ / TWO - SQ2=SQRT( ( D( I )*D( I )+D( IP1 )*D( IP1 ) ) / TWO ) - TEMP = DELSQ2 / ( D( I )+SQ2 ) - DO 100 J = 1, N - WORK( J ) = D( J ) + D( I ) + TEMP - DELTA( J ) = ( D( J )-D( I ) ) - TEMP - 100 CONTINUE -* - PSI = ZERO - DO 110 J = 1, I - 1 - PSI = PSI + Z( J )*Z( J ) / ( WORK( J )*DELTA( J ) ) - 110 CONTINUE -* - PHI = ZERO - DO 120 J = N, I + 2, -1 - PHI = PHI + Z( J )*Z( J ) / ( WORK( J )*DELTA( J ) ) - 120 CONTINUE - C = RHOINV + PSI + PHI - W = C + Z( I )*Z( I ) / ( WORK( I )*DELTA( I ) ) + - $ Z( IP1 )*Z( IP1 ) / ( WORK( IP1 )*DELTA( IP1 ) ) -* - GEOMAVG = .FALSE. - IF( W.GT.ZERO ) THEN -* -* d(i)^2 < the ith sigma^2 < (d(i)^2+d(i+1)^2)/2 -* -* We choose d(i) as origin. -* - ORGATI = .TRUE. - II = I - SGLB = ZERO - SGUB = DELSQ2 / ( D( I )+SQ2 ) - A = C*DELSQ + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 ) - B = Z( I )*Z( I )*DELSQ - IF( A.GT.ZERO ) THEN - TAU2 = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) - ELSE - TAU2 = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) - END IF -* -* TAU2 now is an estimation of SIGMA^2 - D( I )^2. The -* following, however, is the corresponding estimation of -* SIGMA - D( I ). -* - TAU = TAU2 / ( D( I )+SQRT( D( I )*D( I )+TAU2 ) ) - TEMP = SQRT(EPS) - IF( (D(I).LE.TEMP*D(IP1)).AND.(ABS(Z(I)).LE.TEMP) - $ .AND.(D(I).GT.ZERO) ) THEN - TAU = MIN( TEN*D(I), SGUB ) - GEOMAVG = .TRUE. - END IF - ELSE -* -* (d(i)^2+d(i+1)^2)/2 <= the ith sigma^2 < d(i+1)^2/2 -* -* We choose d(i+1) as origin. -* - ORGATI = .FALSE. - II = IP1 - SGLB = -DELSQ2 / ( D( II )+SQ2 ) - SGUB = ZERO - A = C*DELSQ - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 ) - B = Z( IP1 )*Z( IP1 )*DELSQ - IF( A.LT.ZERO ) THEN - TAU2 = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) ) - ELSE - TAU2 = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C ) - END IF -* -* TAU2 now is an estimation of SIGMA^2 - D( IP1 )^2. The -* following, however, is the corresponding estimation of -* SIGMA - D( IP1 ). -* - TAU = TAU2 / ( D( IP1 )+SQRT( ABS( D( IP1 )*D( IP1 )+ - $ TAU2 ) ) ) - END IF -* - SIGMA = D( II ) + TAU - DO 130 J = 1, N - WORK( J ) = D( J ) + D( II ) + TAU - DELTA( J ) = ( D( J )-D( II ) ) - TAU - 130 CONTINUE - IIM1 = II - 1 - IIP1 = II + 1 -* -* Evaluate PSI and the derivative DPSI -* - DPSI = ZERO - PSI = ZERO - ERRETM = ZERO - DO 150 J = 1, IIM1 - TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) - PSI = PSI + Z( J )*TEMP - DPSI = DPSI + TEMP*TEMP - ERRETM = ERRETM + PSI - 150 CONTINUE - ERRETM = ABS( ERRETM ) -* -* Evaluate PHI and the derivative DPHI -* - DPHI = ZERO - PHI = ZERO - DO 160 J = N, IIP1, -1 - TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) - PHI = PHI + Z( J )*TEMP - DPHI = DPHI + TEMP*TEMP - ERRETM = ERRETM + PHI - 160 CONTINUE -* - W = RHOINV + PHI + PSI -* -* W is the value of the secular function with -* its ii-th element removed. -* - SWTCH3 = .FALSE. - IF( ORGATI ) THEN - IF( W.LT.ZERO ) - $ SWTCH3 = .TRUE. - ELSE - IF( W.GT.ZERO ) - $ SWTCH3 = .TRUE. - END IF - IF( II.EQ.1 .OR. II.EQ.N ) - $ SWTCH3 = .FALSE. -* - TEMP = Z( II ) / ( WORK( II )*DELTA( II ) ) - DW = DPSI + DPHI + TEMP*TEMP - TEMP = Z( II )*TEMP - W = W + TEMP - ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV - $ + THREE*ABS( TEMP ) -* $ + ABS( TAU2 )*DW -* -* Test for convergence -* - IF( ABS( W ).LE.EPS*ERRETM ) THEN - GO TO 240 - END IF -* - IF( W.LE.ZERO ) THEN - SGLB = MAX( SGLB, TAU ) - ELSE - SGUB = MIN( SGUB, TAU ) - END IF -* -* Calculate the new step -* - NITER = NITER + 1 - IF( .NOT.SWTCH3 ) THEN - DTIPSQ = WORK( IP1 )*DELTA( IP1 ) - DTISQ = WORK( I )*DELTA( I ) - IF( ORGATI ) THEN - C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2 - ELSE - C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2 - END IF - A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW - B = DTIPSQ*DTISQ*W - IF( C.EQ.ZERO ) THEN - IF( A.EQ.ZERO ) THEN - IF( ORGATI ) THEN - A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ*( DPSI+DPHI ) - ELSE - A = Z( IP1 )*Z( IP1 ) + DTISQ*DTISQ*( DPSI+DPHI ) - END IF - END IF - ETA = B / A - ELSE IF( A.LE.ZERO ) THEN - ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) - ELSE - ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) - END IF - ELSE -* -* Interpolation using THREE most relevant poles -* - DTIIM = WORK( IIM1 )*DELTA( IIM1 ) - DTIIP = WORK( IIP1 )*DELTA( IIP1 ) - TEMP = RHOINV + PSI + PHI - IF( ORGATI ) THEN - TEMP1 = Z( IIM1 ) / DTIIM - TEMP1 = TEMP1*TEMP1 - C = ( TEMP - DTIIP*( DPSI+DPHI ) ) - - $ ( D( IIM1 )-D( IIP1 ) )*( D( IIM1 )+D( IIP1 ) )*TEMP1 - ZZ( 1 ) = Z( IIM1 )*Z( IIM1 ) - IF( DPSI.LT.TEMP1 ) THEN - ZZ( 3 ) = DTIIP*DTIIP*DPHI - ELSE - ZZ( 3 ) = DTIIP*DTIIP*( ( DPSI-TEMP1 )+DPHI ) - END IF - ELSE - TEMP1 = Z( IIP1 ) / DTIIP - TEMP1 = TEMP1*TEMP1 - C = ( TEMP - DTIIM*( DPSI+DPHI ) ) - - $ ( D( IIP1 )-D( IIM1 ) )*( D( IIM1 )+D( IIP1 ) )*TEMP1 - IF( DPHI.LT.TEMP1 ) THEN - ZZ( 1 ) = DTIIM*DTIIM*DPSI - ELSE - ZZ( 1 ) = DTIIM*DTIIM*( DPSI+( DPHI-TEMP1 ) ) - END IF - ZZ( 3 ) = Z( IIP1 )*Z( IIP1 ) - END IF - ZZ( 2 ) = Z( II )*Z( II ) - DD( 1 ) = DTIIM - DD( 2 ) = DELTA( II )*WORK( II ) - DD( 3 ) = DTIIP - CALL DLAED6( NITER, ORGATI, C, DD, ZZ, W, ETA, INFO ) -* - IF( INFO.NE.0 ) THEN -* -* If INFO is not 0, i.e., DLAED6 failed, switch back -* to 2 pole interpolation. -* - SWTCH3 = .FALSE. - INFO = 0 - DTIPSQ = WORK( IP1 )*DELTA( IP1 ) - DTISQ = WORK( I )*DELTA( I ) - IF( ORGATI ) THEN - C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2 - ELSE - C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2 - END IF - A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW - B = DTIPSQ*DTISQ*W - IF( C.EQ.ZERO ) THEN - IF( A.EQ.ZERO ) THEN - IF( ORGATI ) THEN - A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ*( DPSI+DPHI ) - ELSE - A = Z( IP1 )*Z( IP1 ) + DTISQ*DTISQ*( DPSI+DPHI) - END IF - END IF - ETA = B / A - ELSE IF( A.LE.ZERO ) THEN - ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) - ELSE - ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) - END IF - END IF - END IF -* -* Note, eta should be positive if w is negative, and -* eta should be negative otherwise. However, -* if for some reason caused by roundoff, eta*w > 0, -* we simply use one Newton step instead. This way -* will guarantee eta*w < 0. -* - IF( W*ETA.GE.ZERO ) - $ ETA = -W / DW -* - ETA = ETA / ( SIGMA+SQRT( SIGMA*SIGMA+ETA ) ) - TEMP = TAU + ETA - IF( TEMP.GT.SGUB .OR. TEMP.LT.SGLB ) THEN - IF( W.LT.ZERO ) THEN - ETA = ( SGUB-TAU ) / TWO - ELSE - ETA = ( SGLB-TAU ) / TWO - END IF - IF( GEOMAVG ) THEN - IF( W .LT. ZERO ) THEN - IF( TAU .GT. ZERO ) THEN - ETA = SQRT(SGUB*TAU)-TAU - END IF - ELSE - IF( SGLB .GT. ZERO ) THEN - ETA = SQRT(SGLB*TAU)-TAU - END IF - END IF - END IF - END IF -* - PREW = W -* - TAU = TAU + ETA - SIGMA = SIGMA + ETA -* - DO 170 J = 1, N - WORK( J ) = WORK( J ) + ETA - DELTA( J ) = DELTA( J ) - ETA - 170 CONTINUE -* -* Evaluate PSI and the derivative DPSI -* - DPSI = ZERO - PSI = ZERO - ERRETM = ZERO - DO 180 J = 1, IIM1 - TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) - PSI = PSI + Z( J )*TEMP - DPSI = DPSI + TEMP*TEMP - ERRETM = ERRETM + PSI - 180 CONTINUE - ERRETM = ABS( ERRETM ) -* -* Evaluate PHI and the derivative DPHI -* - DPHI = ZERO - PHI = ZERO - DO 190 J = N, IIP1, -1 - TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) - PHI = PHI + Z( J )*TEMP - DPHI = DPHI + TEMP*TEMP - ERRETM = ERRETM + PHI - 190 CONTINUE -* - TAU2 = WORK( II )*DELTA( II ) - TEMP = Z( II ) / TAU2 - DW = DPSI + DPHI + TEMP*TEMP - TEMP = Z( II )*TEMP - W = RHOINV + PHI + PSI + TEMP - ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV - $ + THREE*ABS( TEMP ) -* $ + ABS( TAU2 )*DW -* - SWTCH = .FALSE. - IF( ORGATI ) THEN - IF( -W.GT.ABS( PREW ) / TEN ) - $ SWTCH = .TRUE. - ELSE - IF( W.GT.ABS( PREW ) / TEN ) - $ SWTCH = .TRUE. - END IF -* -* Main loop to update the values of the array DELTA and WORK -* - ITER = NITER + 1 -* - DO 230 NITER = ITER, MAXIT -* -* Test for convergence -* - IF( ABS( W ).LE.EPS*ERRETM ) THEN -* $ .OR. (SGUB-SGLB).LE.EIGHT*ABS(SGUB+SGLB) ) THEN - GO TO 240 - END IF -* - IF( W.LE.ZERO ) THEN - SGLB = MAX( SGLB, TAU ) - ELSE - SGUB = MIN( SGUB, TAU ) - END IF -* -* Calculate the new step -* - IF( .NOT.SWTCH3 ) THEN - DTIPSQ = WORK( IP1 )*DELTA( IP1 ) - DTISQ = WORK( I )*DELTA( I ) - IF( .NOT.SWTCH ) THEN - IF( ORGATI ) THEN - C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2 - ELSE - C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2 - END IF - ELSE - TEMP = Z( II ) / ( WORK( II )*DELTA( II ) ) - IF( ORGATI ) THEN - DPSI = DPSI + TEMP*TEMP - ELSE - DPHI = DPHI + TEMP*TEMP - END IF - C = W - DTISQ*DPSI - DTIPSQ*DPHI - END IF - A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW - B = DTIPSQ*DTISQ*W - IF( C.EQ.ZERO ) THEN - IF( A.EQ.ZERO ) THEN - IF( .NOT.SWTCH ) THEN - IF( ORGATI ) THEN - A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ* - $ ( DPSI+DPHI ) - ELSE - A = Z( IP1 )*Z( IP1 ) + - $ DTISQ*DTISQ*( DPSI+DPHI ) - END IF - ELSE - A = DTISQ*DTISQ*DPSI + DTIPSQ*DTIPSQ*DPHI - END IF - END IF - ETA = B / A - ELSE IF( A.LE.ZERO ) THEN - ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) - ELSE - ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) - END IF - ELSE -* -* Interpolation using THREE most relevant poles -* - DTIIM = WORK( IIM1 )*DELTA( IIM1 ) - DTIIP = WORK( IIP1 )*DELTA( IIP1 ) - TEMP = RHOINV + PSI + PHI - IF( SWTCH ) THEN - C = TEMP - DTIIM*DPSI - DTIIP*DPHI - ZZ( 1 ) = DTIIM*DTIIM*DPSI - ZZ( 3 ) = DTIIP*DTIIP*DPHI - ELSE - IF( ORGATI ) THEN - TEMP1 = Z( IIM1 ) / DTIIM - TEMP1 = TEMP1*TEMP1 - TEMP2 = ( D( IIM1 )-D( IIP1 ) )* - $ ( D( IIM1 )+D( IIP1 ) )*TEMP1 - C = TEMP - DTIIP*( DPSI+DPHI ) - TEMP2 - ZZ( 1 ) = Z( IIM1 )*Z( IIM1 ) - IF( DPSI.LT.TEMP1 ) THEN - ZZ( 3 ) = DTIIP*DTIIP*DPHI - ELSE - ZZ( 3 ) = DTIIP*DTIIP*( ( DPSI-TEMP1 )+DPHI ) - END IF - ELSE - TEMP1 = Z( IIP1 ) / DTIIP - TEMP1 = TEMP1*TEMP1 - TEMP2 = ( D( IIP1 )-D( IIM1 ) )* - $ ( D( IIM1 )+D( IIP1 ) )*TEMP1 - C = TEMP - DTIIM*( DPSI+DPHI ) - TEMP2 - IF( DPHI.LT.TEMP1 ) THEN - ZZ( 1 ) = DTIIM*DTIIM*DPSI - ELSE - ZZ( 1 ) = DTIIM*DTIIM*( DPSI+( DPHI-TEMP1 ) ) - END IF - ZZ( 3 ) = Z( IIP1 )*Z( IIP1 ) - END IF - END IF - DD( 1 ) = DTIIM - DD( 2 ) = DELTA( II )*WORK( II ) - DD( 3 ) = DTIIP - CALL DLAED6( NITER, ORGATI, C, DD, ZZ, W, ETA, INFO ) -* - IF( INFO.NE.0 ) THEN -* -* If INFO is not 0, i.e., DLAED6 failed, switch -* back to two pole interpolation -* - SWTCH3 = .FALSE. - INFO = 0 - DTIPSQ = WORK( IP1 )*DELTA( IP1 ) - DTISQ = WORK( I )*DELTA( I ) - IF( .NOT.SWTCH ) THEN - IF( ORGATI ) THEN - C = W - DTIPSQ*DW + DELSQ*( Z( I )/DTISQ )**2 - ELSE - C = W - DTISQ*DW - DELSQ*( Z( IP1 )/DTIPSQ )**2 - END IF - ELSE - TEMP = Z( II ) / ( WORK( II )*DELTA( II ) ) - IF( ORGATI ) THEN - DPSI = DPSI + TEMP*TEMP - ELSE - DPHI = DPHI + TEMP*TEMP - END IF - C = W - DTISQ*DPSI - DTIPSQ*DPHI - END IF - A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW - B = DTIPSQ*DTISQ*W - IF( C.EQ.ZERO ) THEN - IF( A.EQ.ZERO ) THEN - IF( .NOT.SWTCH ) THEN - IF( ORGATI ) THEN - A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ* - $ ( DPSI+DPHI ) - ELSE - A = Z( IP1 )*Z( IP1 ) + - $ DTISQ*DTISQ*( DPSI+DPHI ) - END IF - ELSE - A = DTISQ*DTISQ*DPSI + DTIPSQ*DTIPSQ*DPHI - END IF - END IF - ETA = B / A - ELSE IF( A.LE.ZERO ) THEN - ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) - ELSE - ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) - END IF - END IF - END IF -* -* Note, eta should be positive if w is negative, and -* eta should be negative otherwise. However, -* if for some reason caused by roundoff, eta*w > 0, -* we simply use one Newton step instead. This way -* will guarantee eta*w < 0. -* - IF( W*ETA.GE.ZERO ) - $ ETA = -W / DW -* - ETA = ETA / ( SIGMA+SQRT( SIGMA*SIGMA+ETA ) ) - TEMP=TAU+ETA - IF( TEMP.GT.SGUB .OR. TEMP.LT.SGLB ) THEN - IF( W.LT.ZERO ) THEN - ETA = ( SGUB-TAU ) / TWO - ELSE - ETA = ( SGLB-TAU ) / TWO - END IF - IF( GEOMAVG ) THEN - IF( W .LT. ZERO ) THEN - IF( TAU .GT. ZERO ) THEN - ETA = SQRT(SGUB*TAU)-TAU - END IF - ELSE - IF( SGLB .GT. ZERO ) THEN - ETA = SQRT(SGLB*TAU)-TAU - END IF - END IF - END IF - END IF -* - PREW = W -* - TAU = TAU + ETA - SIGMA = SIGMA + ETA -* - DO 200 J = 1, N - WORK( J ) = WORK( J ) + ETA - DELTA( J ) = DELTA( J ) - ETA - 200 CONTINUE -* -* Evaluate PSI and the derivative DPSI -* - DPSI = ZERO - PSI = ZERO - ERRETM = ZERO - DO 210 J = 1, IIM1 - TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) - PSI = PSI + Z( J )*TEMP - DPSI = DPSI + TEMP*TEMP - ERRETM = ERRETM + PSI - 210 CONTINUE - ERRETM = ABS( ERRETM ) -* -* Evaluate PHI and the derivative DPHI -* - DPHI = ZERO - PHI = ZERO - DO 220 J = N, IIP1, -1 - TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) - PHI = PHI + Z( J )*TEMP - DPHI = DPHI + TEMP*TEMP - ERRETM = ERRETM + PHI - 220 CONTINUE -* - TAU2 = WORK( II )*DELTA( II ) - TEMP = Z( II ) / TAU2 - DW = DPSI + DPHI + TEMP*TEMP - TEMP = Z( II )*TEMP - W = RHOINV + PHI + PSI + TEMP - ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV - $ + THREE*ABS( TEMP ) -* $ + ABS( TAU2 )*DW -* - IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN ) - $ SWTCH = .NOT.SWTCH -* - 230 CONTINUE -* -* Return with INFO = 1, NITER = MAXIT and not converged -* - INFO = 1 -* - END IF -* - 240 CONTINUE - RETURN -* -* End of DLASD4 -* - END diff --git a/lib/linalg/dlasd5.cpp b/lib/linalg/dlasd5.cpp new file mode 100644 index 0000000000..7bade73f84 --- /dev/null +++ b/lib/linalg/dlasd5.cpp @@ -0,0 +1,67 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dlasd5_(integer *i__, doublereal *d__, doublereal *z__, doublereal *delta, doublereal *rho, + doublereal *dsigma, doublereal *work) +{ + doublereal d__1; + double sqrt(doublereal); + doublereal b, c__, w, del, tau, delsq; + --work; + --delta; + --z__; + --d__; + del = d__[2] - d__[1]; + delsq = del * (d__[2] + d__[1]); + if (*i__ == 1) { + w = *rho * 4. * + (z__[2] * z__[2] / (d__[1] + d__[2] * 3.) - + z__[1] * z__[1] / (d__[1] * 3. + d__[2])) / + del + + 1.; + if (w > 0.) { + b = delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); + c__ = *rho * z__[1] * z__[1] * delsq; + tau = c__ * 2. / (b + sqrt((d__1 = b * b - c__ * 4., abs(d__1)))); + tau /= d__[1] + sqrt(d__[1] * d__[1] + tau); + *dsigma = d__[1] + tau; + delta[1] = -tau; + delta[2] = del - tau; + work[1] = d__[1] * 2. + tau; + work[2] = d__[1] + tau + d__[2]; + } else { + b = -delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); + c__ = *rho * z__[2] * z__[2] * delsq; + if (b > 0.) { + tau = c__ * -2. / (b + sqrt(b * b + c__ * 4.)); + } else { + tau = (b - sqrt(b * b + c__ * 4.)) / 2.; + } + tau /= d__[2] + sqrt((d__1 = d__[2] * d__[2] + tau, abs(d__1))); + *dsigma = d__[2] + tau; + delta[1] = -(del + tau); + delta[2] = -tau; + work[1] = d__[1] + tau + d__[2]; + work[2] = d__[2] * 2. + tau; + } + } else { + b = -delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); + c__ = *rho * z__[2] * z__[2] * delsq; + if (b > 0.) { + tau = (b + sqrt(b * b + c__ * 4.)) / 2.; + } else { + tau = c__ * 2. / (-b + sqrt(b * b + c__ * 4.)); + } + tau /= d__[2] + sqrt(d__[2] * d__[2] + tau); + *dsigma = d__[2] + tau; + delta[1] = -(del + tau); + delta[2] = -tau; + work[1] = d__[1] + tau + d__[2]; + work[2] = d__[2] * 2. + tau; + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlasd5.f b/lib/linalg/dlasd5.f deleted file mode 100644 index 645c2fdc3e..0000000000 --- a/lib/linalg/dlasd5.f +++ /dev/null @@ -1,228 +0,0 @@ -*> \brief \b DLASD5 computes the square root of the i-th eigenvalue of a positive symmetric rank-one modification of a 2-by-2 diagonal matrix. Used by sbdsdc. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASD5 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK ) -* -* .. Scalar Arguments .. -* INTEGER I -* DOUBLE PRECISION DSIGMA, RHO -* .. -* .. Array Arguments .. -* DOUBLE PRECISION D( 2 ), DELTA( 2 ), WORK( 2 ), Z( 2 ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> This subroutine computes the square root of the I-th eigenvalue -*> of a positive symmetric rank-one modification of a 2-by-2 diagonal -*> matrix -*> -*> diag( D ) * diag( D ) + RHO * Z * transpose(Z) . -*> -*> The diagonal entries in the array D are assumed to satisfy -*> -*> 0 <= D(i) < D(j) for i < j . -*> -*> We also assume RHO > 0 and that the Euclidean norm of the vector -*> Z is one. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] I -*> \verbatim -*> I is INTEGER -*> The index of the eigenvalue to be computed. I = 1 or I = 2. -*> \endverbatim -*> -*> \param[in] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension ( 2 ) -*> The original eigenvalues. We assume 0 <= D(1) < D(2). -*> \endverbatim -*> -*> \param[in] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension ( 2 ) -*> The components of the updating vector. -*> \endverbatim -*> -*> \param[out] DELTA -*> \verbatim -*> DELTA is DOUBLE PRECISION array, dimension ( 2 ) -*> Contains (D(j) - sigma_I) in its j-th component. -*> The vector DELTA contains the information necessary -*> to construct the eigenvectors. -*> \endverbatim -*> -*> \param[in] RHO -*> \verbatim -*> RHO is DOUBLE PRECISION -*> The scalar in the symmetric updating formula. -*> \endverbatim -*> -*> \param[out] DSIGMA -*> \verbatim -*> DSIGMA is DOUBLE PRECISION -*> The computed sigma_I, the I-th updated eigenvalue. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension ( 2 ) -*> WORK contains (D(j) + sigma_I) in its j-th component. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -*> \par Contributors: -* ================== -*> -*> Ren-Cang Li, Computer Science Division, University of California -*> at Berkeley, USA -*> -* ===================================================================== - SUBROUTINE DLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER I - DOUBLE PRECISION DSIGMA, RHO -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( 2 ), DELTA( 2 ), WORK( 2 ), Z( 2 ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, - $ THREE = 3.0D+0, FOUR = 4.0D+0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION B, C, DEL, DELSQ, TAU, W -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -* .. -* .. Executable Statements .. -* - DEL = D( 2 ) - D( 1 ) - DELSQ = DEL*( D( 2 )+D( 1 ) ) - IF( I.EQ.1 ) THEN - W = ONE + FOUR*RHO*( Z( 2 )*Z( 2 ) / ( D( 1 )+THREE*D( 2 ) )- - $ Z( 1 )*Z( 1 ) / ( THREE*D( 1 )+D( 2 ) ) ) / DEL - IF( W.GT.ZERO ) THEN - B = DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) - C = RHO*Z( 1 )*Z( 1 )*DELSQ -* -* B > ZERO, always -* -* The following TAU is DSIGMA * DSIGMA - D( 1 ) * D( 1 ) -* - TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) ) -* -* The following TAU is DSIGMA - D( 1 ) -* - TAU = TAU / ( D( 1 )+SQRT( D( 1 )*D( 1 )+TAU ) ) - DSIGMA = D( 1 ) + TAU - DELTA( 1 ) = -TAU - DELTA( 2 ) = DEL - TAU - WORK( 1 ) = TWO*D( 1 ) + TAU - WORK( 2 ) = ( D( 1 )+TAU ) + D( 2 ) -* DELTA( 1 ) = -Z( 1 ) / TAU -* DELTA( 2 ) = Z( 2 ) / ( DEL-TAU ) - ELSE - B = -DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) - C = RHO*Z( 2 )*Z( 2 )*DELSQ -* -* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) -* - IF( B.GT.ZERO ) THEN - TAU = -TWO*C / ( B+SQRT( B*B+FOUR*C ) ) - ELSE - TAU = ( B-SQRT( B*B+FOUR*C ) ) / TWO - END IF -* -* The following TAU is DSIGMA - D( 2 ) -* - TAU = TAU / ( D( 2 )+SQRT( ABS( D( 2 )*D( 2 )+TAU ) ) ) - DSIGMA = D( 2 ) + TAU - DELTA( 1 ) = -( DEL+TAU ) - DELTA( 2 ) = -TAU - WORK( 1 ) = D( 1 ) + TAU + D( 2 ) - WORK( 2 ) = TWO*D( 2 ) + TAU -* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) -* DELTA( 2 ) = -Z( 2 ) / TAU - END IF -* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) -* DELTA( 1 ) = DELTA( 1 ) / TEMP -* DELTA( 2 ) = DELTA( 2 ) / TEMP - ELSE -* -* Now I=2 -* - B = -DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) - C = RHO*Z( 2 )*Z( 2 )*DELSQ -* -* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) -* - IF( B.GT.ZERO ) THEN - TAU = ( B+SQRT( B*B+FOUR*C ) ) / TWO - ELSE - TAU = TWO*C / ( -B+SQRT( B*B+FOUR*C ) ) - END IF -* -* The following TAU is DSIGMA - D( 2 ) -* - TAU = TAU / ( D( 2 )+SQRT( D( 2 )*D( 2 )+TAU ) ) - DSIGMA = D( 2 ) + TAU - DELTA( 1 ) = -( DEL+TAU ) - DELTA( 2 ) = -TAU - WORK( 1 ) = D( 1 ) + TAU + D( 2 ) - WORK( 2 ) = TWO*D( 2 ) + TAU -* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) -* DELTA( 2 ) = -Z( 2 ) / TAU -* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) -* DELTA( 1 ) = DELTA( 1 ) / TEMP -* DELTA( 2 ) = DELTA( 2 ) / TEMP - END IF - RETURN -* -* End of DLASD5 -* - END diff --git a/lib/linalg/dlasd6.cpp b/lib/linalg/dlasd6.cpp new file mode 100644 index 0000000000..a631245cf5 --- /dev/null +++ b/lib/linalg/dlasd6.cpp @@ -0,0 +1,112 @@ +#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 dlasd6_(integer *icompq, integer *nl, integer *nr, integer *sqre, doublereal *d__, + doublereal *vf, doublereal *vl, doublereal *alpha, doublereal *beta, integer *idxq, + integer *perm, integer *givptr, integer *givcol, integer *ldgcol, doublereal *givnum, + integer *ldgnum, doublereal *poles, doublereal *difl, doublereal *difr, doublereal *z__, + integer *k, doublereal *c__, doublereal *s, doublereal *work, integer *iwork, + integer *info) +{ + integer givcol_dim1, givcol_offset, givnum_dim1, givnum_offset, poles_dim1, poles_offset, i__1; + doublereal d__1, d__2; + integer i__, m, n, n1, n2, iw, idx, idxc, idxp, ivfw, ivlw; + extern int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *), + dlasd7_(integer *, integer *, integer *, integer *, integer *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *), + dlasd8_(integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, 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; + --d__; + --vf; + --vl; + --idxq; + --perm; + givcol_dim1 = *ldgcol; + givcol_offset = 1 + givcol_dim1; + givcol -= givcol_offset; + poles_dim1 = *ldgnum; + poles_offset = 1 + poles_dim1; + poles -= poles_offset; + givnum_dim1 = *ldgnum; + givnum_offset = 1 + givnum_dim1; + givnum -= givnum_offset; + --difl; + --difr; + --z__; + --work; + --iwork; + *info = 0; + n = *nl + *nr + 1; + m = n + *sqre; + if (*icompq < 0 || *icompq > 1) { + *info = -1; + } else if (*nl < 1) { + *info = -2; + } else if (*nr < 1) { + *info = -3; + } else if (*sqre < 0 || *sqre > 1) { + *info = -4; + } else if (*ldgcol < n) { + *info = -14; + } else if (*ldgnum < n) { + *info = -16; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DLASD6", &i__1, (ftnlen)6); + return 0; + } + isigma = 1; + iw = isigma + n; + ivfw = iw + m; + ivlw = ivfw + m; + idx = 1; + idxc = idx + n; + idxp = idxc + 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; + dlasd7_(icompq, nl, nr, sqre, k, &d__[1], &z__[1], &work[iw], &vf[1], &work[ivfw], &vl[1], + &work[ivlw], alpha, beta, &work[isigma], &iwork[idx], &iwork[idxp], &idxq[1], &perm[1], + givptr, &givcol[givcol_offset], ldgcol, &givnum[givnum_offset], ldgnum, c__, s, info); + dlasd8_(icompq, k, &d__[1], &z__[1], &vf[1], &vl[1], &difl[1], &difr[1], ldgnum, &work[isigma], + &work[iw], info); + if (*info != 0) { + return 0; + } + if (*icompq == 1) { + dcopy_(k, &d__[1], &c__1, &poles[poles_dim1 + 1], &c__1); + dcopy_(k, &work[isigma], &c__1, &poles[(poles_dim1 << 1) + 1], &c__1); + } + 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 diff --git a/lib/linalg/dlasd6.f b/lib/linalg/dlasd6.f deleted file mode 100644 index 51e67588dd..0000000000 --- a/lib/linalg/dlasd6.f +++ /dev/null @@ -1,440 +0,0 @@ -*> \brief \b DLASD6 computes the SVD of an updated upper bidiagonal matrix obtained by merging two smaller ones by appending a row. Used by sbdsdc. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASD6 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLASD6( ICOMPQ, NL, NR, SQRE, D, VF, VL, ALPHA, BETA, -* IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, -* LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, -* IWORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, -* $ NR, SQRE -* DOUBLE PRECISION ALPHA, BETA, C, S -* .. -* .. Array Arguments .. -* INTEGER GIVCOL( LDGCOL, * ), IDXQ( * ), IWORK( * ), -* $ PERM( * ) -* DOUBLE PRECISION D( * ), DIFL( * ), DIFR( * ), -* $ GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ), -* $ VF( * ), VL( * ), WORK( * ), Z( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLASD6 computes the SVD of an updated upper bidiagonal matrix B -*> obtained by merging two smaller ones by appending a row. This -*> routine is used only for the problem which requires all singular -*> values and optionally singular vector matrices in factored form. -*> B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE. -*> A related subroutine, DLASD1, handles the case in which all singular -*> values and singular vectors of the bidiagonal matrix are desired. -*> -*> DLASD6 computes the SVD as follows: -*> -*> ( D1(in) 0 0 0 ) -*> B = U(in) * ( Z1**T a Z2**T b ) * VT(in) -*> ( 0 0 D2(in) 0 ) -*> -*> = U(out) * ( D(out) 0) * VT(out) -*> -*> where Z**T = (Z1**T a Z2**T b) = u**T VT**T, and u is a vector of dimension M -*> with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros -*> elsewhere; and the entry b is empty if SQRE = 0. -*> -*> The singular values of B can be computed using D1, D2, the first -*> components of all the right singular vectors of the lower block, and -*> the last components of all the right singular vectors of the upper -*> block. These components are stored and updated in VF and VL, -*> respectively, in DLASD6. Hence U and VT are not explicitly -*> referenced. -*> -*> The singular values are stored in D. The algorithm consists of two -*> stages: -*> -*> The first stage consists of deflating the size of the problem -*> when there are multiple singular values or if there is a zero -*> in the Z vector. For each such occurrence the dimension of the -*> secular equation problem is reduced by one. This stage is -*> performed by the routine DLASD7. -*> -*> The second stage consists of calculating the updated -*> singular values. This is done by finding the roots of the -*> secular equation via the routine DLASD4 (as called by DLASD8). -*> This routine also updates VF and VL and computes the distances -*> between the updated singular values and the old singular -*> values. -*> -*> DLASD6 is called from DLASDA. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] ICOMPQ -*> \verbatim -*> ICOMPQ is INTEGER -*> Specifies whether singular vectors are to be computed in -*> factored form: -*> = 0: Compute singular values only. -*> = 1: Compute singular vectors in factored form as well. -*> \endverbatim -*> -*> \param[in] NL -*> \verbatim -*> NL is INTEGER -*> The row dimension of the upper block. NL >= 1. -*> \endverbatim -*> -*> \param[in] NR -*> \verbatim -*> NR is INTEGER -*> The row dimension of the lower block. NR >= 1. -*> \endverbatim -*> -*> \param[in] SQRE -*> \verbatim -*> SQRE is INTEGER -*> = 0: the lower block is an NR-by-NR square matrix. -*> = 1: the lower block is an NR-by-(NR+1) rectangular matrix. -*> -*> The bidiagonal matrix has row dimension N = NL + NR + 1, -*> and column dimension M = N + SQRE. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension ( NL+NR+1 ). -*> On entry D(1:NL,1:NL) contains the singular values of the -*> upper block, and D(NL+2:N) contains the singular values -*> of the lower block. On exit D(1:N) contains the singular -*> values of the modified matrix. -*> \endverbatim -*> -*> \param[in,out] VF -*> \verbatim -*> VF is DOUBLE PRECISION array, dimension ( M ) -*> On entry, VF(1:NL+1) contains the first components of all -*> right singular vectors of the upper block; and VF(NL+2:M) -*> contains the first components of all right singular vectors -*> of the lower block. On exit, VF contains the first components -*> of all right singular vectors of the bidiagonal matrix. -*> \endverbatim -*> -*> \param[in,out] VL -*> \verbatim -*> VL is DOUBLE PRECISION array, dimension ( M ) -*> On entry, VL(1:NL+1) contains the last components of all -*> right singular vectors of the upper block; and VL(NL+2:M) -*> contains the last components of all right singular vectors of -*> the lower block. On exit, VL contains the last components of -*> all right singular vectors of the bidiagonal matrix. -*> \endverbatim -*> -*> \param[in,out] ALPHA -*> \verbatim -*> ALPHA is DOUBLE PRECISION -*> Contains the diagonal element associated with the added row. -*> \endverbatim -*> -*> \param[in,out] BETA -*> \verbatim -*> BETA is DOUBLE PRECISION -*> Contains the off-diagonal element associated with the added -*> row. -*> \endverbatim -*> -*> \param[in,out] IDXQ -*> \verbatim -*> IDXQ is INTEGER array, dimension ( N ) -*> This contains the permutation which will reintegrate the -*> subproblem just solved back into sorted order, i.e. -*> D( IDXQ( I = 1, N ) ) will be in ascending order. -*> \endverbatim -*> -*> \param[out] PERM -*> \verbatim -*> PERM is INTEGER array, dimension ( N ) -*> The permutations (from deflation and sorting) to be applied -*> to each block. Not referenced if ICOMPQ = 0. -*> \endverbatim -*> -*> \param[out] GIVPTR -*> \verbatim -*> GIVPTR is INTEGER -*> The number of Givens rotations which took place in this -*> subproblem. Not referenced if ICOMPQ = 0. -*> \endverbatim -*> -*> \param[out] GIVCOL -*> \verbatim -*> GIVCOL is INTEGER array, dimension ( LDGCOL, 2 ) -*> Each pair of numbers indicates a pair of columns to take place -*> in a Givens rotation. Not referenced if ICOMPQ = 0. -*> \endverbatim -*> -*> \param[in] LDGCOL -*> \verbatim -*> LDGCOL is INTEGER -*> leading dimension of GIVCOL, must be at least N. -*> \endverbatim -*> -*> \param[out] GIVNUM -*> \verbatim -*> GIVNUM is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) -*> Each number indicates the C or S value to be used in the -*> corresponding Givens rotation. Not referenced if ICOMPQ = 0. -*> \endverbatim -*> -*> \param[in] LDGNUM -*> \verbatim -*> LDGNUM is INTEGER -*> The leading dimension of GIVNUM and POLES, must be at least N. -*> \endverbatim -*> -*> \param[out] POLES -*> \verbatim -*> POLES is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) -*> On exit, POLES(1,*) is an array containing the new singular -*> values obtained from solving the secular equation, and -*> POLES(2,*) is an array containing the poles in the secular -*> equation. Not referenced if ICOMPQ = 0. -*> \endverbatim -*> -*> \param[out] DIFL -*> \verbatim -*> DIFL is DOUBLE PRECISION array, dimension ( N ) -*> On exit, DIFL(I) is the distance between I-th updated -*> (undeflated) singular value and the I-th (undeflated) old -*> singular value. -*> \endverbatim -*> -*> \param[out] DIFR -*> \verbatim -*> DIFR is DOUBLE PRECISION array, -*> dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and -*> dimension ( K ) if ICOMPQ = 0. -*> On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not -*> defined and will not be referenced. -*> -*> If ICOMPQ = 1, DIFR(1:K,2) is an array containing the -*> normalizing factors for the right singular vector matrix. -*> -*> See DLASD8 for details on DIFL and DIFR. -*> \endverbatim -*> -*> \param[out] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension ( M ) -*> The first elements of this array contain the components -*> of the deflation-adjusted updating row vector. -*> \endverbatim -*> -*> \param[out] K -*> \verbatim -*> K is INTEGER -*> Contains the dimension of the non-deflated matrix, -*> This is the order of the related secular equation. 1 <= K <=N. -*> \endverbatim -*> -*> \param[out] C -*> \verbatim -*> C is DOUBLE PRECISION -*> C contains garbage if SQRE =0 and the C-value of a Givens -*> rotation related to the right null space if SQRE = 1. -*> \endverbatim -*> -*> \param[out] S -*> \verbatim -*> S is DOUBLE PRECISION -*> S contains garbage if SQRE =0 and the S-value of a Givens -*> rotation related to the right null space if SQRE = 1. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension ( 4 * M ) -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, dimension ( 3 * N ) -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit. -*> < 0: if INFO = -i, the i-th argument had an illegal value. -*> > 0: if INFO = 1, a singular value did not converge -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -*> \par Contributors: -* ================== -*> -*> Ming Gu and Huan Ren, Computer Science Division, University of -*> California at Berkeley, USA -*> -* ===================================================================== - SUBROUTINE DLASD6( ICOMPQ, NL, NR, SQRE, D, VF, VL, ALPHA, BETA, - $ IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, - $ LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, - $ IWORK, INFO ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, - $ NR, SQRE - DOUBLE PRECISION ALPHA, BETA, C, S -* .. -* .. Array Arguments .. - INTEGER GIVCOL( LDGCOL, * ), IDXQ( * ), IWORK( * ), - $ PERM( * ) - DOUBLE PRECISION D( * ), DIFL( * ), DIFR( * ), - $ GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ), - $ VF( * ), VL( * ), WORK( * ), Z( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, IDX, IDXC, IDXP, ISIGMA, IVFW, IVLW, IW, M, - $ N, N1, N2 - DOUBLE PRECISION ORGNRM -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DLAMRG, DLASCL, DLASD7, DLASD8, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - N = NL + NR + 1 - M = N + SQRE -* - IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN - INFO = -1 - ELSE IF( NL.LT.1 ) THEN - INFO = -2 - ELSE IF( NR.LT.1 ) THEN - INFO = -3 - ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN - INFO = -4 - ELSE IF( LDGCOL.LT.N ) THEN - INFO = -14 - ELSE IF( LDGNUM.LT.N ) THEN - INFO = -16 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLASD6', -INFO ) - RETURN - END IF -* -* The following values are for bookkeeping purposes only. They are -* integer pointers which indicate the portion of the workspace -* used by a particular array in DLASD7 and DLASD8. -* - ISIGMA = 1 - IW = ISIGMA + N - IVFW = IW + M - IVLW = IVFW + M -* - IDX = 1 - IDXC = IDX + N - IDXP = IDXC + N -* -* Scale. -* - ORGNRM = MAX( ABS( ALPHA ), ABS( BETA ) ) - D( NL+1 ) = ZERO - DO 10 I = 1, N - IF( ABS( D( I ) ).GT.ORGNRM ) THEN - ORGNRM = ABS( D( I ) ) - END IF - 10 CONTINUE - CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO ) - ALPHA = ALPHA / ORGNRM - BETA = BETA / ORGNRM -* -* Sort and Deflate singular values. -* - CALL DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, WORK( IW ), VF, - $ WORK( IVFW ), VL, WORK( IVLW ), ALPHA, BETA, - $ WORK( ISIGMA ), IWORK( IDX ), IWORK( IDXP ), IDXQ, - $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, C, S, - $ INFO ) -* -* Solve Secular Equation, compute DIFL, DIFR, and update VF, VL. -* - CALL DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDGNUM, - $ WORK( ISIGMA ), WORK( IW ), INFO ) -* -* Report the possible convergence failure. -* - IF( INFO.NE.0 ) THEN - RETURN - END IF -* -* Save the poles if ICOMPQ = 1. -* - IF( ICOMPQ.EQ.1 ) THEN - CALL DCOPY( K, D, 1, POLES( 1, 1 ), 1 ) - CALL DCOPY( K, WORK( ISIGMA ), 1, POLES( 1, 2 ), 1 ) - END IF -* -* Unscale. -* - CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO ) -* -* Prepare the IDXQ sorting permutation. -* - N1 = K - N2 = N - K - CALL DLAMRG( N1, N2, D, 1, -1, IDXQ ) -* - RETURN -* -* End of DLASD6 -* - END diff --git a/lib/linalg/dlasd7.cpp b/lib/linalg/dlasd7.cpp new file mode 100644 index 0000000000..989771ca01 --- /dev/null +++ b/lib/linalg/dlasd7.cpp @@ -0,0 +1,236 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +int dlasd7_(integer *icompq, integer *nl, integer *nr, integer *sqre, integer *k, doublereal *d__, + doublereal *z__, doublereal *zw, doublereal *vf, doublereal *vfw, doublereal *vl, + doublereal *vlw, doublereal *alpha, doublereal *beta, doublereal *dsigma, integer *idx, + integer *idxp, integer *idxq, integer *perm, integer *givptr, integer *givcol, + integer *ldgcol, doublereal *givnum, integer *ldgnum, doublereal *c__, doublereal *s, + integer *info) +{ + integer givcol_dim1, givcol_offset, givnum_dim1, givnum_offset, i__1; + doublereal d__1, d__2; + integer i__, j, m, n, k2; + doublereal z1; + integer jp; + doublereal eps, tau, tol; + integer nlp1, nlp2, idxi, idxj; + extern int drot_(integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, + doublereal *); + integer 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 *), + xerbla_(char *, integer *, ftnlen); + doublereal hlftol; + --d__; + --z__; + --zw; + --vf; + --vfw; + --vl; + --vlw; + --dsigma; + --idx; + --idxp; + --idxq; + --perm; + givcol_dim1 = *ldgcol; + givcol_offset = 1 + givcol_dim1; + givcol -= givcol_offset; + givnum_dim1 = *ldgnum; + givnum_offset = 1 + givnum_dim1; + givnum -= givnum_offset; + *info = 0; + n = *nl + *nr + 1; + m = n + *sqre; + if (*icompq < 0 || *icompq > 1) { + *info = -1; + } else if (*nl < 1) { + *info = -2; + } else if (*nr < 1) { + *info = -3; + } else if (*sqre < 0 || *sqre > 1) { + *info = -4; + } else if (*ldgcol < n) { + *info = -22; + } else if (*ldgnum < n) { + *info = -24; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DLASD7", &i__1, (ftnlen)6); + return 0; + } + nlp1 = *nl + 1; + nlp2 = *nl + 2; + if (*icompq == 1) { + *givptr = 0; + } + z1 = *alpha * vl[nlp1]; + vl[nlp1] = 0.; + tau = vf[nlp1]; + for (i__ = *nl; i__ >= 1; --i__) { + z__[i__ + 1] = *alpha * vl[i__]; + vl[i__] = 0.; + vf[i__ + 1] = vf[i__]; + d__[i__ + 1] = d__[i__]; + idxq[i__ + 1] = idxq[i__] + 1; + } + vf[1] = tau; + i__1 = m; + for (i__ = nlp2; i__ <= i__1; ++i__) { + z__[i__] = *beta * vf[i__]; + vf[i__] = 0.; + } + 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__]]; + zw[i__] = z__[idxq[i__]]; + vfw[i__] = vf[idxq[i__]]; + vlw[i__] = vl[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__] = zw[idxi]; + vf[i__] = vfw[idxi]; + vl[i__] = vlw[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 * 64. * 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; + if (j == n) { + goto L100; + } + } else { + jprev = j; + goto L70; + } + } +L70: + j = jprev; +L80: + ++j; + if (j > n) { + goto L90; + } + if ((d__1 = z__[j], abs(d__1)) <= tol) { + --k2; + idxp[k2] = j; + } else { + if ((d__1 = d__[j] - d__[jprev], abs(d__1)) <= tol) { + *s = z__[jprev]; + *c__ = z__[j]; + tau = dlapy2_(c__, s); + z__[j] = tau; + z__[jprev] = 0.; + *c__ /= tau; + *s = -(*s) / tau; + if (*icompq == 1) { + ++(*givptr); + idxjp = idxq[idx[jprev] + 1]; + idxj = idxq[idx[j] + 1]; + if (idxjp <= nlp1) { + --idxjp; + } + if (idxj <= nlp1) { + --idxj; + } + givcol[*givptr + (givcol_dim1 << 1)] = idxjp; + givcol[*givptr + givcol_dim1] = idxj; + givnum[*givptr + (givnum_dim1 << 1)] = *c__; + givnum[*givptr + givnum_dim1] = *s; + } + drot_(&c__1, &vf[jprev], &c__1, &vf[j], &c__1, c__, s); + drot_(&c__1, &vl[jprev], &c__1, &vl[j], &c__1, c__, s); + --k2; + idxp[k2] = jprev; + jprev = j; + } else { + ++(*k); + zw[*k] = z__[jprev]; + dsigma[*k] = d__[jprev]; + idxp[*k] = jprev; + jprev = j; + } + } + goto L80; +L90: + ++(*k); + zw[*k] = z__[jprev]; + dsigma[*k] = d__[jprev]; + idxp[*k] = jprev; +L100: + i__1 = n; + for (j = 2; j <= i__1; ++j) { + jp = idxp[j]; + dsigma[j] = d__[jp]; + vfw[j] = vf[jp]; + vlw[j] = vl[jp]; + } + if (*icompq == 1) { + i__1 = n; + for (j = 2; j <= i__1; ++j) { + jp = idxp[j]; + perm[j] = idxq[idx[jp] + 1]; + if (perm[j] <= nlp1) { + --perm[j]; + } + } + } + i__1 = n - *k; + dcopy_(&i__1, &dsigma[*k + 1], &c__1, &d__[*k + 1], &c__1); + 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]; + } + drot_(&c__1, &vf[m], &c__1, &vf[1], &c__1, c__, s); + drot_(&c__1, &vl[m], &c__1, &vl[1], &c__1, c__, s); + } else { + if (abs(z1) <= tol) { + z__[1] = tol; + } else { + z__[1] = z1; + } + } + i__1 = *k - 1; + dcopy_(&i__1, &zw[2], &c__1, &z__[2], &c__1); + i__1 = n - 1; + dcopy_(&i__1, &vfw[2], &c__1, &vf[2], &c__1); + i__1 = n - 1; + dcopy_(&i__1, &vlw[2], &c__1, &vl[2], &c__1); + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlasd7.f b/lib/linalg/dlasd7.f deleted file mode 100644 index ff9ba4c36a..0000000000 --- a/lib/linalg/dlasd7.f +++ /dev/null @@ -1,577 +0,0 @@ -*> \brief \b DLASD7 merges the two sets of singular values together into a single sorted set. Then it tries to deflate the size of the problem. Used by sbdsdc. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASD7 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL, -* VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ, -* PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, -* C, S, INFO ) -* -* .. Scalar Arguments .. -* INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, -* $ NR, SQRE -* DOUBLE PRECISION ALPHA, BETA, C, S -* .. -* .. Array Arguments .. -* INTEGER GIVCOL( LDGCOL, * ), IDX( * ), IDXP( * ), -* $ IDXQ( * ), PERM( * ) -* DOUBLE PRECISION D( * ), DSIGMA( * ), GIVNUM( LDGNUM, * ), -* $ VF( * ), VFW( * ), VL( * ), VLW( * ), Z( * ), -* $ ZW( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLASD7 merges the two sets of singular values together into a single -*> sorted set. Then it tries to deflate the size of the problem. There -*> are two ways in which deflation can occur: when two or more singular -*> values are close together or if there is a tiny entry in the Z -*> vector. For each such occurrence the order of the related -*> secular equation problem is reduced by one. -*> -*> DLASD7 is called from DLASD6. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] ICOMPQ -*> \verbatim -*> ICOMPQ is INTEGER -*> Specifies whether singular vectors are to be computed -*> in compact form, as follows: -*> = 0: Compute singular values only. -*> = 1: Compute singular vectors of upper -*> bidiagonal matrix in compact form. -*> \endverbatim -*> -*> \param[in] NL -*> \verbatim -*> NL is INTEGER -*> The row dimension of the upper block. NL >= 1. -*> \endverbatim -*> -*> \param[in] NR -*> \verbatim -*> NR is INTEGER -*> The row dimension of the lower block. NR >= 1. -*> \endverbatim -*> -*> \param[in] SQRE -*> \verbatim -*> SQRE is INTEGER -*> = 0: the lower block is an NR-by-NR square matrix. -*> = 1: the lower block is an NR-by-(NR+1) rectangular matrix. -*> -*> The bidiagonal matrix has -*> N = NL + NR + 1 rows and -*> M = N + SQRE >= N columns. -*> \endverbatim -*> -*> \param[out] K -*> \verbatim -*> K is INTEGER -*> Contains the dimension of the non-deflated matrix, this is -*> the order of the related secular equation. 1 <= K <=N. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension ( N ) -*> On entry D contains the singular values of the two submatrices -*> to be combined. On exit D contains the trailing (N-K) updated -*> singular values (those which were deflated) sorted into -*> increasing order. -*> \endverbatim -*> -*> \param[out] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension ( M ) -*> On exit Z contains the updating row vector in the secular -*> equation. -*> \endverbatim -*> -*> \param[out] ZW -*> \verbatim -*> ZW is DOUBLE PRECISION array, dimension ( M ) -*> Workspace for Z. -*> \endverbatim -*> -*> \param[in,out] VF -*> \verbatim -*> VF is DOUBLE PRECISION array, dimension ( M ) -*> On entry, VF(1:NL+1) contains the first components of all -*> right singular vectors of the upper block; and VF(NL+2:M) -*> contains the first components of all right singular vectors -*> of the lower block. On exit, VF contains the first components -*> of all right singular vectors of the bidiagonal matrix. -*> \endverbatim -*> -*> \param[out] VFW -*> \verbatim -*> VFW is DOUBLE PRECISION array, dimension ( M ) -*> Workspace for VF. -*> \endverbatim -*> -*> \param[in,out] VL -*> \verbatim -*> VL is DOUBLE PRECISION array, dimension ( M ) -*> On entry, VL(1:NL+1) contains the last components of all -*> right singular vectors of the upper block; and VL(NL+2:M) -*> contains the last components of all right singular vectors -*> of the lower block. On exit, VL contains the last components -*> of all right singular vectors of the bidiagonal matrix. -*> \endverbatim -*> -*> \param[out] VLW -*> \verbatim -*> VLW is DOUBLE PRECISION array, dimension ( M ) -*> Workspace for VL. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is DOUBLE PRECISION -*> Contains the diagonal element associated with the added row. -*> \endverbatim -*> -*> \param[in] BETA -*> \verbatim -*> BETA is DOUBLE PRECISION -*> Contains the off-diagonal element associated with the added -*> row. -*> \endverbatim -*> -*> \param[out] DSIGMA -*> \verbatim -*> DSIGMA is DOUBLE PRECISION array, dimension ( N ) -*> Contains a copy of the diagonal elements (K-1 singular values -*> and one zero) in the secular equation. -*> \endverbatim -*> -*> \param[out] IDX -*> \verbatim -*> IDX is INTEGER array, dimension ( N ) -*> This will contain the permutation used to sort the contents of -*> D into ascending order. -*> \endverbatim -*> -*> \param[out] IDXP -*> \verbatim -*> IDXP is INTEGER array, dimension ( N ) -*> This will contain the permutation used to place deflated -*> values of D at the end of the array. On output IDXP(2:K) -*> points to the nondeflated D-values and IDXP(K+1:N) -*> points to the deflated singular values. -*> \endverbatim -*> -*> \param[in] IDXQ -*> \verbatim -*> IDXQ is INTEGER array, dimension ( N ) -*> This contains the permutation which separately sorts the two -*> sub-problems in D into ascending order. Note that entries in -*> the first half of this permutation must first be moved one -*> position backward; and entries in the second half -*> must first have NL+1 added to their values. -*> \endverbatim -*> -*> \param[out] PERM -*> \verbatim -*> PERM is INTEGER array, dimension ( N ) -*> The permutations (from deflation and sorting) to be applied -*> to each singular block. Not referenced if ICOMPQ = 0. -*> \endverbatim -*> -*> \param[out] GIVPTR -*> \verbatim -*> GIVPTR is INTEGER -*> The number of Givens rotations which took place in this -*> subproblem. Not referenced if ICOMPQ = 0. -*> \endverbatim -*> -*> \param[out] GIVCOL -*> \verbatim -*> GIVCOL is INTEGER array, dimension ( LDGCOL, 2 ) -*> Each pair of numbers indicates a pair of columns to take place -*> in a Givens rotation. Not referenced if ICOMPQ = 0. -*> \endverbatim -*> -*> \param[in] LDGCOL -*> \verbatim -*> LDGCOL is INTEGER -*> The leading dimension of GIVCOL, must be at least N. -*> \endverbatim -*> -*> \param[out] GIVNUM -*> \verbatim -*> GIVNUM is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) -*> Each number indicates the C or S value to be used in the -*> corresponding Givens rotation. Not referenced if ICOMPQ = 0. -*> \endverbatim -*> -*> \param[in] LDGNUM -*> \verbatim -*> LDGNUM is INTEGER -*> The leading dimension of GIVNUM, must be at least N. -*> \endverbatim -*> -*> \param[out] C -*> \verbatim -*> C is DOUBLE PRECISION -*> C contains garbage if SQRE =0 and the C-value of a Givens -*> rotation related to the right null space if SQRE = 1. -*> \endverbatim -*> -*> \param[out] S -*> \verbatim -*> S is DOUBLE PRECISION -*> S contains garbage if SQRE =0 and the S-value of a Givens -*> rotation related to the right null space if SQRE = 1. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit. -*> < 0: if INFO = -i, the i-th argument had an illegal value. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -*> \par Contributors: -* ================== -*> -*> Ming Gu and Huan Ren, Computer Science Division, University of -*> California at Berkeley, USA -*> -* ===================================================================== - SUBROUTINE DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL, - $ VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ, - $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, - $ C, S, INFO ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, - $ NR, SQRE - DOUBLE PRECISION ALPHA, BETA, C, S -* .. -* .. Array Arguments .. - INTEGER GIVCOL( LDGCOL, * ), IDX( * ), IDXP( * ), - $ IDXQ( * ), PERM( * ) - DOUBLE PRECISION D( * ), DSIGMA( * ), GIVNUM( LDGNUM, * ), - $ VF( * ), VFW( * ), VL( * ), VLW( * ), Z( * ), - $ ZW( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, EIGHT - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, - $ EIGHT = 8.0D+0 ) -* .. -* .. Local Scalars .. -* - INTEGER I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M, N, - $ NLP1, NLP2 - DOUBLE PRECISION EPS, HLFTOL, TAU, TOL, Z1 -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DLAMRG, DROT, XERBLA -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH, DLAPY2 - EXTERNAL DLAMCH, DLAPY2 -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - N = NL + NR + 1 - M = N + SQRE -* - IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN - INFO = -1 - ELSE IF( NL.LT.1 ) THEN - INFO = -2 - ELSE IF( NR.LT.1 ) THEN - INFO = -3 - ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN - INFO = -4 - ELSE IF( LDGCOL.LT.N ) THEN - INFO = -22 - ELSE IF( LDGNUM.LT.N ) THEN - INFO = -24 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLASD7', -INFO ) - RETURN - END IF -* - NLP1 = NL + 1 - NLP2 = NL + 2 - IF( ICOMPQ.EQ.1 ) THEN - GIVPTR = 0 - END IF -* -* Generate the first part of the vector Z and move the singular -* values in the first part of D one position backward. -* - Z1 = ALPHA*VL( NLP1 ) - VL( NLP1 ) = ZERO - TAU = VF( NLP1 ) - DO 10 I = NL, 1, -1 - Z( I+1 ) = ALPHA*VL( I ) - VL( I ) = ZERO - VF( I+1 ) = VF( I ) - D( I+1 ) = D( I ) - IDXQ( I+1 ) = IDXQ( I ) + 1 - 10 CONTINUE - VF( 1 ) = TAU -* -* Generate the second part of the vector Z. -* - DO 20 I = NLP2, M - Z( I ) = BETA*VF( I ) - VF( I ) = ZERO - 20 CONTINUE -* -* Sort the singular values into increasing order -* - DO 30 I = NLP2, N - IDXQ( I ) = IDXQ( I ) + NLP1 - 30 CONTINUE -* -* DSIGMA, IDXC, IDXC, and ZW are used as storage space. -* - DO 40 I = 2, N - DSIGMA( I ) = D( IDXQ( I ) ) - ZW( I ) = Z( IDXQ( I ) ) - VFW( I ) = VF( IDXQ( I ) ) - VLW( I ) = VL( IDXQ( I ) ) - 40 CONTINUE -* - CALL DLAMRG( NL, NR, DSIGMA( 2 ), 1, 1, IDX( 2 ) ) -* - DO 50 I = 2, N - IDXI = 1 + IDX( I ) - D( I ) = DSIGMA( IDXI ) - Z( I ) = ZW( IDXI ) - VF( I ) = VFW( IDXI ) - VL( I ) = VLW( IDXI ) - 50 CONTINUE -* -* Calculate the allowable deflation tolerance -* - EPS = DLAMCH( 'Epsilon' ) - TOL = MAX( ABS( ALPHA ), ABS( BETA ) ) - TOL = EIGHT*EIGHT*EPS*MAX( ABS( D( N ) ), TOL ) -* -* There are 2 kinds of deflation -- first a value in the z-vector -* is small, second two (or more) singular values are very close -* together (their difference is small). -* -* If the value in the z-vector is small, we simply permute the -* array so that the corresponding singular value is moved to the -* end. -* -* If two values in the D-vector are close, we perform a two-sided -* rotation designed to make one of the corresponding z-vector -* entries zero, and then permute the array so that the deflated -* singular value is moved to the end. -* -* If there are multiple singular values then the problem deflates. -* Here the number of equal singular values are found. As each equal -* singular value is found, an elementary reflector is computed to -* rotate the corresponding singular subspace so that the -* corresponding components of Z are zero in this new basis. -* - K = 1 - K2 = N + 1 - DO 60 J = 2, N - IF( ABS( Z( J ) ).LE.TOL ) THEN -* -* Deflate due to small z component. -* - K2 = K2 - 1 - IDXP( K2 ) = J - IF( J.EQ.N ) - $ GO TO 100 - ELSE - JPREV = J - GO TO 70 - END IF - 60 CONTINUE - 70 CONTINUE - J = JPREV - 80 CONTINUE - J = J + 1 - IF( J.GT.N ) - $ GO TO 90 - IF( ABS( Z( J ) ).LE.TOL ) THEN -* -* Deflate due to small z component. -* - K2 = K2 - 1 - IDXP( K2 ) = J - ELSE -* -* Check if singular values are close enough to allow deflation. -* - IF( ABS( D( J )-D( JPREV ) ).LE.TOL ) THEN -* -* Deflation is possible. -* - S = Z( JPREV ) - C = Z( J ) -* -* Find sqrt(a**2+b**2) without overflow or -* destructive underflow. -* - TAU = DLAPY2( C, S ) - Z( J ) = TAU - Z( JPREV ) = ZERO - C = C / TAU - S = -S / TAU -* -* Record the appropriate Givens rotation -* - IF( ICOMPQ.EQ.1 ) THEN - GIVPTR = GIVPTR + 1 - IDXJP = IDXQ( IDX( JPREV )+1 ) - IDXJ = IDXQ( IDX( J )+1 ) - IF( IDXJP.LE.NLP1 ) THEN - IDXJP = IDXJP - 1 - END IF - IF( IDXJ.LE.NLP1 ) THEN - IDXJ = IDXJ - 1 - END IF - GIVCOL( GIVPTR, 2 ) = IDXJP - GIVCOL( GIVPTR, 1 ) = IDXJ - GIVNUM( GIVPTR, 2 ) = C - GIVNUM( GIVPTR, 1 ) = S - END IF - CALL DROT( 1, VF( JPREV ), 1, VF( J ), 1, C, S ) - CALL DROT( 1, VL( JPREV ), 1, VL( J ), 1, C, S ) - K2 = K2 - 1 - IDXP( K2 ) = JPREV - JPREV = J - ELSE - K = K + 1 - ZW( K ) = Z( JPREV ) - DSIGMA( K ) = D( JPREV ) - IDXP( K ) = JPREV - JPREV = J - END IF - END IF - GO TO 80 - 90 CONTINUE -* -* Record the last singular value. -* - K = K + 1 - ZW( K ) = Z( JPREV ) - DSIGMA( K ) = D( JPREV ) - IDXP( K ) = JPREV -* - 100 CONTINUE -* -* Sort the singular values into DSIGMA. The singular values which -* were not deflated go into the first K slots of DSIGMA, except -* that DSIGMA(1) is treated separately. -* - DO 110 J = 2, N - JP = IDXP( J ) - DSIGMA( J ) = D( JP ) - VFW( J ) = VF( JP ) - VLW( J ) = VL( JP ) - 110 CONTINUE - IF( ICOMPQ.EQ.1 ) THEN - DO 120 J = 2, N - JP = IDXP( J ) - PERM( J ) = IDXQ( IDX( JP )+1 ) - IF( PERM( J ).LE.NLP1 ) THEN - PERM( J ) = PERM( J ) - 1 - END IF - 120 CONTINUE - END IF -* -* The deflated singular values go back into the last N - K slots of -* D. -* - CALL DCOPY( N-K, DSIGMA( K+1 ), 1, D( K+1 ), 1 ) -* -* Determine DSIGMA(1), DSIGMA(2), Z(1), VF(1), VL(1), VF(M), and -* VL(M). -* - DSIGMA( 1 ) = ZERO - HLFTOL = TOL / TWO - IF( ABS( DSIGMA( 2 ) ).LE.HLFTOL ) - $ DSIGMA( 2 ) = HLFTOL - IF( M.GT.N ) THEN - Z( 1 ) = DLAPY2( Z1, Z( M ) ) - IF( Z( 1 ).LE.TOL ) THEN - C = ONE - S = ZERO - Z( 1 ) = TOL - ELSE - C = Z1 / Z( 1 ) - S = -Z( M ) / Z( 1 ) - END IF - CALL DROT( 1, VF( M ), 1, VF( 1 ), 1, C, S ) - CALL DROT( 1, VL( M ), 1, VL( 1 ), 1, C, S ) - ELSE - IF( ABS( Z1 ).LE.TOL ) THEN - Z( 1 ) = TOL - ELSE - Z( 1 ) = Z1 - END IF - END IF -* -* Restore Z, VF, and VL. -* - CALL DCOPY( K-1, ZW( 2 ), 1, Z( 2 ), 1 ) - CALL DCOPY( N-1, VFW( 2 ), 1, VF( 2 ), 1 ) - CALL DCOPY( N-1, VLW( 2 ), 1, VL( 2 ), 1 ) -* - RETURN -* -* End of DLASD7 -* - END diff --git a/lib/linalg/dlasd8.cpp b/lib/linalg/dlasd8.cpp new file mode 100644 index 0000000000..ba92932435 --- /dev/null +++ b/lib/linalg/dlasd8.cpp @@ -0,0 +1,134 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +static integer c__0 = 0; +static doublereal c_b8 = 1.; +int dlasd8_(integer *icompq, integer *k, doublereal *d__, doublereal *z__, doublereal *vf, + doublereal *vl, doublereal *difl, doublereal *difr, integer *lddifr, doublereal *dsigma, + doublereal *work, integer *info) +{ + integer difr_dim1, difr_offset, i__1, i__2; + doublereal d__1, d__2; + double sqrt(doublereal), d_lmp_sign(doublereal *, doublereal *); + integer i__, j; + doublereal dj, rho; + integer iwk1, iwk2, iwk3; + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *); + doublereal temp; + extern doublereal dnrm2_(integer *, doublereal *, integer *); + integer iwk2i, iwk3i; + doublereal diflj, difrj, dsigj; + extern int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *); + 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), + dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, + ftnlen), + xerbla_(char *, integer *, ftnlen); + doublereal dsigjp; + --d__; + --z__; + --vf; + --vl; + --difl; + difr_dim1 = *lddifr; + difr_offset = 1 + difr_dim1; + difr -= difr_offset; + --dsigma; + --work; + *info = 0; + if (*icompq < 0 || *icompq > 1) { + *info = -1; + } else if (*k < 1) { + *info = -2; + } else if (*lddifr < *k) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DLASD8", &i__1, (ftnlen)6); + return 0; + } + if (*k == 1) { + d__[1] = abs(z__[1]); + difl[1] = d__[1]; + if (*icompq == 1) { + difl[2] = 1.; + difr[(difr_dim1 << 1) + 1] = 1.; + } + return 0; + } + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + dsigma[i__] = dlamc3_(&dsigma[i__], &dsigma[i__]) - dsigma[i__]; + } + iwk1 = 1; + iwk2 = iwk1 + *k; + iwk3 = iwk2 + *k; + iwk2i = iwk2 - 1; + iwk3i = iwk3 - 1; + rho = dnrm2_(k, &z__[1], &c__1); + dlascl_((char *)"G", &c__0, &c__0, &rho, &c_b8, k, &c__1, &z__[1], k, info, (ftnlen)1); + rho *= rho; + dlaset_((char *)"A", k, &c__1, &c_b8, &c_b8, &work[iwk3], k, (ftnlen)1); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dlasd4_(k, &j, &dsigma[1], &z__[1], &work[iwk1], &rho, &d__[j], &work[iwk2], info); + if (*info != 0) { + return 0; + } + work[iwk3i + j] = work[iwk3i + j] * work[j] * work[iwk2i + j]; + difl[j] = -work[j]; + difr[j + difr_dim1] = -work[j + 1]; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i + i__] / + (dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[j]); + } + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i + i__] / + (dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[j]); + } + } + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + d__2 = sqrt((d__1 = work[iwk3i + i__], abs(d__1))); + z__[i__] = d_lmp_sign(&d__2, &z__[i__]); + } + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + diflj = difl[j]; + dj = d__[j]; + dsigj = -dsigma[j]; + if (j < *k) { + difrj = -difr[j + difr_dim1]; + dsigjp = -dsigma[j + 1]; + } + work[j] = -z__[j] / diflj / (dsigma[j] + dj); + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] = z__[i__] / (dlamc3_(&dsigma[i__], &dsigj) - diflj) / (dsigma[i__] + dj); + } + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + work[i__] = z__[i__] / (dlamc3_(&dsigma[i__], &dsigjp) + difrj) / (dsigma[i__] + dj); + } + temp = dnrm2_(k, &work[1], &c__1); + work[iwk2i + j] = ddot_(k, &work[1], &c__1, &vf[1], &c__1) / temp; + work[iwk3i + j] = ddot_(k, &work[1], &c__1, &vl[1], &c__1) / temp; + if (*icompq == 1) { + difr[j + (difr_dim1 << 1)] = temp; + } + } + dcopy_(k, &work[iwk2], &c__1, &vf[1], &c__1); + dcopy_(k, &work[iwk3], &c__1, &vl[1], &c__1); + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlasd8.f b/lib/linalg/dlasd8.f deleted file mode 100644 index a769bdb22e..0000000000 --- a/lib/linalg/dlasd8.f +++ /dev/null @@ -1,339 +0,0 @@ -*> \brief \b DLASD8 finds the square roots of the roots of the secular equation, and stores, for each element in D, the distance to its two nearest poles. Used by sbdsdc. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASD8 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR, -* DSIGMA, WORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER ICOMPQ, INFO, K, LDDIFR -* .. -* .. Array Arguments .. -* DOUBLE PRECISION D( * ), DIFL( * ), DIFR( LDDIFR, * ), -* $ DSIGMA( * ), VF( * ), VL( * ), WORK( * ), -* $ Z( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLASD8 finds the square roots of the roots of the secular equation, -*> as defined by the values in DSIGMA and Z. It makes the appropriate -*> calls to DLASD4, and stores, for each element in D, the distance -*> to its two nearest poles (elements in DSIGMA). It also updates -*> the arrays VF and VL, the first and last components of all the -*> right singular vectors of the original bidiagonal matrix. -*> -*> DLASD8 is called from DLASD6. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] ICOMPQ -*> \verbatim -*> ICOMPQ is INTEGER -*> Specifies whether singular vectors are to be computed in -*> factored form in the calling routine: -*> = 0: Compute singular values only. -*> = 1: Compute singular vectors in factored form as well. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of terms in the rational function to be solved -*> by DLASD4. K >= 1. -*> \endverbatim -*> -*> \param[out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension ( K ) -*> On output, D contains the updated singular values. -*> \endverbatim -*> -*> \param[in,out] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension ( K ) -*> On entry, the first K elements of this array contain the -*> components of the deflation-adjusted updating row vector. -*> On exit, Z is updated. -*> \endverbatim -*> -*> \param[in,out] VF -*> \verbatim -*> VF is DOUBLE PRECISION array, dimension ( K ) -*> On entry, VF contains information passed through DBEDE8. -*> On exit, VF contains the first K components of the first -*> components of all right singular vectors of the bidiagonal -*> matrix. -*> \endverbatim -*> -*> \param[in,out] VL -*> \verbatim -*> VL is DOUBLE PRECISION array, dimension ( K ) -*> On entry, VL contains information passed through DBEDE8. -*> On exit, VL contains the first K components of the last -*> components of all right singular vectors of the bidiagonal -*> matrix. -*> \endverbatim -*> -*> \param[out] DIFL -*> \verbatim -*> DIFL is DOUBLE PRECISION array, dimension ( K ) -*> On exit, DIFL(I) = D(I) - DSIGMA(I). -*> \endverbatim -*> -*> \param[out] DIFR -*> \verbatim -*> DIFR is DOUBLE PRECISION array, -*> dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and -*> dimension ( K ) if ICOMPQ = 0. -*> On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not -*> defined and will not be referenced. -*> -*> If ICOMPQ = 1, DIFR(1:K,2) is an array containing the -*> normalizing factors for the right singular vector matrix. -*> \endverbatim -*> -*> \param[in] LDDIFR -*> \verbatim -*> LDDIFR is INTEGER -*> The leading dimension of DIFR, must be at least K. -*> \endverbatim -*> -*> \param[in,out] DSIGMA -*> \verbatim -*> DSIGMA is DOUBLE PRECISION array, dimension ( K ) -*> On entry, the first K elements of this array contain the old -*> roots of the deflated updating problem. These are the poles -*> of the secular equation. -*> On exit, the elements of DSIGMA may be very slightly altered -*> in value. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (3*K) -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit. -*> < 0: if INFO = -i, the i-th argument had an illegal value. -*> > 0: if INFO = 1, a singular value did not converge -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -*> \par Contributors: -* ================== -*> -*> Ming Gu and Huan Ren, Computer Science Division, University of -*> California at Berkeley, USA -*> -* ===================================================================== - SUBROUTINE DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR, - $ DSIGMA, WORK, INFO ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER ICOMPQ, INFO, K, LDDIFR -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), DIFL( * ), DIFR( LDDIFR, * ), - $ DSIGMA( * ), VF( * ), VL( * ), WORK( * ), - $ Z( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, IWK1, IWK2, IWK2I, IWK3, IWK3I, J - DOUBLE PRECISION DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, RHO, TEMP -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DLASCL, DLASD4, DLASET, XERBLA -* .. -* .. External Functions .. - DOUBLE PRECISION DDOT, DLAMC3, DNRM2 - EXTERNAL DDOT, DLAMC3, DNRM2 -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SIGN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN - INFO = -1 - ELSE IF( K.LT.1 ) THEN - INFO = -2 - ELSE IF( LDDIFR.LT.K ) THEN - INFO = -9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLASD8', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( K.EQ.1 ) THEN - D( 1 ) = ABS( Z( 1 ) ) - DIFL( 1 ) = D( 1 ) - IF( ICOMPQ.EQ.1 ) THEN - DIFL( 2 ) = ONE - DIFR( 1, 2 ) = ONE - END IF - RETURN - END IF -* -* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can -* be computed with high relative accuracy (barring over/underflow). -* This is a problem on machines without a guard digit in -* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). -* The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I), -* which on any of these machines zeros out the bottommost -* bit of DSIGMA(I) if it is 1; this makes the subsequent -* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation -* occurs. On binary machines with a guard digit (almost all -* machines) it does not change DSIGMA(I) at all. On hexadecimal -* and decimal machines with a guard digit, it slightly -* changes the bottommost bits of DSIGMA(I). It does not account -* for hexadecimal or decimal machines without guard digits -* (we know of none). We use a subroutine call to compute -* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating -* this code. -* - DO 10 I = 1, K - DSIGMA( I ) = DLAMC3( DSIGMA( I ), DSIGMA( I ) ) - DSIGMA( I ) - 10 CONTINUE -* -* Book keeping. -* - IWK1 = 1 - IWK2 = IWK1 + K - IWK3 = IWK2 + K - IWK2I = IWK2 - 1 - IWK3I = IWK3 - 1 -* -* Normalize Z. -* - RHO = DNRM2( K, Z, 1 ) - CALL DLASCL( 'G', 0, 0, RHO, ONE, K, 1, Z, K, INFO ) - RHO = RHO*RHO -* -* Initialize WORK(IWK3). -* - CALL DLASET( 'A', K, 1, ONE, ONE, WORK( IWK3 ), K ) -* -* Compute the updated singular values, the arrays DIFL, DIFR, -* and the updated Z. -* - DO 40 J = 1, K - CALL DLASD4( K, J, DSIGMA, Z, WORK( IWK1 ), RHO, D( J ), - $ WORK( IWK2 ), INFO ) -* -* If the root finder fails, report the convergence failure. -* - IF( INFO.NE.0 ) THEN - RETURN - END IF - WORK( IWK3I+J ) = WORK( IWK3I+J )*WORK( J )*WORK( IWK2I+J ) - DIFL( J ) = -WORK( J ) - DIFR( J, 1 ) = -WORK( J+1 ) - DO 20 I = 1, J - 1 - WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )* - $ WORK( IWK2I+I ) / ( DSIGMA( I )- - $ DSIGMA( J ) ) / ( DSIGMA( I )+ - $ DSIGMA( J ) ) - 20 CONTINUE - DO 30 I = J + 1, K - WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )* - $ WORK( IWK2I+I ) / ( DSIGMA( I )- - $ DSIGMA( J ) ) / ( DSIGMA( I )+ - $ DSIGMA( J ) ) - 30 CONTINUE - 40 CONTINUE -* -* Compute updated Z. -* - DO 50 I = 1, K - Z( I ) = SIGN( SQRT( ABS( WORK( IWK3I+I ) ) ), Z( I ) ) - 50 CONTINUE -* -* Update VF and VL. -* - DO 80 J = 1, K - DIFLJ = DIFL( J ) - DJ = D( J ) - DSIGJ = -DSIGMA( J ) - IF( J.LT.K ) THEN - DIFRJ = -DIFR( J, 1 ) - DSIGJP = -DSIGMA( J+1 ) - END IF - WORK( J ) = -Z( J ) / DIFLJ / ( DSIGMA( J )+DJ ) - DO 60 I = 1, J - 1 - WORK( I ) = Z( I ) / ( DLAMC3( DSIGMA( I ), DSIGJ )-DIFLJ ) - $ / ( DSIGMA( I )+DJ ) - 60 CONTINUE - DO 70 I = J + 1, K - WORK( I ) = Z( I ) / ( DLAMC3( DSIGMA( I ), DSIGJP )+DIFRJ ) - $ / ( DSIGMA( I )+DJ ) - 70 CONTINUE - TEMP = DNRM2( K, WORK, 1 ) - WORK( IWK2I+J ) = DDOT( K, WORK, 1, VF, 1 ) / TEMP - WORK( IWK3I+J ) = DDOT( K, WORK, 1, VL, 1 ) / TEMP - IF( ICOMPQ.EQ.1 ) THEN - DIFR( J, 2 ) = TEMP - END IF - 80 CONTINUE -* - CALL DCOPY( K, WORK( IWK2 ), 1, VF, 1 ) - CALL DCOPY( K, WORK( IWK3 ), 1, VL, 1 ) -* - RETURN -* -* End of DLASD8 -* - END - diff --git a/lib/linalg/dlasda.cpp b/lib/linalg/dlasda.cpp new file mode 100644 index 0000000000..47f76ed32d --- /dev/null +++ b/lib/linalg/dlasda.cpp @@ -0,0 +1,242 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__0 = 0; +static doublereal c_b11 = 0.; +static doublereal c_b12 = 1.; +static integer c__1 = 1; +static integer c__2 = 2; +int dlasda_(integer *icompq, integer *smlsiz, integer *n, integer *sqre, doublereal *d__, + doublereal *e, doublereal *u, integer *ldu, doublereal *vt, integer *k, + doublereal *difl, doublereal *difr, doublereal *z__, doublereal *poles, integer *givptr, + integer *givcol, integer *ldgcol, integer *perm, doublereal *givnum, doublereal *c__, + doublereal *s, doublereal *work, integer *iwork, integer *info) +{ + integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, difl_dim1, difl_offset, difr_dim1, + difr_offset, givnum_dim1, givnum_offset, poles_dim1, poles_offset, u_dim1, u_offset, + vt_dim1, vt_offset, z_dim1, z_offset, i__1, i__2; + integer pow_lmp_ii(integer *, integer *); + integer i__, j, m, i1, ic, lf, nd, ll, nl, vf, nr, vl, im1, ncc, nlf, nrf, vfi, iwk, vli, lvl, + nru, ndb1, nlp1, lvl2, nrp1; + doublereal beta; + integer idxq, nlvl; + doublereal alpha; + integer inode, ndiml, ndimr, idxqi, itemp; + extern int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *); + integer sqrei; + extern int dlasd6_(integer *, integer *, integer *, integer *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, integer *, integer *, integer *, + integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, doublereal *, + doublereal *, integer *, integer *); + integer nwork1, nwork2; + extern int 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 *), + dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, + ftnlen), + xerbla_(char *, integer *, ftnlen); + integer smlszp; + --d__; + --e; + givnum_dim1 = *ldu; + givnum_offset = 1 + givnum_dim1; + givnum -= givnum_offset; + poles_dim1 = *ldu; + poles_offset = 1 + poles_dim1; + poles -= poles_offset; + z_dim1 = *ldu; + z_offset = 1 + z_dim1; + z__ -= z_offset; + difr_dim1 = *ldu; + difr_offset = 1 + difr_dim1; + difr -= difr_offset; + difl_dim1 = *ldu; + difl_offset = 1 + difl_dim1; + difl -= difl_offset; + vt_dim1 = *ldu; + vt_offset = 1 + vt_dim1; + vt -= vt_offset; + u_dim1 = *ldu; + u_offset = 1 + u_dim1; + u -= u_offset; + --k; + --givptr; + perm_dim1 = *ldgcol; + perm_offset = 1 + perm_dim1; + perm -= perm_offset; + givcol_dim1 = *ldgcol; + givcol_offset = 1 + givcol_dim1; + givcol -= givcol_offset; + --c__; + --s; + --work; + --iwork; + *info = 0; + if (*icompq < 0 || *icompq > 1) { + *info = -1; + } else if (*smlsiz < 3) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*sqre < 0 || *sqre > 1) { + *info = -4; + } else if (*ldu < *n + *sqre) { + *info = -8; + } else if (*ldgcol < *n) { + *info = -17; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DLASDA", &i__1, (ftnlen)6); + return 0; + } + m = *n + *sqre; + if (*n <= *smlsiz) { + if (*icompq == 0) { + dlasdq_((char *)"U", sqre, n, &c__0, &c__0, &c__0, &d__[1], &e[1], &vt[vt_offset], ldu, + &u[u_offset], ldu, &u[u_offset], ldu, &work[1], info, (ftnlen)1); + } else { + dlasdq_((char *)"U", sqre, n, &m, n, &c__0, &d__[1], &e[1], &vt[vt_offset], ldu, &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; + ncc = 0; + nru = 0; + smlszp = *smlsiz + 1; + vf = 1; + vl = vf + m; + nwork1 = vl + m; + nwork2 = nwork1 + smlszp * smlszp; + dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr], smlsiz); + ndb1 = (nd + 1) / 2; + 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]; + nlf = ic - nl; + nrf = ic + 1; + idxqi = idxq + nlf - 2; + vfi = vf + nlf - 1; + vli = vl + nlf - 1; + sqrei = 1; + if (*icompq == 0) { + dlaset_((char *)"A", &nlp1, &nlp1, &c_b11, &c_b12, &work[nwork1], &smlszp, (ftnlen)1); + dlasdq_((char *)"U", &sqrei, &nl, &nlp1, &nru, &ncc, &d__[nlf], &e[nlf], &work[nwork1], &smlszp, + &work[nwork2], &nl, &work[nwork2], &nl, &work[nwork2], info, (ftnlen)1); + itemp = nwork1 + nl * smlszp; + dcopy_(&nlp1, &work[nwork1], &c__1, &work[vfi], &c__1); + dcopy_(&nlp1, &work[itemp], &c__1, &work[vli], &c__1); + } else { + dlaset_((char *)"A", &nl, &nl, &c_b11, &c_b12, &u[nlf + u_dim1], ldu, (ftnlen)1); + dlaset_((char *)"A", &nlp1, &nlp1, &c_b11, &c_b12, &vt[nlf + vt_dim1], ldu, (ftnlen)1); + dlasdq_((char *)"U", &sqrei, &nl, &nlp1, &nl, &ncc, &d__[nlf], &e[nlf], &vt[nlf + vt_dim1], ldu, + &u[nlf + u_dim1], ldu, &u[nlf + u_dim1], ldu, &work[nwork1], info, (ftnlen)1); + dcopy_(&nlp1, &vt[nlf + vt_dim1], &c__1, &work[vfi], &c__1); + dcopy_(&nlp1, &vt[nlf + nlp1 * vt_dim1], &c__1, &work[vli], &c__1); + } + if (*info != 0) { + return 0; + } + i__2 = nl; + for (j = 1; j <= i__2; ++j) { + iwork[idxqi + j] = j; + } + if (i__ == nd && *sqre == 0) { + sqrei = 0; + } else { + sqrei = 1; + } + idxqi += nlp1; + vfi += nlp1; + vli += nlp1; + nrp1 = nr + sqrei; + if (*icompq == 0) { + dlaset_((char *)"A", &nrp1, &nrp1, &c_b11, &c_b12, &work[nwork1], &smlszp, (ftnlen)1); + dlasdq_((char *)"U", &sqrei, &nr, &nrp1, &nru, &ncc, &d__[nrf], &e[nrf], &work[nwork1], &smlszp, + &work[nwork2], &nr, &work[nwork2], &nr, &work[nwork2], info, (ftnlen)1); + itemp = nwork1 + (nrp1 - 1) * smlszp; + dcopy_(&nrp1, &work[nwork1], &c__1, &work[vfi], &c__1); + dcopy_(&nrp1, &work[itemp], &c__1, &work[vli], &c__1); + } else { + dlaset_((char *)"A", &nr, &nr, &c_b11, &c_b12, &u[nrf + u_dim1], ldu, (ftnlen)1); + dlaset_((char *)"A", &nrp1, &nrp1, &c_b11, &c_b12, &vt[nrf + vt_dim1], ldu, (ftnlen)1); + dlasdq_((char *)"U", &sqrei, &nr, &nrp1, &nr, &ncc, &d__[nrf], &e[nrf], &vt[nrf + vt_dim1], ldu, + &u[nrf + u_dim1], ldu, &u[nrf + u_dim1], ldu, &work[nwork1], info, (ftnlen)1); + dcopy_(&nrp1, &vt[nrf + vt_dim1], &c__1, &work[vfi], &c__1); + dcopy_(&nrp1, &vt[nrf + nrp1 * vt_dim1], &c__1, &work[vli], &c__1); + } + if (*info != 0) { + return 0; + } + i__2 = nr; + for (j = 1; j <= i__2; ++j) { + iwork[idxqi + j] = j; + } + } + j = pow_lmp_ii(&c__2, &nlvl); + for (lvl = nlvl; lvl >= 1; --lvl) { + lvl2 = (lvl << 1) - 1; + 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; + nrf = ic + 1; + if (i__ == ll) { + sqrei = *sqre; + } else { + sqrei = 1; + } + vfi = vf + nlf - 1; + vli = vl + nlf - 1; + idxqi = idxq + nlf - 1; + alpha = d__[ic]; + beta = e[ic]; + if (*icompq == 0) { + dlasd6_(icompq, &nl, &nr, &sqrei, &d__[nlf], &work[vfi], &work[vli], &alpha, &beta, + &iwork[idxqi], &perm[perm_offset], &givptr[1], &givcol[givcol_offset], + ldgcol, &givnum[givnum_offset], ldu, &poles[poles_offset], + &difl[difl_offset], &difr[difr_offset], &z__[z_offset], &k[1], &c__[1], + &s[1], &work[nwork1], &iwork[iwk], info); + } else { + --j; + dlasd6_(icompq, &nl, &nr, &sqrei, &d__[nlf], &work[vfi], &work[vli], &alpha, &beta, + &iwork[idxqi], &perm[nlf + lvl * perm_dim1], &givptr[j], + &givcol[nlf + lvl2 * givcol_dim1], ldgcol, + &givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 * poles_dim1], + &difl[nlf + lvl * difl_dim1], &difr[nlf + lvl2 * difr_dim1], + &z__[nlf + lvl * z_dim1], &k[j], &c__[j], &s[j], &work[nwork1], &iwork[iwk], + info); + } + if (*info != 0) { + return 0; + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlasda.f b/lib/linalg/dlasda.f deleted file mode 100644 index 3e169a4edb..0000000000 --- a/lib/linalg/dlasda.f +++ /dev/null @@ -1,511 +0,0 @@ -*> \brief \b DLASDA computes the singular value decomposition (SVD) of a real upper bidiagonal matrix with diagonal d and off-diagonal e. Used by sbdsdc. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASDA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K, -* DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, -* PERM, GIVNUM, C, S, WORK, IWORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER ICOMPQ, INFO, LDGCOL, LDU, N, SMLSIZ, SQRE -* .. -* .. Array Arguments .. -* INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ), -* $ K( * ), PERM( LDGCOL, * ) -* DOUBLE PRECISION C( * ), D( * ), DIFL( LDU, * ), DIFR( LDU, * ), -* $ E( * ), GIVNUM( LDU, * ), POLES( LDU, * ), -* $ S( * ), U( LDU, * ), VT( LDU, * ), WORK( * ), -* $ Z( LDU, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> Using a divide and conquer approach, DLASDA computes the singular -*> value decomposition (SVD) of a real upper bidiagonal N-by-M matrix -*> B with diagonal D and offdiagonal E, where M = N + SQRE. The -*> algorithm computes the singular values in the SVD B = U * S * VT. -*> The orthogonal matrices U and VT are optionally computed in -*> compact form. -*> -*> A related subroutine, DLASD0, computes the singular values and -*> the singular vectors in explicit form. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] ICOMPQ -*> \verbatim -*> ICOMPQ is INTEGER -*> Specifies whether singular vectors are to be computed -*> in compact form, as follows -*> = 0: Compute singular values only. -*> = 1: Compute singular vectors of upper bidiagonal -*> matrix in compact form. -*> \endverbatim -*> -*> \param[in] SMLSIZ -*> \verbatim -*> SMLSIZ is INTEGER -*> The maximum size of the subproblems at the bottom of the -*> computation tree. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The row dimension of the upper bidiagonal matrix. This is -*> also the dimension of the main diagonal array D. -*> \endverbatim -*> -*> \param[in] SQRE -*> \verbatim -*> SQRE is INTEGER -*> Specifies the column dimension of the bidiagonal matrix. -*> = 0: The bidiagonal matrix has column dimension M = N; -*> = 1: The bidiagonal matrix has column dimension M = N + 1. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension ( N ) -*> On entry D contains the main diagonal of the bidiagonal -*> matrix. On exit D, if INFO = 0, contains its singular values. -*> \endverbatim -*> -*> \param[in] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension ( M-1 ) -*> Contains the subdiagonal entries of the bidiagonal matrix. -*> On exit, E has been destroyed. -*> \endverbatim -*> -*> \param[out] U -*> \verbatim -*> U is DOUBLE PRECISION array, -*> dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced -*> if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left -*> singular vector matrices of all subproblems at the bottom -*> level. -*> \endverbatim -*> -*> \param[in] LDU -*> \verbatim -*> LDU is INTEGER, LDU = > N. -*> The leading dimension of arrays U, VT, DIFL, DIFR, POLES, -*> GIVNUM, and Z. -*> \endverbatim -*> -*> \param[out] VT -*> \verbatim -*> VT is DOUBLE PRECISION array, -*> dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced -*> if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT**T contains the right -*> singular vector matrices of all subproblems at the bottom -*> level. -*> \endverbatim -*> -*> \param[out] K -*> \verbatim -*> K is INTEGER array, -*> dimension ( N ) if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0. -*> If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th -*> secular equation on the computation tree. -*> \endverbatim -*> -*> \param[out] DIFL -*> \verbatim -*> DIFL is DOUBLE PRECISION array, dimension ( LDU, NLVL ), -*> where NLVL = floor(log_2 (N/SMLSIZ))). -*> \endverbatim -*> -*> \param[out] DIFR -*> \verbatim -*> DIFR is DOUBLE PRECISION array, -*> dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and -*> dimension ( N ) if ICOMPQ = 0. -*> If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1) -*> record distances between singular values on the I-th -*> level and singular values on the (I -1)-th level, and -*> DIFR(1:N, 2 * I ) contains the normalizing factors for -*> the right singular vector matrix. See DLASD8 for details. -*> \endverbatim -*> -*> \param[out] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, -*> dimension ( LDU, NLVL ) if ICOMPQ = 1 and -*> dimension ( N ) if ICOMPQ = 0. -*> The first K elements of Z(1, I) contain the components of -*> the deflation-adjusted updating row vector for subproblems -*> on the I-th level. -*> \endverbatim -*> -*> \param[out] POLES -*> \verbatim -*> POLES is DOUBLE PRECISION array, -*> dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced -*> if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and -*> POLES(1, 2*I) contain the new and old singular values -*> involved in the secular equations on the I-th level. -*> \endverbatim -*> -*> \param[out] GIVPTR -*> \verbatim -*> GIVPTR is INTEGER array, -*> dimension ( N ) if ICOMPQ = 1, and not referenced if -*> ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records -*> the number of Givens rotations performed on the I-th -*> problem on the computation tree. -*> \endverbatim -*> -*> \param[out] GIVCOL -*> \verbatim -*> GIVCOL is INTEGER array, -*> dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not -*> referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, -*> GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations -*> of Givens rotations performed on the I-th level on the -*> computation tree. -*> \endverbatim -*> -*> \param[in] LDGCOL -*> \verbatim -*> LDGCOL is INTEGER, LDGCOL = > N. -*> The leading dimension of arrays GIVCOL and PERM. -*> \endverbatim -*> -*> \param[out] PERM -*> \verbatim -*> PERM is INTEGER array, -*> dimension ( LDGCOL, NLVL ) if ICOMPQ = 1, and not referenced -*> if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records -*> permutations done on the I-th level of the computation tree. -*> \endverbatim -*> -*> \param[out] GIVNUM -*> \verbatim -*> GIVNUM is DOUBLE PRECISION array, -*> dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not -*> referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, -*> GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S- -*> values of Givens rotations performed on the I-th level on -*> the computation tree. -*> \endverbatim -*> -*> \param[out] C -*> \verbatim -*> C is DOUBLE PRECISION array, -*> dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. -*> If ICOMPQ = 1 and the I-th subproblem is not square, on exit, -*> C( I ) contains the C-value of a Givens rotation related to -*> the right null space of the I-th subproblem. -*> \endverbatim -*> -*> \param[out] S -*> \verbatim -*> S is DOUBLE PRECISION array, dimension ( N ) if -*> ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1 -*> and the I-th subproblem is not square, on exit, S( I ) -*> contains the S-value of a Givens rotation related to -*> the right null space of the I-th subproblem. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension -*> (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)). -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, dimension (7*N) -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit. -*> < 0: if INFO = -i, the i-th argument had an illegal value. -*> > 0: if INFO = 1, a singular value did not converge -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -*> \par Contributors: -* ================== -*> -*> Ming Gu and Huan Ren, Computer Science Division, University of -*> California at Berkeley, USA -*> -* ===================================================================== - SUBROUTINE DLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K, - $ DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, - $ PERM, GIVNUM, C, S, WORK, IWORK, INFO ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER ICOMPQ, INFO, LDGCOL, LDU, N, SMLSIZ, SQRE -* .. -* .. Array Arguments .. - INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ), - $ K( * ), PERM( LDGCOL, * ) - DOUBLE PRECISION C( * ), D( * ), DIFL( LDU, * ), DIFR( LDU, * ), - $ E( * ), GIVNUM( LDU, * ), POLES( LDU, * ), - $ S( * ), U( LDU, * ), VT( LDU, * ), WORK( * ), - $ Z( LDU, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, I1, IC, IDXQ, IDXQI, IM1, INODE, ITEMP, IWK, - $ J, LF, LL, LVL, LVL2, M, NCC, ND, NDB1, NDIML, - $ NDIMR, NL, NLF, NLP1, NLVL, NR, NRF, NRP1, NRU, - $ NWORK1, NWORK2, SMLSZP, SQREI, VF, VFI, VL, VLI - DOUBLE PRECISION ALPHA, BETA -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DLASD6, DLASDQ, DLASDT, DLASET, XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN - INFO = -1 - ELSE IF( SMLSIZ.LT.3 ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN - INFO = -4 - ELSE IF( LDU.LT.( N+SQRE ) ) THEN - INFO = -8 - ELSE IF( LDGCOL.LT.N ) THEN - INFO = -17 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLASDA', -INFO ) - RETURN - END IF -* - M = N + SQRE -* -* If the input matrix is too small, call DLASDQ to find the SVD. -* - IF( N.LE.SMLSIZ ) THEN - IF( ICOMPQ.EQ.0 ) THEN - CALL DLASDQ( 'U', SQRE, N, 0, 0, 0, D, E, VT, LDU, U, LDU, - $ U, LDU, WORK, INFO ) - ELSE - CALL DLASDQ( 'U', SQRE, N, M, N, 0, D, E, VT, LDU, U, LDU, - $ U, LDU, WORK, INFO ) - END IF - RETURN - END IF -* -* Book-keeping and set up the computation tree. -* - INODE = 1 - NDIML = INODE + N - NDIMR = NDIML + N - IDXQ = NDIMR + N - IWK = IDXQ + N -* - NCC = 0 - NRU = 0 -* - SMLSZP = SMLSIZ + 1 - VF = 1 - VL = VF + M - NWORK1 = VL + M - NWORK2 = NWORK1 + SMLSZP*SMLSZP -* - CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ), - $ IWORK( NDIMR ), SMLSIZ ) -* -* for the nodes on bottom level of the tree, solve -* their subproblems by DLASDQ. -* - NDB1 = ( ND+1 ) / 2 - DO 30 I = NDB1, ND -* -* IC : center row of each node -* NL : number of rows of left subproblem -* NR : number of rows of right subproblem -* NLF: starting row of the left subproblem -* NRF: starting row of the right subproblem -* - I1 = I - 1 - IC = IWORK( INODE+I1 ) - NL = IWORK( NDIML+I1 ) - NLP1 = NL + 1 - NR = IWORK( NDIMR+I1 ) - NLF = IC - NL - NRF = IC + 1 - IDXQI = IDXQ + NLF - 2 - VFI = VF + NLF - 1 - VLI = VL + NLF - 1 - SQREI = 1 - IF( ICOMPQ.EQ.0 ) THEN - CALL DLASET( 'A', NLP1, NLP1, ZERO, ONE, WORK( NWORK1 ), - $ SMLSZP ) - CALL DLASDQ( 'U', SQREI, NL, NLP1, NRU, NCC, D( NLF ), - $ E( NLF ), WORK( NWORK1 ), SMLSZP, - $ WORK( NWORK2 ), NL, WORK( NWORK2 ), NL, - $ WORK( NWORK2 ), INFO ) - ITEMP = NWORK1 + NL*SMLSZP - CALL DCOPY( NLP1, WORK( NWORK1 ), 1, WORK( VFI ), 1 ) - CALL DCOPY( NLP1, WORK( ITEMP ), 1, WORK( VLI ), 1 ) - ELSE - CALL DLASET( 'A', NL, NL, ZERO, ONE, U( NLF, 1 ), LDU ) - CALL DLASET( 'A', NLP1, NLP1, ZERO, ONE, VT( NLF, 1 ), LDU ) - CALL DLASDQ( 'U', SQREI, NL, NLP1, NL, NCC, D( NLF ), - $ E( NLF ), VT( NLF, 1 ), LDU, U( NLF, 1 ), LDU, - $ U( NLF, 1 ), LDU, WORK( NWORK1 ), INFO ) - CALL DCOPY( NLP1, VT( NLF, 1 ), 1, WORK( VFI ), 1 ) - CALL DCOPY( NLP1, VT( NLF, NLP1 ), 1, WORK( VLI ), 1 ) - END IF - IF( INFO.NE.0 ) THEN - RETURN - END IF - DO 10 J = 1, NL - IWORK( IDXQI+J ) = J - 10 CONTINUE - IF( ( I.EQ.ND ) .AND. ( SQRE.EQ.0 ) ) THEN - SQREI = 0 - ELSE - SQREI = 1 - END IF - IDXQI = IDXQI + NLP1 - VFI = VFI + NLP1 - VLI = VLI + NLP1 - NRP1 = NR + SQREI - IF( ICOMPQ.EQ.0 ) THEN - CALL DLASET( 'A', NRP1, NRP1, ZERO, ONE, WORK( NWORK1 ), - $ SMLSZP ) - CALL DLASDQ( 'U', SQREI, NR, NRP1, NRU, NCC, D( NRF ), - $ E( NRF ), WORK( NWORK1 ), SMLSZP, - $ WORK( NWORK2 ), NR, WORK( NWORK2 ), NR, - $ WORK( NWORK2 ), INFO ) - ITEMP = NWORK1 + ( NRP1-1 )*SMLSZP - CALL DCOPY( NRP1, WORK( NWORK1 ), 1, WORK( VFI ), 1 ) - CALL DCOPY( NRP1, WORK( ITEMP ), 1, WORK( VLI ), 1 ) - ELSE - CALL DLASET( 'A', NR, NR, ZERO, ONE, U( NRF, 1 ), LDU ) - CALL DLASET( 'A', NRP1, NRP1, ZERO, ONE, VT( NRF, 1 ), LDU ) - CALL DLASDQ( 'U', SQREI, NR, NRP1, NR, NCC, D( NRF ), - $ E( NRF ), VT( NRF, 1 ), LDU, U( NRF, 1 ), LDU, - $ U( NRF, 1 ), LDU, WORK( NWORK1 ), INFO ) - CALL DCOPY( NRP1, VT( NRF, 1 ), 1, WORK( VFI ), 1 ) - CALL DCOPY( NRP1, VT( NRF, NRP1 ), 1, WORK( VLI ), 1 ) - END IF - IF( INFO.NE.0 ) THEN - RETURN - END IF - DO 20 J = 1, NR - IWORK( IDXQI+J ) = J - 20 CONTINUE - 30 CONTINUE -* -* Now conquer each subproblem bottom-up. -* - J = 2**NLVL - DO 50 LVL = NLVL, 1, -1 - LVL2 = LVL*2 - 1 -* -* Find the first node LF and last node LL on -* the current level LVL. -* - IF( LVL.EQ.1 ) THEN - LF = 1 - LL = 1 - ELSE - LF = 2**( LVL-1 ) - LL = 2*LF - 1 - END IF - DO 40 I = LF, LL - IM1 = I - 1 - IC = IWORK( INODE+IM1 ) - NL = IWORK( NDIML+IM1 ) - NR = IWORK( NDIMR+IM1 ) - NLF = IC - NL - NRF = IC + 1 - IF( I.EQ.LL ) THEN - SQREI = SQRE - ELSE - SQREI = 1 - END IF - VFI = VF + NLF - 1 - VLI = VL + NLF - 1 - IDXQI = IDXQ + NLF - 1 - ALPHA = D( IC ) - BETA = E( IC ) - IF( ICOMPQ.EQ.0 ) THEN - CALL DLASD6( ICOMPQ, NL, NR, SQREI, D( NLF ), - $ WORK( VFI ), WORK( VLI ), ALPHA, BETA, - $ IWORK( IDXQI ), PERM, GIVPTR( 1 ), GIVCOL, - $ LDGCOL, GIVNUM, LDU, POLES, DIFL, DIFR, Z, - $ K( 1 ), C( 1 ), S( 1 ), WORK( NWORK1 ), - $ IWORK( IWK ), INFO ) - ELSE - J = J - 1 - CALL DLASD6( ICOMPQ, NL, NR, SQREI, D( NLF ), - $ WORK( VFI ), WORK( VLI ), ALPHA, BETA, - $ IWORK( IDXQI ), PERM( NLF, LVL ), - $ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL, - $ GIVNUM( NLF, LVL2 ), LDU, - $ POLES( NLF, LVL2 ), DIFL( NLF, LVL ), - $ DIFR( NLF, LVL2 ), Z( NLF, LVL ), K( J ), - $ C( J ), S( J ), WORK( NWORK1 ), - $ IWORK( IWK ), INFO ) - END IF - IF( INFO.NE.0 ) THEN - RETURN - END IF - 40 CONTINUE - 50 CONTINUE -* - RETURN -* -* End of DLASDA -* - END diff --git a/lib/linalg/dlasdq.cpp b/lib/linalg/dlasdq.cpp new file mode 100644 index 0000000000..9b97d9258f --- /dev/null +++ b/lib/linalg/dlasdq.cpp @@ -0,0 +1,174 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +int dlasdq_(char *uplo, integer *sqre, integer *n, integer *ncvt, integer *nru, integer *ncc, + doublereal *d__, doublereal *e, doublereal *vt, integer *ldvt, doublereal *u, + integer *ldu, doublereal *c__, integer *ldc, doublereal *work, integer *info, + ftnlen uplo_len) +{ + integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2; + integer i__, j; + doublereal r__, cs, sn; + integer np1, isub; + doublereal smin; + integer sqre1; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern int dlasr_(char *, char *, char *, integer *, integer *, doublereal *, doublereal *, + doublereal *, integer *, ftnlen, ftnlen, ftnlen), + dswap_(integer *, doublereal *, integer *, doublereal *, integer *); + integer iuplo; + extern int dlartg_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *), + xerbla_(char *, integer *, ftnlen), + dbdsqr_(char *, integer *, integer *, integer *, integer *, doublereal *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, ftnlen); + logical rotate; + --d__; + --e; + vt_dim1 = *ldvt; + vt_offset = 1 + vt_dim1; + vt -= vt_offset; + u_dim1 = *ldu; + u_offset = 1 + u_dim1; + u -= u_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --work; + *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 (iuplo == 0) { + *info = -1; + } else if (*sqre < 0 || *sqre > 1) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ncvt < 0) { + *info = -4; + } else if (*nru < 0) { + *info = -5; + } else if (*ncc < 0) { + *info = -6; + } else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < max(1, *n)) { + *info = -10; + } else if (*ldu < max(1, *nru)) { + *info = -12; + } else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < max(1, *n)) { + *info = -14; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DLASDQ", &i__1, (ftnlen)6); + return 0; + } + if (*n == 0) { + return 0; + } + rotate = *ncvt > 0 || *nru > 0 || *ncc > 0; + np1 = *n + 1; + sqre1 = *sqre; + if (iuplo == 1 && sqre1 == 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 (rotate) { + work[i__] = cs; + work[*n + i__] = sn; + } + } + dlartg_(&d__[*n], &e[*n], &cs, &sn, &r__); + d__[*n] = r__; + e[*n] = 0.; + if (rotate) { + work[*n] = cs; + work[*n + *n] = sn; + } + iuplo = 2; + sqre1 = 0; + if (*ncvt > 0) { + dlasr_((char *)"L", (char *)"V", (char *)"F", &np1, ncvt, &work[1], &work[np1], &vt[vt_offset], ldvt, (ftnlen)1, + (ftnlen)1, (ftnlen)1); + } + } + if (iuplo == 2) { + 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 (rotate) { + work[i__] = cs; + work[*n + i__] = sn; + } + } + if (sqre1 == 1) { + dlartg_(&d__[*n], &e[*n], &cs, &sn, &r__); + d__[*n] = r__; + if (rotate) { + work[*n] = cs; + work[*n + *n] = sn; + } + } + if (*nru > 0) { + if (sqre1 == 0) { + dlasr_((char *)"R", (char *)"V", (char *)"F", nru, n, &work[1], &work[np1], &u[u_offset], ldu, (ftnlen)1, + (ftnlen)1, (ftnlen)1); + } else { + dlasr_((char *)"R", (char *)"V", (char *)"F", nru, &np1, &work[1], &work[np1], &u[u_offset], ldu, (ftnlen)1, + (ftnlen)1, (ftnlen)1); + } + } + if (*ncc > 0) { + if (sqre1 == 0) { + dlasr_((char *)"L", (char *)"V", (char *)"F", n, ncc, &work[1], &work[np1], &c__[c_offset], ldc, (ftnlen)1, + (ftnlen)1, (ftnlen)1); + } else { + dlasr_((char *)"L", (char *)"V", (char *)"F", &np1, ncc, &work[1], &work[np1], &c__[c_offset], ldc, + (ftnlen)1, (ftnlen)1, (ftnlen)1); + } + } + } + dbdsqr_((char *)"U", n, ncvt, nru, ncc, &d__[1], &e[1], &vt[vt_offset], ldvt, &u[u_offset], ldu, + &c__[c_offset], ldc, &work[1], info, (ftnlen)1); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + isub = i__; + smin = d__[i__]; + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + if (d__[j] < smin) { + isub = j; + smin = d__[j]; + } + } + if (isub != i__) { + d__[isub] = d__[i__]; + d__[i__] = smin; + if (*ncvt > 0) { + dswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[i__ + vt_dim1], ldvt); + } + if (*nru > 0) { + dswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[i__ * u_dim1 + 1], &c__1); + } + if (*ncc > 0) { + dswap_(ncc, &c__[isub + c_dim1], ldc, &c__[i__ + c_dim1], ldc); + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlasdq.f b/lib/linalg/dlasdq.f deleted file mode 100644 index 0c39b24f0d..0000000000 --- a/lib/linalg/dlasdq.f +++ /dev/null @@ -1,410 +0,0 @@ -*> \brief \b DLASDQ computes the SVD of a real bidiagonal matrix with diagonal d and off-diagonal e. Used by sbdsdc. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASDQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT, -* U, LDU, C, LDC, WORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU, SQRE -* .. -* .. Array Arguments .. -* DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ), -* $ VT( LDVT, * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLASDQ computes the singular value decomposition (SVD) of a real -*> (upper or lower) bidiagonal matrix with diagonal D and offdiagonal -*> E, accumulating the transformations if desired. Letting B denote -*> the input bidiagonal matrix, the algorithm computes orthogonal -*> matrices Q and P such that B = Q * S * P**T (P**T denotes the transpose -*> of P). The singular values S are overwritten on D. -*> -*> The input matrix U is changed to U * Q if desired. -*> The input matrix VT is changed to P**T * VT if desired. -*> The input matrix C is changed to Q**T * C if desired. -*> -*> See "Computing Small Singular Values of Bidiagonal Matrices With -*> Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, -*> LAPACK Working Note #3, for a detailed description of the algorithm. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the input bidiagonal matrix -*> is upper or lower bidiagonal, and whether it is square are -*> not. -*> UPLO = 'U' or 'u' B is upper bidiagonal. -*> UPLO = 'L' or 'l' B is lower bidiagonal. -*> \endverbatim -*> -*> \param[in] SQRE -*> \verbatim -*> SQRE is INTEGER -*> = 0: then the input matrix is N-by-N. -*> = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and -*> (N+1)-by-N if UPLU = 'L'. -*> -*> The bidiagonal matrix has -*> N = NL + NR + 1 rows and -*> M = N + SQRE >= N columns. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the number of rows and columns -*> in the matrix. N must be at least 0. -*> \endverbatim -*> -*> \param[in] NCVT -*> \verbatim -*> NCVT is INTEGER -*> On entry, NCVT specifies the number of columns of -*> the matrix VT. NCVT must be at least 0. -*> \endverbatim -*> -*> \param[in] NRU -*> \verbatim -*> NRU is INTEGER -*> On entry, NRU specifies the number of rows of -*> the matrix U. NRU must be at least 0. -*> \endverbatim -*> -*> \param[in] NCC -*> \verbatim -*> NCC is INTEGER -*> On entry, NCC specifies the number of columns of -*> the matrix C. NCC must be at least 0. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, D contains the diagonal entries of the -*> bidiagonal matrix whose SVD is desired. On normal exit, -*> D contains the singular values in ascending order. -*> \endverbatim -*> -*> \param[in,out] E -*> \verbatim -*> E is DOUBLE PRECISION array. -*> dimension is (N-1) if SQRE = 0 and N if SQRE = 1. -*> On entry, the entries of E contain the offdiagonal entries -*> of the bidiagonal matrix whose SVD is desired. On normal -*> exit, E will contain 0. If the algorithm does not converge, -*> D and E will contain the diagonal and superdiagonal entries -*> of a bidiagonal matrix orthogonally equivalent to the one -*> given as input. -*> \endverbatim -*> -*> \param[in,out] VT -*> \verbatim -*> VT is DOUBLE PRECISION array, dimension (LDVT, NCVT) -*> On entry, contains a matrix which on exit has been -*> premultiplied by P**T, dimension N-by-NCVT if SQRE = 0 -*> and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0). -*> \endverbatim -*> -*> \param[in] LDVT -*> \verbatim -*> LDVT is INTEGER -*> On entry, LDVT specifies the leading dimension of VT as -*> declared in the calling (sub) program. LDVT must be at -*> least 1. If NCVT is nonzero LDVT must also be at least N. -*> \endverbatim -*> -*> \param[in,out] U -*> \verbatim -*> U is DOUBLE PRECISION array, dimension (LDU, N) -*> On entry, contains a matrix which on exit has been -*> postmultiplied by Q, dimension NRU-by-N if SQRE = 0 -*> and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0). -*> \endverbatim -*> -*> \param[in] LDU -*> \verbatim -*> LDU is INTEGER -*> On entry, LDU specifies the leading dimension of U as -*> declared in the calling (sub) program. LDU must be at -*> least max( 1, NRU ) . -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension (LDC, NCC) -*> On entry, contains an N-by-NCC matrix which on exit -*> has been premultiplied by Q**T dimension N-by-NCC if SQRE = 0 -*> and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0). -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> On entry, LDC specifies the leading dimension of C as -*> declared in the calling (sub) program. LDC must be at -*> least 1. If NCC is nonzero, LDC must also be at least N. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (4*N) -*> Workspace. Only referenced if one of NCVT, NRU, or NCC is -*> nonzero, and if N is at least 2. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> On exit, a value of 0 indicates a successful exit. -*> If INFO < 0, argument number -INFO is illegal. -*> If INFO > 0, the algorithm did not converge, and INFO -*> specifies how many superdiagonals did not converge. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -*> \par Contributors: -* ================== -*> -*> Ming Gu and Huan Ren, Computer Science Division, University of -*> California at Berkeley, USA -*> -* ===================================================================== - SUBROUTINE DLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT, - $ U, LDU, C, LDC, WORK, INFO ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU, SQRE -* .. -* .. Array Arguments .. - DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ), - $ VT( LDVT, * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL ROTATE - INTEGER I, ISUB, IUPLO, J, NP1, SQRE1 - DOUBLE PRECISION CS, R, SMIN, SN -* .. -* .. External Subroutines .. - EXTERNAL DBDSQR, DLARTG, DLASR, DSWAP, XERBLA -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IUPLO = 0 - IF( LSAME( UPLO, 'U' ) ) - $ IUPLO = 1 - IF( LSAME( UPLO, 'L' ) ) - $ IUPLO = 2 - IF( IUPLO.EQ.0 ) THEN - INFO = -1 - ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( NCVT.LT.0 ) THEN - INFO = -4 - ELSE IF( NRU.LT.0 ) THEN - INFO = -5 - ELSE IF( NCC.LT.0 ) THEN - INFO = -6 - ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR. - $ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN - INFO = -10 - ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN - INFO = -12 - ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR. - $ ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN - INFO = -14 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLASDQ', -INFO ) - RETURN - END IF - IF( N.EQ.0 ) - $ RETURN -* -* ROTATE is true if any singular vectors desired, false otherwise -* - ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 ) - NP1 = N + 1 - SQRE1 = SQRE -* -* If matrix non-square upper bidiagonal, rotate to be lower -* bidiagonal. The rotations are on the right. -* - IF( ( IUPLO.EQ.1 ) .AND. ( SQRE1.EQ.1 ) ) THEN - DO 10 I = 1, N - 1 - CALL 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( ROTATE ) THEN - WORK( I ) = CS - WORK( N+I ) = SN - END IF - 10 CONTINUE - CALL DLARTG( D( N ), E( N ), CS, SN, R ) - D( N ) = R - E( N ) = ZERO - IF( ROTATE ) THEN - WORK( N ) = CS - WORK( N+N ) = SN - END IF - IUPLO = 2 - SQRE1 = 0 -* -* Update singular vectors if desired. -* - IF( NCVT.GT.0 ) - $ CALL DLASR( 'L', 'V', 'F', NP1, NCVT, WORK( 1 ), - $ WORK( NP1 ), VT, LDVT ) - END IF -* -* If matrix lower bidiagonal, rotate to be upper bidiagonal -* by applying Givens rotations on the left. -* - IF( IUPLO.EQ.2 ) THEN - DO 20 I = 1, N - 1 - CALL 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( ROTATE ) THEN - WORK( I ) = CS - WORK( N+I ) = SN - END IF - 20 CONTINUE -* -* If matrix (N+1)-by-N lower bidiagonal, one additional -* rotation is needed. -* - IF( SQRE1.EQ.1 ) THEN - CALL DLARTG( D( N ), E( N ), CS, SN, R ) - D( N ) = R - IF( ROTATE ) THEN - WORK( N ) = CS - WORK( N+N ) = SN - END IF - END IF -* -* Update singular vectors if desired. -* - IF( NRU.GT.0 ) THEN - IF( SQRE1.EQ.0 ) THEN - CALL DLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ), - $ WORK( NP1 ), U, LDU ) - ELSE - CALL DLASR( 'R', 'V', 'F', NRU, NP1, WORK( 1 ), - $ WORK( NP1 ), U, LDU ) - END IF - END IF - IF( NCC.GT.0 ) THEN - IF( SQRE1.EQ.0 ) THEN - CALL DLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ), - $ WORK( NP1 ), C, LDC ) - ELSE - CALL DLASR( 'L', 'V', 'F', NP1, NCC, WORK( 1 ), - $ WORK( NP1 ), C, LDC ) - END IF - END IF - END IF -* -* Call DBDSQR to compute the SVD of the reduced real -* N-by-N upper bidiagonal matrix. -* - CALL DBDSQR( 'U', N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, - $ LDC, WORK, INFO ) -* -* Sort the singular values into ascending order (insertion sort on -* singular values, but only one transposition per singular vector) -* - DO 40 I = 1, N -* -* Scan for smallest D(I). -* - ISUB = I - SMIN = D( I ) - DO 30 J = I + 1, N - IF( D( J ).LT.SMIN ) THEN - ISUB = J - SMIN = D( J ) - END IF - 30 CONTINUE - IF( ISUB.NE.I ) THEN -* -* Swap singular values and vectors. -* - D( ISUB ) = D( I ) - D( I ) = SMIN - IF( NCVT.GT.0 ) - $ CALL DSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( I, 1 ), LDVT ) - IF( NRU.GT.0 ) - $ CALL DSWAP( NRU, U( 1, ISUB ), 1, U( 1, I ), 1 ) - IF( NCC.GT.0 ) - $ CALL DSWAP( NCC, C( ISUB, 1 ), LDC, C( I, 1 ), LDC ) - END IF - 40 CONTINUE -* - RETURN -* -* End of DLASDQ -* - END diff --git a/lib/linalg/dlasdt.cpp b/lib/linalg/dlasdt.cpp new file mode 100644 index 0000000000..ddc7df74ba --- /dev/null +++ b/lib/linalg/dlasdt.cpp @@ -0,0 +1,47 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dlasdt_(integer *n, integer *lvl, integer *nd, integer *inode, integer *ndiml, integer *ndimr, + integer *msub) +{ + integer i__1, i__2; + double log(doublereal); + integer i__, il, ir, maxn; + doublereal temp; + integer nlvl, llst, ncrnt; + --ndimr; + --ndiml; + --inode; + maxn = max(1, *n); + temp = log((doublereal)maxn / (doublereal)(*msub + 1)) / log(2.); + *lvl = (integer)temp + 1; + i__ = *n / 2; + inode[1] = i__ + 1; + ndiml[1] = i__; + ndimr[1] = *n - i__ - 1; + il = 0; + ir = 1; + llst = 1; + i__1 = *lvl - 1; + for (nlvl = 1; nlvl <= i__1; ++nlvl) { + i__2 = llst - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + il += 2; + ir += 2; + ncrnt = llst + i__; + ndiml[il] = ndiml[ncrnt] / 2; + ndimr[il] = ndiml[ncrnt] - ndiml[il] - 1; + inode[il] = inode[ncrnt] - ndimr[il] - 1; + ndiml[ir] = ndimr[ncrnt] / 2; + ndimr[ir] = ndimr[ncrnt] - ndiml[ir] - 1; + inode[ir] = inode[ncrnt] + ndiml[ir] + 1; + } + llst <<= 1; + } + *nd = (llst << 1) - 1; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlasdt.f b/lib/linalg/dlasdt.f deleted file mode 100644 index 0d9999ea62..0000000000 --- a/lib/linalg/dlasdt.f +++ /dev/null @@ -1,169 +0,0 @@ -*> \brief \b DLASDT creates a tree of subproblems for bidiagonal divide and conquer. Used by sbdsdc. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASDT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB ) -* -* .. Scalar Arguments .. -* INTEGER LVL, MSUB, N, ND -* .. -* .. Array Arguments .. -* INTEGER INODE( * ), NDIML( * ), NDIMR( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLASDT creates a tree of subproblems for bidiagonal divide and -*> conquer. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, the number of diagonal elements of the -*> bidiagonal matrix. -*> \endverbatim -*> -*> \param[out] LVL -*> \verbatim -*> LVL is INTEGER -*> On exit, the number of levels on the computation tree. -*> \endverbatim -*> -*> \param[out] ND -*> \verbatim -*> ND is INTEGER -*> On exit, the number of nodes on the tree. -*> \endverbatim -*> -*> \param[out] INODE -*> \verbatim -*> INODE is INTEGER array, dimension ( N ) -*> On exit, centers of subproblems. -*> \endverbatim -*> -*> \param[out] NDIML -*> \verbatim -*> NDIML is INTEGER array, dimension ( N ) -*> On exit, row dimensions of left children. -*> \endverbatim -*> -*> \param[out] NDIMR -*> \verbatim -*> NDIMR is INTEGER array, dimension ( N ) -*> On exit, row dimensions of right children. -*> \endverbatim -*> -*> \param[in] MSUB -*> \verbatim -*> MSUB is INTEGER -*> On entry, the maximum row dimension each subproblem at the -*> bottom of the tree can be of. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -*> \par Contributors: -* ================== -*> -*> Ming Gu and Huan Ren, Computer Science Division, University of -*> California at Berkeley, USA -*> -* ===================================================================== - SUBROUTINE DLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER LVL, MSUB, N, ND -* .. -* .. Array Arguments .. - INTEGER INODE( * ), NDIML( * ), NDIMR( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, IL, IR, LLST, MAXN, NCRNT, NLVL - DOUBLE PRECISION TEMP -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, INT, LOG, MAX -* .. -* .. Executable Statements .. -* -* Find the number of levels on the tree. -* - MAXN = MAX( 1, N ) - TEMP = LOG( DBLE( MAXN ) / DBLE( MSUB+1 ) ) / LOG( TWO ) - LVL = INT( TEMP ) + 1 -* - I = N / 2 - INODE( 1 ) = I + 1 - NDIML( 1 ) = I - NDIMR( 1 ) = N - I - 1 - IL = 0 - IR = 1 - LLST = 1 - DO 20 NLVL = 1, LVL - 1 -* -* Constructing the tree at (NLVL+1)-st level. The number of -* nodes created on this level is LLST * 2. -* - DO 10 I = 0, LLST - 1 - IL = IL + 2 - IR = IR + 2 - NCRNT = LLST + I - NDIML( IL ) = NDIML( NCRNT ) / 2 - NDIMR( IL ) = NDIML( NCRNT ) - NDIML( IL ) - 1 - INODE( IL ) = INODE( NCRNT ) - NDIMR( IL ) - 1 - NDIML( IR ) = NDIMR( NCRNT ) / 2 - NDIMR( IR ) = NDIMR( NCRNT ) - NDIML( IR ) - 1 - INODE( IR ) = INODE( NCRNT ) + NDIML( IR ) + 1 - 10 CONTINUE - LLST = LLST*2 - 20 CONTINUE - ND = LLST*2 - 1 -* - RETURN -* -* End of DLASDT -* - END diff --git a/lib/linalg/dlaset.cpp b/lib/linalg/dlaset.cpp new file mode 100644 index 0000000000..b3cea88292 --- /dev/null +++ b/lib/linalg/dlaset.cpp @@ -0,0 +1,48 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dlaset_(char *uplo, integer *m, integer *n, doublereal *alpha, doublereal *beta, doublereal *a, + integer *lda, ftnlen uplo_len) +{ + integer a_dim1, a_offset, i__1, i__2, i__3; + integer i__, j; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + i__3 = j - 1; + i__2 = min(i__3, *m); + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = *alpha; + } + } + } else if (lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { + i__1 = min(*m, *n); + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = *alpha; + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = *alpha; + } + } + } + i__1 = min(*m, *n); + for (i__ = 1; i__ <= i__1; ++i__) { + a[i__ + i__ * a_dim1] = *beta; + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlaset.f b/lib/linalg/dlaset.f deleted file mode 100644 index 625c757b6b..0000000000 --- a/lib/linalg/dlaset.f +++ /dev/null @@ -1,181 +0,0 @@ -*> \brief \b DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASET + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER LDA, M, N -* DOUBLE PRECISION ALPHA, BETA -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLASET initializes an m-by-n matrix A to BETA on the diagonal and -*> ALPHA on the offdiagonals. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> Specifies the part of the matrix A to be set. -*> = 'U': Upper triangular part is set; the strictly lower -*> triangular part of A is not changed. -*> = 'L': Lower triangular part is set; the strictly upper -*> triangular part of A is not changed. -*> Otherwise: All of the matrix A is set. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is DOUBLE PRECISION -*> The constant to which the offdiagonal elements are to be set. -*> \endverbatim -*> -*> \param[in] BETA -*> \verbatim -*> BETA is DOUBLE PRECISION -*> The constant to which the diagonal elements are to be set. -*> \endverbatim -*> -*> \param[out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On exit, the leading m-by-n submatrix of A is set as follows: -*> -*> if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n, -*> if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n, -*> otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j, -*> -*> and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n). -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, M, N - DOUBLE PRECISION ALPHA, BETA -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, J -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* - IF( LSAME( UPLO, 'U' ) ) THEN -* -* Set the strictly upper triangular or trapezoidal part of the -* array to ALPHA. -* - DO 20 J = 2, N - DO 10 I = 1, MIN( J-1, M ) - A( I, J ) = ALPHA - 10 CONTINUE - 20 CONTINUE -* - ELSE IF( LSAME( UPLO, 'L' ) ) THEN -* -* Set the strictly lower triangular or trapezoidal part of the -* array to ALPHA. -* - DO 40 J = 1, MIN( M, N ) - DO 30 I = J + 1, M - A( I, J ) = ALPHA - 30 CONTINUE - 40 CONTINUE -* - ELSE -* -* Set the leading m-by-n submatrix to ALPHA. -* - DO 60 J = 1, N - DO 50 I = 1, M - A( I, J ) = ALPHA - 50 CONTINUE - 60 CONTINUE - END IF -* -* Set the first min(M,N) diagonal elements to BETA. -* - DO 70 I = 1, MIN( M, N ) - A( I, I ) = BETA - 70 CONTINUE -* - RETURN -* -* End of DLASET -* - END diff --git a/lib/linalg/dlasq1.cpp b/lib/linalg/dlasq1.cpp new file mode 100644 index 0000000000..1a719c6ee3 --- /dev/null +++ b/lib/linalg/dlasq1.cpp @@ -0,0 +1,100 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +static integer c__2 = 2; +static integer c__0 = 0; +int dlasq1_(integer *n, doublereal *d__, doublereal *e, doublereal *work, integer *info) +{ + integer i__1, i__2; + doublereal d__1, d__2, d__3; + double sqrt(doublereal); + integer i__; + doublereal eps; + extern int dlas2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *); + doublereal scale; + integer iinfo; + doublereal sigmn; + extern int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *); + doublereal sigmx; + extern int dlasq2_(integer *, doublereal *, integer *); + extern doublereal dlamch_(char *, ftnlen); + extern int dlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, + integer *, doublereal *, integer *, integer *, ftnlen); + doublereal safmin; + extern int xerbla_(char *, integer *, ftnlen), + dlasrt_(char *, integer *, doublereal *, integer *, ftnlen); + --work; + --e; + --d__; + *info = 0; + if (*n < 0) { + *info = -1; + i__1 = -(*info); + xerbla_((char *)"DLASQ1", &i__1, (ftnlen)6); + return 0; + } else if (*n == 0) { + return 0; + } else if (*n == 1) { + d__[1] = abs(d__[1]); + return 0; + } else if (*n == 2) { + dlas2_(&d__[1], &e[1], &d__[2], &sigmn, &sigmx); + d__[1] = sigmx; + d__[2] = sigmn; + return 0; + } + sigmx = 0.; + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = (d__1 = d__[i__], abs(d__1)); + d__2 = sigmx, d__3 = (d__1 = e[i__], abs(d__1)); + sigmx = max(d__2, d__3); + } + d__[*n] = (d__1 = d__[*n], abs(d__1)); + if (sigmx == 0.) { + dlasrt_((char *)"D", n, &d__[1], &iinfo, (ftnlen)1); + return 0; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__1 = sigmx, d__2 = d__[i__]; + sigmx = max(d__1, d__2); + } + eps = dlamch_((char *)"Precision", (ftnlen)9); + safmin = dlamch_((char *)"Safe minimum", (ftnlen)12); + scale = sqrt(eps / safmin); + dcopy_(n, &d__[1], &c__1, &work[1], &c__2); + i__1 = *n - 1; + dcopy_(&i__1, &e[1], &c__1, &work[2], &c__2); + i__1 = (*n << 1) - 1; + i__2 = (*n << 1) - 1; + dlascl_((char *)"G", &c__0, &c__0, &sigmx, &scale, &i__1, &c__1, &work[1], &i__2, &iinfo, (ftnlen)1); + i__1 = (*n << 1) - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + d__1 = work[i__]; + work[i__] = d__1 * d__1; + } + work[*n * 2] = 0.; + dlasq2_(n, &work[1], info); + if (*info == 0) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = sqrt(work[i__]); + } + dlascl_((char *)"G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &d__[1], n, &iinfo, (ftnlen)1); + } else if (*info == 2) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = sqrt(work[(i__ << 1) - 1]); + e[i__] = sqrt(work[i__ * 2]); + } + dlascl_((char *)"G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &d__[1], n, &iinfo, (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &e[1], n, &iinfo, (ftnlen)1); + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlasq1.f b/lib/linalg/dlasq1.f deleted file mode 100644 index 27fa30736e..0000000000 --- a/lib/linalg/dlasq1.f +++ /dev/null @@ -1,221 +0,0 @@ -*> \brief \b DLASQ1 computes the singular values of a real square bidiagonal matrix. Used by sbdsqr. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASQ1 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLASQ1( N, D, E, WORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION D( * ), E( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLASQ1 computes the singular values of a real N-by-N bidiagonal -*> matrix with diagonal D and off-diagonal E. The singular values -*> are computed to high relative accuracy, in the absence of -*> denormalization, underflow and overflow. The algorithm was first -*> presented in -*> -*> "Accurate singular values and differential qd algorithms" by K. V. -*> Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230, -*> 1994, -*> -*> and the present implementation is described in "An implementation of -*> the dqds Algorithm (Positive Case)", LAPACK Working Note. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of rows and columns in the matrix. N >= 0. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, D contains the diagonal elements of the -*> bidiagonal matrix whose SVD is desired. On normal exit, -*> D contains the singular values in decreasing order. -*> \endverbatim -*> -*> \param[in,out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N) -*> On entry, elements E(1:N-1) contain the off-diagonal elements -*> of the bidiagonal matrix whose SVD is desired. -*> On exit, E is overwritten. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (4*N) -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> > 0: the algorithm failed -*> = 1, a split was marked by a positive value in E -*> = 2, current block of Z not diagonalized after 100*N -*> iterations (in inner while loop) On exit D and E -*> represent a matrix with the same singular values -*> which the calling subroutine could use to finish the -*> computation, or even feed back into DLASQ1 -*> = 3, termination criterion of outer while loop not met -*> (program created more than N unreduced blocks) -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -* ===================================================================== - SUBROUTINE DLASQ1( N, D, E, WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), E( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -* .. -* .. Local Scalars .. - INTEGER I, IINFO - DOUBLE PRECISION EPS, SCALE, SAFMIN, SIGMN, SIGMX -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DLAS2, DLASCL, DLASQ2, DLASRT, XERBLA -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -* .. -* .. Executable Statements .. -* - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - CALL XERBLA( 'DLASQ1', -INFO ) - RETURN - ELSE IF( N.EQ.0 ) THEN - RETURN - ELSE IF( N.EQ.1 ) THEN - D( 1 ) = ABS( D( 1 ) ) - RETURN - ELSE IF( N.EQ.2 ) THEN - CALL DLAS2( D( 1 ), E( 1 ), D( 2 ), SIGMN, SIGMX ) - D( 1 ) = SIGMX - D( 2 ) = SIGMN - RETURN - END IF -* -* Estimate the largest singular value. -* - SIGMX = ZERO - DO 10 I = 1, N - 1 - D( I ) = ABS( D( I ) ) - SIGMX = MAX( SIGMX, ABS( E( I ) ) ) - 10 CONTINUE - D( N ) = ABS( D( N ) ) -* -* Early return if SIGMX is zero (matrix is already diagonal). -* - IF( SIGMX.EQ.ZERO ) THEN - CALL DLASRT( 'D', N, D, IINFO ) - RETURN - END IF -* - DO 20 I = 1, N - SIGMX = MAX( SIGMX, D( I ) ) - 20 CONTINUE -* -* Copy D and E into WORK (in the Z format) and scale (squaring the -* input data makes scaling by a power of the radix pointless). -* - EPS = DLAMCH( 'Precision' ) - SAFMIN = DLAMCH( 'Safe minimum' ) - SCALE = SQRT( EPS / SAFMIN ) - CALL DCOPY( N, D, 1, WORK( 1 ), 2 ) - CALL DCOPY( N-1, E, 1, WORK( 2 ), 2 ) - CALL DLASCL( 'G', 0, 0, SIGMX, SCALE, 2*N-1, 1, WORK, 2*N-1, - $ IINFO ) -* -* Compute the q's and e's. -* - DO 30 I = 1, 2*N - 1 - WORK( I ) = WORK( I )**2 - 30 CONTINUE - WORK( 2*N ) = ZERO -* - CALL DLASQ2( N, WORK, INFO ) -* - IF( INFO.EQ.0 ) THEN - DO 40 I = 1, N - D( I ) = SQRT( WORK( I ) ) - 40 CONTINUE - CALL DLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, D, N, IINFO ) - ELSE IF( INFO.EQ.2 ) THEN -* -* Maximum number of iterations exceeded. Move data from WORK -* into D and E so the calling subroutine can try to finish -* - DO I = 1, N - D( I ) = SQRT( WORK( 2*I-1 ) ) - E( I ) = SQRT( WORK( 2*I ) ) - END DO - CALL DLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, D, N, IINFO ) - CALL DLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, E, N, IINFO ) - END IF -* - RETURN -* -* End of DLASQ1 -* - END diff --git a/lib/linalg/dlasq2.cpp b/lib/linalg/dlasq2.cpp new file mode 100644 index 0000000000..37bc963975 --- /dev/null +++ b/lib/linalg/dlasq2.cpp @@ -0,0 +1,395 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +static integer c__2 = 2; +static integer c__10 = 10; +static integer c__3 = 3; +static integer c__4 = 4; +int dlasq2_(integer *n, doublereal *z__, integer *info) +{ + integer i__1, i__2, i__3; + doublereal d__1, d__2; + double sqrt(doublereal); + doublereal d__, e, g; + integer k; + doublereal s, t; + integer i0, i1, i4, n0, n1; + doublereal dn; + integer pp; + doublereal dn1, dn2, dee, eps, tau, tol; + integer ipn4; + doublereal tol2; + logical ieee; + integer nbig; + doublereal dmin__, emin, emax; + integer kmin, ndiv, iter; + doublereal qmin, temp, qmax, zmax; + integer splt; + doublereal dmin1, dmin2; + integer nfail; + doublereal desig, trace, sigma; + integer iinfo; + doublereal tempe, tempq; + integer ttype; + extern int dlasq3_(integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, + doublereal *, doublereal *, integer *, integer *, integer *, logical *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *); + extern doublereal dlamch_(char *, ftnlen); + doublereal deemin; + integer iwhila, iwhilb; + doublereal oldemn, safmin; + extern int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, + ftnlen, ftnlen); + extern int dlasrt_(char *, integer *, doublereal *, integer *, ftnlen); + --z__; + *info = 0; + eps = dlamch_((char *)"Precision", (ftnlen)9); + safmin = dlamch_((char *)"Safe minimum", (ftnlen)12); + tol = eps * 100.; + d__1 = tol; + tol2 = d__1 * d__1; + if (*n < 0) { + *info = -1; + xerbla_((char *)"DLASQ2", &c__1, (ftnlen)6); + return 0; + } else if (*n == 0) { + return 0; + } else if (*n == 1) { + if (z__[1] < 0.) { + *info = -201; + xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6); + } + return 0; + } else if (*n == 2) { + if (z__[1] < 0.) { + *info = -201; + xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6); + return 0; + } else if (z__[2] < 0.) { + *info = -202; + xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6); + return 0; + } else if (z__[3] < 0.) { + *info = -203; + xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6); + return 0; + } else if (z__[3] > z__[1]) { + d__ = z__[3]; + z__[3] = z__[1]; + z__[1] = d__; + } + z__[5] = z__[1] + z__[2] + z__[3]; + if (z__[2] > z__[3] * tol2) { + t = (z__[1] - z__[3] + z__[2]) * .5; + s = z__[3] * (z__[2] / t); + if (s <= t) { + s = z__[3] * (z__[2] / (t * (sqrt(s / t + 1.) + 1.))); + } else { + s = z__[3] * (z__[2] / (t + sqrt(t) * sqrt(t + s))); + } + t = z__[1] + (s + z__[2]); + z__[3] *= z__[1] / t; + z__[1] = t; + } + z__[2] = z__[3]; + z__[6] = z__[2] + z__[1]; + return 0; + } + z__[*n * 2] = 0.; + emin = z__[2]; + qmax = 0.; + zmax = 0.; + d__ = 0.; + e = 0.; + i__1 = *n - 1 << 1; + for (k = 1; k <= i__1; k += 2) { + if (z__[k] < 0.) { + *info = -(k + 200); + xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6); + return 0; + } else if (z__[k + 1] < 0.) { + *info = -(k + 201); + xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6); + return 0; + } + d__ += z__[k]; + e += z__[k + 1]; + d__1 = qmax, d__2 = z__[k]; + qmax = max(d__1, d__2); + d__1 = emin, d__2 = z__[k + 1]; + emin = min(d__1, d__2); + d__1 = max(qmax, zmax), d__2 = z__[k + 1]; + zmax = max(d__1, d__2); + } + if (z__[(*n << 1) - 1] < 0.) { + *info = -((*n << 1) + 199); + xerbla_((char *)"DLASQ2", &c__2, (ftnlen)6); + return 0; + } + d__ += z__[(*n << 1) - 1]; + d__1 = qmax, d__2 = z__[(*n << 1) - 1]; + qmax = max(d__1, d__2); + zmax = max(qmax, zmax); + if (e == 0.) { + i__1 = *n; + for (k = 2; k <= i__1; ++k) { + z__[k] = z__[(k << 1) - 1]; + } + dlasrt_((char *)"D", n, &z__[1], &iinfo, (ftnlen)1); + z__[(*n << 1) - 1] = d__; + return 0; + } + trace = d__ + e; + if (trace == 0.) { + z__[(*n << 1) - 1] = 0.; + return 0; + } + ieee = ilaenv_(&c__10, (char *)"DLASQ2", (char *)"N", &c__1, &c__2, &c__3, &c__4, (ftnlen)6, (ftnlen)1) == 1; + for (k = *n << 1; k >= 2; k += -2) { + z__[k * 2] = 0.; + z__[(k << 1) - 1] = z__[k]; + z__[(k << 1) - 2] = 0.; + z__[(k << 1) - 3] = z__[k - 1]; + } + i0 = 1; + n0 = *n; + if (z__[(i0 << 2) - 3] * 1.5 < z__[(n0 << 2) - 3]) { + ipn4 = i0 + n0 << 2; + i__1 = i0 + n0 - 1 << 1; + for (i4 = i0 << 2; i4 <= i__1; i4 += 4) { + temp = z__[i4 - 3]; + z__[i4 - 3] = z__[ipn4 - i4 - 3]; + z__[ipn4 - i4 - 3] = temp; + temp = z__[i4 - 1]; + z__[i4 - 1] = z__[ipn4 - i4 - 5]; + z__[ipn4 - i4 - 5] = temp; + } + } + pp = 0; + for (k = 1; k <= 2; ++k) { + d__ = z__[(n0 << 2) + pp - 3]; + i__1 = (i0 << 2) + pp; + for (i4 = (n0 - 1 << 2) + pp; i4 >= i__1; i4 += -4) { + if (z__[i4 - 1] <= tol2 * d__) { + z__[i4 - 1] = -0.; + d__ = z__[i4 - 3]; + } else { + d__ = z__[i4 - 3] * (d__ / (d__ + z__[i4 - 1])); + } + } + emin = z__[(i0 << 2) + pp + 1]; + d__ = z__[(i0 << 2) + pp - 3]; + i__1 = (n0 - 1 << 2) + pp; + for (i4 = (i0 << 2) + pp; i4 <= i__1; i4 += 4) { + z__[i4 - (pp << 1) - 2] = d__ + z__[i4 - 1]; + if (z__[i4 - 1] <= tol2 * d__) { + z__[i4 - 1] = -0.; + z__[i4 - (pp << 1) - 2] = d__; + z__[i4 - (pp << 1)] = 0.; + d__ = z__[i4 + 1]; + } else if (safmin * z__[i4 + 1] < z__[i4 - (pp << 1) - 2] && + safmin * z__[i4 - (pp << 1) - 2] < z__[i4 + 1]) { + temp = z__[i4 + 1] / z__[i4 - (pp << 1) - 2]; + z__[i4 - (pp << 1)] = z__[i4 - 1] * temp; + d__ *= temp; + } else { + z__[i4 - (pp << 1)] = z__[i4 + 1] * (z__[i4 - 1] / z__[i4 - (pp << 1) - 2]); + d__ = z__[i4 + 1] * (d__ / z__[i4 - (pp << 1) - 2]); + } + d__1 = emin, d__2 = z__[i4 - (pp << 1)]; + emin = min(d__1, d__2); + } + z__[(n0 << 2) - pp - 2] = d__; + qmax = z__[(i0 << 2) - pp - 2]; + i__1 = (n0 << 2) - pp - 2; + for (i4 = (i0 << 2) - pp + 2; i4 <= i__1; i4 += 4) { + d__1 = qmax, d__2 = z__[i4]; + qmax = max(d__1, d__2); + } + pp = 1 - pp; + } + ttype = 0; + dmin1 = 0.; + dmin2 = 0.; + dn = 0.; + dn1 = 0.; + dn2 = 0.; + g = 0.; + tau = 0.; + iter = 2; + nfail = 0; + ndiv = n0 - i0 << 1; + i__1 = *n + 1; + for (iwhila = 1; iwhila <= i__1; ++iwhila) { + if (n0 < 1) { + goto L170; + } + desig = 0.; + if (n0 == *n) { + sigma = 0.; + } else { + sigma = -z__[(n0 << 2) - 1]; + } + if (sigma < 0.) { + *info = 1; + return 0; + } + emax = 0.; + if (n0 > i0) { + emin = (d__1 = z__[(n0 << 2) - 5], abs(d__1)); + } else { + emin = 0.; + } + qmin = z__[(n0 << 2) - 3]; + qmax = qmin; + for (i4 = n0 << 2; i4 >= 8; i4 += -4) { + if (z__[i4 - 5] <= 0.) { + goto L100; + } + if (qmin >= emax * 4.) { + d__1 = qmin, d__2 = z__[i4 - 3]; + qmin = min(d__1, d__2); + d__1 = emax, d__2 = z__[i4 - 5]; + emax = max(d__1, d__2); + } + d__1 = qmax, d__2 = z__[i4 - 7] + z__[i4 - 5]; + qmax = max(d__1, d__2); + d__1 = emin, d__2 = z__[i4 - 5]; + emin = min(d__1, d__2); + } + i4 = 4; + L100: + i0 = i4 / 4; + pp = 0; + if (n0 - i0 > 1) { + dee = z__[(i0 << 2) - 3]; + deemin = dee; + kmin = i0; + i__2 = (n0 << 2) - 3; + for (i4 = (i0 << 2) + 1; i4 <= i__2; i4 += 4) { + dee = z__[i4] * (dee / (dee + z__[i4 - 2])); + if (dee <= deemin) { + deemin = dee; + kmin = (i4 + 3) / 4; + } + } + if (kmin - i0 << 1 < n0 - kmin && deemin <= z__[(n0 << 2) - 3] * .5) { + ipn4 = i0 + n0 << 2; + pp = 2; + i__2 = i0 + n0 - 1 << 1; + for (i4 = i0 << 2; i4 <= i__2; i4 += 4) { + temp = z__[i4 - 3]; + z__[i4 - 3] = z__[ipn4 - i4 - 3]; + z__[ipn4 - i4 - 3] = temp; + temp = z__[i4 - 2]; + z__[i4 - 2] = z__[ipn4 - i4 - 2]; + z__[ipn4 - i4 - 2] = temp; + temp = z__[i4 - 1]; + z__[i4 - 1] = z__[ipn4 - i4 - 5]; + z__[ipn4 - i4 - 5] = temp; + temp = z__[i4]; + z__[i4] = z__[ipn4 - i4 - 4]; + z__[ipn4 - i4 - 4] = temp; + } + } + } + d__1 = 0., d__2 = qmin - sqrt(qmin) * 2. * sqrt(emax); + dmin__ = -max(d__1, d__2); + nbig = (n0 - i0 + 1) * 100; + i__2 = nbig; + for (iwhilb = 1; iwhilb <= i__2; ++iwhilb) { + if (i0 > n0) { + goto L150; + } + dlasq3_(&i0, &n0, &z__[1], &pp, &dmin__, &sigma, &desig, &qmax, &nfail, &iter, &ndiv, + &ieee, &ttype, &dmin1, &dmin2, &dn, &dn1, &dn2, &g, &tau); + pp = 1 - pp; + if (pp == 0 && n0 - i0 >= 3) { + if (z__[n0 * 4] <= tol2 * qmax || z__[(n0 << 2) - 1] <= tol2 * sigma) { + splt = i0 - 1; + qmax = z__[(i0 << 2) - 3]; + emin = z__[(i0 << 2) - 1]; + oldemn = z__[i0 * 4]; + i__3 = n0 - 3 << 2; + for (i4 = i0 << 2; i4 <= i__3; i4 += 4) { + if (z__[i4] <= tol2 * z__[i4 - 3] || z__[i4 - 1] <= tol2 * sigma) { + z__[i4 - 1] = -sigma; + splt = i4 / 4; + qmax = 0.; + emin = z__[i4 + 3]; + oldemn = z__[i4 + 4]; + } else { + d__1 = qmax, d__2 = z__[i4 + 1]; + qmax = max(d__1, d__2); + d__1 = emin, d__2 = z__[i4 - 1]; + emin = min(d__1, d__2); + d__1 = oldemn, d__2 = z__[i4]; + oldemn = min(d__1, d__2); + } + } + z__[(n0 << 2) - 1] = emin; + z__[n0 * 4] = oldemn; + i0 = splt + 1; + } + } + } + *info = 2; + i1 = i0; + n1 = n0; + L145: + tempq = z__[(i0 << 2) - 3]; + z__[(i0 << 2) - 3] += sigma; + i__2 = n0; + for (k = i0 + 1; k <= i__2; ++k) { + tempe = z__[(k << 2) - 5]; + z__[(k << 2) - 5] *= tempq / z__[(k << 2) - 7]; + tempq = z__[(k << 2) - 3]; + z__[(k << 2) - 3] = z__[(k << 2) - 3] + sigma + tempe - z__[(k << 2) - 5]; + } + if (i1 > 1) { + n1 = i1 - 1; + while (i1 >= 2 && z__[(i1 << 2) - 5] >= 0.) { + --i1; + } + sigma = -z__[(n1 << 2) - 1]; + goto L145; + } + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + z__[(k << 1) - 1] = z__[(k << 2) - 3]; + if (k < n0) { + z__[k * 2] = z__[(k << 2) - 1]; + } else { + z__[k * 2] = 0.; + } + } + return 0; + L150:; + } + *info = 3; + return 0; +L170: + i__1 = *n; + for (k = 2; k <= i__1; ++k) { + z__[k] = z__[(k << 2) - 3]; + } + dlasrt_((char *)"D", n, &z__[1], &iinfo, (ftnlen)1); + e = 0.; + for (k = *n; k >= 1; --k) { + e += z__[k]; + } + z__[(*n << 1) + 1] = trace; + z__[(*n << 1) + 2] = e; + z__[(*n << 1) + 3] = (doublereal)iter; + i__1 = *n; + z__[(*n << 1) + 4] = (doublereal)ndiv / (doublereal)(i__1 * i__1); + z__[(*n << 1) + 5] = nfail * 100. / (doublereal)iter; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlasq2.f b/lib/linalg/dlasq2.f deleted file mode 100644 index 608ca7a619..0000000000 --- a/lib/linalg/dlasq2.f +++ /dev/null @@ -1,586 +0,0 @@ -*> \brief \b DLASQ2 computes all the eigenvalues of the symmetric positive definite tridiagonal matrix associated with the qd Array Z to high relative accuracy. Used by sbdsqr and sstegr. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASQ2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLASQ2( N, Z, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION Z( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLASQ2 computes all the eigenvalues of the symmetric positive -*> definite tridiagonal matrix associated with the qd array Z to high -*> relative accuracy are computed to high relative accuracy, in the -*> absence of denormalization, underflow and overflow. -*> -*> To see the relation of Z to the tridiagonal matrix, let L be a -*> unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and -*> let U be an upper bidiagonal matrix with 1's above and diagonal -*> Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the -*> symmetric tridiagonal to which it is similar. -*> -*> Note : DLASQ2 defines a logical variable, IEEE, which is true -*> on machines which follow ieee-754 floating-point standard in their -*> handling of infinities and NaNs, and false otherwise. This variable -*> is passed to DLASQ3. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of rows and columns in the matrix. N >= 0. -*> \endverbatim -*> -*> \param[in,out] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension ( 4*N ) -*> On entry Z holds the qd array. On exit, entries 1 to N hold -*> the eigenvalues in decreasing order, Z( 2*N+1 ) holds the -*> trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If -*> N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 ) -*> holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of -*> shifts that failed. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if the i-th argument is a scalar and had an illegal -*> value, then INFO = -i, if the i-th argument is an -*> array and the j-entry had an illegal value, then -*> INFO = -(i*100+j) -*> > 0: the algorithm failed -*> = 1, a split was marked by a positive value in E -*> = 2, current block of Z not diagonalized after 100*N -*> iterations (in inner while loop). On exit Z holds -*> a qd array with the same eigenvalues as the given Z. -*> = 3, termination criterion of outer while loop not met -*> (program created more than N unreduced blocks) -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Local Variables: I0:N0 defines a current unreduced segment of Z. -*> The shifts are accumulated in SIGMA. Iteration count is in ITER. -*> Ping-pong is controlled by PP (alternates between 0 and 1). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DLASQ2( N, Z, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION Z( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION CBIAS - PARAMETER ( CBIAS = 1.50D0 ) - DOUBLE PRECISION ZERO, HALF, ONE, TWO, FOUR, HUNDRD - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, - $ TWO = 2.0D0, FOUR = 4.0D0, HUNDRD = 100.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL IEEE - INTEGER I0, I1, I4, IINFO, IPN4, ITER, IWHILA, IWHILB, - $ K, KMIN, N0, N1, NBIG, NDIV, NFAIL, PP, SPLT, - $ TTYPE - DOUBLE PRECISION D, DEE, DEEMIN, DESIG, DMIN, DMIN1, DMIN2, DN, - $ DN1, DN2, E, EMAX, EMIN, EPS, G, OLDEMN, QMAX, - $ QMIN, S, SAFMIN, SIGMA, T, TAU, TEMP, TOL, - $ TOL2, TRACE, ZMAX, TEMPE, TEMPQ -* .. -* .. External Subroutines .. - EXTERNAL DLASQ3, DLASRT, XERBLA -* .. -* .. External Functions .. - INTEGER ILAENV - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, ILAENV -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input arguments. -* (in case DLASQ2 is not called by DLASQ1) -* - INFO = 0 - EPS = DLAMCH( 'Precision' ) - SAFMIN = DLAMCH( 'Safe minimum' ) - TOL = EPS*HUNDRD - TOL2 = TOL**2 -* - IF( N.LT.0 ) THEN - INFO = -1 - CALL XERBLA( 'DLASQ2', 1 ) - RETURN - ELSE IF( N.EQ.0 ) THEN - RETURN - ELSE IF( N.EQ.1 ) THEN -* -* 1-by-1 case. -* - IF( Z( 1 ).LT.ZERO ) THEN - INFO = -201 - CALL XERBLA( 'DLASQ2', 2 ) - END IF - RETURN - ELSE IF( N.EQ.2 ) THEN -* -* 2-by-2 case. -* - IF( Z( 1 ).LT.ZERO ) THEN - INFO = -201 - CALL XERBLA( 'DLASQ2', 2 ) - RETURN - ELSE IF( Z( 2 ).LT.ZERO ) THEN - INFO = -202 - CALL XERBLA( 'DLASQ2', 2 ) - RETURN - ELSE IF( Z( 3 ).LT.ZERO ) THEN - INFO = -203 - CALL XERBLA( 'DLASQ2', 2 ) - RETURN - ELSE IF( Z( 3 ).GT.Z( 1 ) ) THEN - D = Z( 3 ) - Z( 3 ) = Z( 1 ) - Z( 1 ) = D - END IF - Z( 5 ) = Z( 1 ) + Z( 2 ) + Z( 3 ) - IF( Z( 2 ).GT.Z( 3 )*TOL2 ) THEN - T = HALF*( ( Z( 1 )-Z( 3 ) )+Z( 2 ) ) - S = Z( 3 )*( Z( 2 ) / T ) - IF( S.LE.T ) THEN - S = Z( 3 )*( Z( 2 ) / ( T*( ONE+SQRT( ONE+S / T ) ) ) ) - ELSE - S = Z( 3 )*( Z( 2 ) / ( T+SQRT( T )*SQRT( T+S ) ) ) - END IF - T = Z( 1 ) + ( S+Z( 2 ) ) - Z( 3 ) = Z( 3 )*( Z( 1 ) / T ) - Z( 1 ) = T - END IF - Z( 2 ) = Z( 3 ) - Z( 6 ) = Z( 2 ) + Z( 1 ) - RETURN - END IF -* -* Check for negative data and compute sums of q's and e's. -* - Z( 2*N ) = ZERO - EMIN = Z( 2 ) - QMAX = ZERO - ZMAX = ZERO - D = ZERO - E = ZERO -* - DO 10 K = 1, 2*( N-1 ), 2 - IF( Z( K ).LT.ZERO ) THEN - INFO = -( 200+K ) - CALL XERBLA( 'DLASQ2', 2 ) - RETURN - ELSE IF( Z( K+1 ).LT.ZERO ) THEN - INFO = -( 200+K+1 ) - CALL XERBLA( 'DLASQ2', 2 ) - RETURN - END IF - D = D + Z( K ) - E = E + Z( K+1 ) - QMAX = MAX( QMAX, Z( K ) ) - EMIN = MIN( EMIN, Z( K+1 ) ) - ZMAX = MAX( QMAX, ZMAX, Z( K+1 ) ) - 10 CONTINUE - IF( Z( 2*N-1 ).LT.ZERO ) THEN - INFO = -( 200+2*N-1 ) - CALL XERBLA( 'DLASQ2', 2 ) - RETURN - END IF - D = D + Z( 2*N-1 ) - QMAX = MAX( QMAX, Z( 2*N-1 ) ) - ZMAX = MAX( QMAX, ZMAX ) -* -* Check for diagonality. -* - IF( E.EQ.ZERO ) THEN - DO 20 K = 2, N - Z( K ) = Z( 2*K-1 ) - 20 CONTINUE - CALL DLASRT( 'D', N, Z, IINFO ) - Z( 2*N-1 ) = D - RETURN - END IF -* - TRACE = D + E -* -* Check for zero data. -* - IF( TRACE.EQ.ZERO ) THEN - Z( 2*N-1 ) = ZERO - RETURN - END IF -* -* Check whether the machine is IEEE conformable. -* - IEEE = ( ILAENV( 10, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 ) -* -* Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...). -* - DO 30 K = 2*N, 2, -2 - Z( 2*K ) = ZERO - Z( 2*K-1 ) = Z( K ) - Z( 2*K-2 ) = ZERO - Z( 2*K-3 ) = Z( K-1 ) - 30 CONTINUE -* - I0 = 1 - N0 = N -* -* Reverse the qd-array, if warranted. -* - IF( CBIAS*Z( 4*I0-3 ).LT.Z( 4*N0-3 ) ) THEN - IPN4 = 4*( I0+N0 ) - DO 40 I4 = 4*I0, 2*( I0+N0-1 ), 4 - TEMP = Z( I4-3 ) - Z( I4-3 ) = Z( IPN4-I4-3 ) - Z( IPN4-I4-3 ) = TEMP - TEMP = Z( I4-1 ) - Z( I4-1 ) = Z( IPN4-I4-5 ) - Z( IPN4-I4-5 ) = TEMP - 40 CONTINUE - END IF -* -* Initial split checking via dqd and Li's test. -* - PP = 0 -* - DO 80 K = 1, 2 -* - D = Z( 4*N0+PP-3 ) - DO 50 I4 = 4*( N0-1 ) + PP, 4*I0 + PP, -4 - IF( Z( I4-1 ).LE.TOL2*D ) THEN - Z( I4-1 ) = -ZERO - D = Z( I4-3 ) - ELSE - D = Z( I4-3 )*( D / ( D+Z( I4-1 ) ) ) - END IF - 50 CONTINUE -* -* dqd maps Z to ZZ plus Li's test. -* - EMIN = Z( 4*I0+PP+1 ) - D = Z( 4*I0+PP-3 ) - DO 60 I4 = 4*I0 + PP, 4*( N0-1 ) + PP, 4 - Z( I4-2*PP-2 ) = D + Z( I4-1 ) - IF( Z( I4-1 ).LE.TOL2*D ) THEN - Z( I4-1 ) = -ZERO - Z( I4-2*PP-2 ) = D - Z( I4-2*PP ) = ZERO - D = Z( I4+1 ) - ELSE IF( SAFMIN*Z( I4+1 ).LT.Z( I4-2*PP-2 ) .AND. - $ SAFMIN*Z( I4-2*PP-2 ).LT.Z( I4+1 ) ) THEN - TEMP = Z( I4+1 ) / Z( I4-2*PP-2 ) - Z( I4-2*PP ) = Z( I4-1 )*TEMP - D = D*TEMP - ELSE - Z( I4-2*PP ) = Z( I4+1 )*( Z( I4-1 ) / Z( I4-2*PP-2 ) ) - D = Z( I4+1 )*( D / Z( I4-2*PP-2 ) ) - END IF - EMIN = MIN( EMIN, Z( I4-2*PP ) ) - 60 CONTINUE - Z( 4*N0-PP-2 ) = D -* -* Now find qmax. -* - QMAX = Z( 4*I0-PP-2 ) - DO 70 I4 = 4*I0 - PP + 2, 4*N0 - PP - 2, 4 - QMAX = MAX( QMAX, Z( I4 ) ) - 70 CONTINUE -* -* Prepare for the next iteration on K. -* - PP = 1 - PP - 80 CONTINUE -* -* Initialise variables to pass to DLASQ3. -* - TTYPE = 0 - DMIN1 = ZERO - DMIN2 = ZERO - DN = ZERO - DN1 = ZERO - DN2 = ZERO - G = ZERO - TAU = ZERO -* - ITER = 2 - NFAIL = 0 - NDIV = 2*( N0-I0 ) -* - DO 160 IWHILA = 1, N + 1 - IF( N0.LT.1 ) - $ GO TO 170 -* -* While array unfinished do -* -* E(N0) holds the value of SIGMA when submatrix in I0:N0 -* splits from the rest of the array, but is negated. -* - DESIG = ZERO - IF( N0.EQ.N ) THEN - SIGMA = ZERO - ELSE - SIGMA = -Z( 4*N0-1 ) - END IF - IF( SIGMA.LT.ZERO ) THEN - INFO = 1 - RETURN - END IF -* -* Find last unreduced submatrix's top index I0, find QMAX and -* EMIN. Find Gershgorin-type bound if Q's much greater than E's. -* - EMAX = ZERO - IF( N0.GT.I0 ) THEN - EMIN = ABS( Z( 4*N0-5 ) ) - ELSE - EMIN = ZERO - END IF - QMIN = Z( 4*N0-3 ) - QMAX = QMIN - DO 90 I4 = 4*N0, 8, -4 - IF( Z( I4-5 ).LE.ZERO ) - $ GO TO 100 - IF( QMIN.GE.FOUR*EMAX ) THEN - QMIN = MIN( QMIN, Z( I4-3 ) ) - EMAX = MAX( EMAX, Z( I4-5 ) ) - END IF - QMAX = MAX( QMAX, Z( I4-7 )+Z( I4-5 ) ) - EMIN = MIN( EMIN, Z( I4-5 ) ) - 90 CONTINUE - I4 = 4 -* - 100 CONTINUE - I0 = I4 / 4 - PP = 0 -* - IF( N0-I0.GT.1 ) THEN - DEE = Z( 4*I0-3 ) - DEEMIN = DEE - KMIN = I0 - DO 110 I4 = 4*I0+1, 4*N0-3, 4 - DEE = Z( I4 )*( DEE /( DEE+Z( I4-2 ) ) ) - IF( DEE.LE.DEEMIN ) THEN - DEEMIN = DEE - KMIN = ( I4+3 )/4 - END IF - 110 CONTINUE - IF( (KMIN-I0)*2.LT.N0-KMIN .AND. - $ DEEMIN.LE.HALF*Z(4*N0-3) ) THEN - IPN4 = 4*( I0+N0 ) - PP = 2 - DO 120 I4 = 4*I0, 2*( I0+N0-1 ), 4 - TEMP = Z( I4-3 ) - Z( I4-3 ) = Z( IPN4-I4-3 ) - Z( IPN4-I4-3 ) = TEMP - TEMP = Z( I4-2 ) - Z( I4-2 ) = Z( IPN4-I4-2 ) - Z( IPN4-I4-2 ) = TEMP - TEMP = Z( I4-1 ) - Z( I4-1 ) = Z( IPN4-I4-5 ) - Z( IPN4-I4-5 ) = TEMP - TEMP = Z( I4 ) - Z( I4 ) = Z( IPN4-I4-4 ) - Z( IPN4-I4-4 ) = TEMP - 120 CONTINUE - END IF - END IF -* -* Put -(initial shift) into DMIN. -* - DMIN = -MAX( ZERO, QMIN-TWO*SQRT( QMIN )*SQRT( EMAX ) ) -* -* Now I0:N0 is unreduced. -* PP = 0 for ping, PP = 1 for pong. -* PP = 2 indicates that flipping was applied to the Z array and -* and that the tests for deflation upon entry in DLASQ3 -* should not be performed. -* - NBIG = 100*( N0-I0+1 ) - DO 140 IWHILB = 1, NBIG - IF( I0.GT.N0 ) - $ GO TO 150 -* -* While submatrix unfinished take a good dqds step. -* - CALL DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, - $ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, - $ DN2, G, TAU ) -* - PP = 1 - PP -* -* When EMIN is very small check for splits. -* - IF( PP.EQ.0 .AND. N0-I0.GE.3 ) THEN - IF( Z( 4*N0 ).LE.TOL2*QMAX .OR. - $ Z( 4*N0-1 ).LE.TOL2*SIGMA ) THEN - SPLT = I0 - 1 - QMAX = Z( 4*I0-3 ) - EMIN = Z( 4*I0-1 ) - OLDEMN = Z( 4*I0 ) - DO 130 I4 = 4*I0, 4*( N0-3 ), 4 - IF( Z( I4 ).LE.TOL2*Z( I4-3 ) .OR. - $ Z( I4-1 ).LE.TOL2*SIGMA ) THEN - Z( I4-1 ) = -SIGMA - SPLT = I4 / 4 - QMAX = ZERO - EMIN = Z( I4+3 ) - OLDEMN = Z( I4+4 ) - ELSE - QMAX = MAX( QMAX, Z( I4+1 ) ) - EMIN = MIN( EMIN, Z( I4-1 ) ) - OLDEMN = MIN( OLDEMN, Z( I4 ) ) - END IF - 130 CONTINUE - Z( 4*N0-1 ) = EMIN - Z( 4*N0 ) = OLDEMN - I0 = SPLT + 1 - END IF - END IF -* - 140 CONTINUE -* - INFO = 2 -* -* Maximum number of iterations exceeded, restore the shift -* SIGMA and place the new d's and e's in a qd array. -* This might need to be done for several blocks -* - I1 = I0 - N1 = N0 - 145 CONTINUE - TEMPQ = Z( 4*I0-3 ) - Z( 4*I0-3 ) = Z( 4*I0-3 ) + SIGMA - DO K = I0+1, N0 - TEMPE = Z( 4*K-5 ) - Z( 4*K-5 ) = Z( 4*K-5 ) * (TEMPQ / Z( 4*K-7 )) - TEMPQ = Z( 4*K-3 ) - Z( 4*K-3 ) = Z( 4*K-3 ) + SIGMA + TEMPE - Z( 4*K-5 ) - END DO -* -* Prepare to do this on the previous block if there is one -* - IF( I1.GT.1 ) THEN - N1 = I1-1 - DO WHILE( ( I1.GE.2 ) .AND. ( Z(4*I1-5).GE.ZERO ) ) - I1 = I1 - 1 - END DO - SIGMA = -Z(4*N1-1) - GO TO 145 - END IF - - DO K = 1, N - Z( 2*K-1 ) = Z( 4*K-3 ) -* -* Only the block 1..N0 is unfinished. The rest of the e's -* must be essentially zero, although sometimes other data -* has been stored in them. -* - IF( K.LT.N0 ) THEN - Z( 2*K ) = Z( 4*K-1 ) - ELSE - Z( 2*K ) = 0 - END IF - END DO - RETURN -* -* end IWHILB -* - 150 CONTINUE -* - 160 CONTINUE -* - INFO = 3 - RETURN -* -* end IWHILA -* - 170 CONTINUE -* -* Move q's to the front. -* - DO 180 K = 2, N - Z( K ) = Z( 4*K-3 ) - 180 CONTINUE -* -* Sort and compute sum of eigenvalues. -* - CALL DLASRT( 'D', N, Z, IINFO ) -* - E = ZERO - DO 190 K = N, 1, -1 - E = E + Z( K ) - 190 CONTINUE -* -* Store trace, sum(eigenvalues) and information on performance. -* - Z( 2*N+1 ) = TRACE - Z( 2*N+2 ) = E - Z( 2*N+3 ) = DBLE( ITER ) - Z( 2*N+4 ) = DBLE( NDIV ) / DBLE( N**2 ) - Z( 2*N+5 ) = HUNDRD*NFAIL / DBLE( ITER ) - RETURN -* -* End of DLASQ2 -* - END diff --git a/lib/linalg/dlasq3.cpp b/lib/linalg/dlasq3.cpp new file mode 100644 index 0000000000..62819cf77f --- /dev/null +++ b/lib/linalg/dlasq3.cpp @@ -0,0 +1,172 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dlasq3_(integer *i0, integer *n0, doublereal *z__, integer *pp, doublereal *dmin__, + doublereal *sigma, doublereal *desig, doublereal *qmax, integer *nfail, integer *iter, + integer *ndiv, logical *ieee, integer *ttype, doublereal *dmin1, doublereal *dmin2, + doublereal *dn, doublereal *dn1, doublereal *dn2, doublereal *g, doublereal *tau) +{ + integer i__1; + doublereal d__1, d__2; + double sqrt(doublereal); + doublereal s, t; + integer j4, nn; + doublereal eps, tol; + integer n0in, ipn4; + doublereal tol2, temp; + extern int dlasq4_(integer *, integer *, doublereal *, integer *, integer *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *, doublereal *), + dlasq5_(integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, + logical *, doublereal *), + dlasq6_(integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *); + extern doublereal dlamch_(char *, ftnlen); + extern logical disnan_(doublereal *); + --z__; + n0in = *n0; + eps = dlamch_((char *)"Precision", (ftnlen)9); + tol = eps * 100.; + d__1 = tol; + tol2 = d__1 * d__1; +L10: + if (*n0 < *i0) { + return 0; + } + if (*n0 == *i0) { + goto L20; + } + nn = (*n0 << 2) + *pp; + if (*n0 == *i0 + 1) { + goto L40; + } + if (z__[nn - 5] > tol2 * (*sigma + z__[nn - 3]) && + z__[nn - (*pp << 1) - 4] > tol2 * z__[nn - 7]) { + goto L30; + } +L20: + z__[(*n0 << 2) - 3] = z__[(*n0 << 2) + *pp - 3] + *sigma; + --(*n0); + goto L10; +L30: + if (z__[nn - 9] > tol2 * *sigma && z__[nn - (*pp << 1) - 8] > tol2 * z__[nn - 11]) { + goto L50; + } +L40: + if (z__[nn - 3] > z__[nn - 7]) { + s = z__[nn - 3]; + z__[nn - 3] = z__[nn - 7]; + z__[nn - 7] = s; + } + t = (z__[nn - 7] - z__[nn - 3] + z__[nn - 5]) * .5; + if (z__[nn - 5] > z__[nn - 3] * tol2 && t != 0.) { + s = z__[nn - 3] * (z__[nn - 5] / t); + if (s <= t) { + s = z__[nn - 3] * (z__[nn - 5] / (t * (sqrt(s / t + 1.) + 1.))); + } else { + s = z__[nn - 3] * (z__[nn - 5] / (t + sqrt(t) * sqrt(t + s))); + } + t = z__[nn - 7] + (s + z__[nn - 5]); + z__[nn - 3] *= z__[nn - 7] / t; + z__[nn - 7] = t; + } + z__[(*n0 << 2) - 7] = z__[nn - 7] + *sigma; + z__[(*n0 << 2) - 3] = z__[nn - 3] + *sigma; + *n0 += -2; + goto L10; +L50: + if (*pp == 2) { + *pp = 0; + } + if (*dmin__ <= 0. || *n0 < n0in) { + if (z__[(*i0 << 2) + *pp - 3] * 1.5 < z__[(*n0 << 2) + *pp - 3]) { + ipn4 = *i0 + *n0 << 2; + i__1 = *i0 + *n0 - 1 << 1; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + temp = z__[j4 - 3]; + z__[j4 - 3] = z__[ipn4 - j4 - 3]; + z__[ipn4 - j4 - 3] = temp; + temp = z__[j4 - 2]; + z__[j4 - 2] = z__[ipn4 - j4 - 2]; + z__[ipn4 - j4 - 2] = temp; + temp = z__[j4 - 1]; + z__[j4 - 1] = z__[ipn4 - j4 - 5]; + z__[ipn4 - j4 - 5] = temp; + temp = z__[j4]; + z__[j4] = z__[ipn4 - j4 - 4]; + z__[ipn4 - j4 - 4] = temp; + } + if (*n0 - *i0 <= 4) { + z__[(*n0 << 2) + *pp - 1] = z__[(*i0 << 2) + *pp - 1]; + z__[(*n0 << 2) - *pp] = z__[(*i0 << 2) - *pp]; + } + d__1 = *dmin2, d__2 = z__[(*n0 << 2) + *pp - 1]; + *dmin2 = min(d__1, d__2); + d__1 = z__[(*n0 << 2) + *pp - 1], d__2 = z__[(*i0 << 2) + *pp - 1], + d__1 = min(d__1, d__2), d__2 = z__[(*i0 << 2) + *pp + 3]; + z__[(*n0 << 2) + *pp - 1] = min(d__1, d__2); + d__1 = z__[(*n0 << 2) - *pp], d__2 = z__[(*i0 << 2) - *pp], d__1 = min(d__1, d__2), + d__2 = z__[(*i0 << 2) - *pp + 4]; + z__[(*n0 << 2) - *pp] = min(d__1, d__2); + d__1 = *qmax, d__2 = z__[(*i0 << 2) + *pp - 3], d__1 = max(d__1, d__2), + d__2 = z__[(*i0 << 2) + *pp + 1]; + *qmax = max(d__1, d__2); + *dmin__ = -0.; + } + } + dlasq4_(i0, n0, &z__[1], pp, &n0in, dmin__, dmin1, dmin2, dn, dn1, dn2, tau, ttype, g); +L70: + dlasq5_(i0, n0, &z__[1], pp, tau, sigma, dmin__, dmin1, dmin2, dn, dn1, dn2, ieee, &eps); + *ndiv += *n0 - *i0 + 2; + ++(*iter); + if (*dmin__ >= 0. && *dmin1 >= 0.) { + goto L90; + } else if (*dmin__ < 0. && *dmin1 > 0. && z__[(*n0 - 1 << 2) - *pp] < tol * (*sigma + *dn1) && + abs(*dn) < tol * *sigma) { + z__[(*n0 - 1 << 2) - *pp + 2] = 0.; + *dmin__ = 0.; + goto L90; + } else if (*dmin__ < 0.) { + ++(*nfail); + if (*ttype < -22) { + *tau = 0.; + } else if (*dmin1 > 0.) { + *tau = (*tau + *dmin__) * (1. - eps * 2.); + *ttype += -11; + } else { + *tau *= .25; + *ttype += -12; + } + goto L70; + } else if (disnan_(dmin__)) { + if (*tau == 0.) { + goto L80; + } else { + *tau = 0.; + goto L70; + } + } else { + goto L80; + } +L80: + dlasq6_(i0, n0, &z__[1], pp, dmin__, dmin1, dmin2, dn, dn1, dn2); + *ndiv += *n0 - *i0 + 2; + ++(*iter); + *tau = 0.; +L90: + if (*tau < *sigma) { + *desig += *tau; + t = *sigma + *desig; + *desig -= t - *sigma; + } else { + t = *sigma + *tau; + *desig = *sigma - (t - *tau) + *desig; + } + *sigma = t; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlasq3.f b/lib/linalg/dlasq3.f deleted file mode 100644 index e4bdafe06e..0000000000 --- a/lib/linalg/dlasq3.f +++ /dev/null @@ -1,418 +0,0 @@ -*> \brief \b DLASQ3 checks for deflation, computes a shift and calls dqds. Used by sbdsqr. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASQ3 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, -* ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, -* DN2, G, TAU ) -* -* .. Scalar Arguments .. -* LOGICAL IEEE -* INTEGER I0, ITER, N0, NDIV, NFAIL, PP -* DOUBLE PRECISION DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, -* $ QMAX, SIGMA, TAU -* .. -* .. Array Arguments .. -* DOUBLE PRECISION Z( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLASQ3 checks for deflation, computes a shift (TAU) and calls dqds. -*> In case of failure it changes shifts, and tries again until output -*> is positive. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] I0 -*> \verbatim -*> I0 is INTEGER -*> First index. -*> \endverbatim -*> -*> \param[in,out] N0 -*> \verbatim -*> N0 is INTEGER -*> Last index. -*> \endverbatim -*> -*> \param[in,out] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension ( 4*N0 ) -*> Z holds the qd array. -*> \endverbatim -*> -*> \param[in,out] PP -*> \verbatim -*> PP is INTEGER -*> PP=0 for ping, PP=1 for pong. -*> PP=2 indicates that flipping was applied to the Z array -*> and that the initial tests for deflation should not be -*> performed. -*> \endverbatim -*> -*> \param[out] DMIN -*> \verbatim -*> DMIN is DOUBLE PRECISION -*> Minimum value of d. -*> \endverbatim -*> -*> \param[out] SIGMA -*> \verbatim -*> SIGMA is DOUBLE PRECISION -*> Sum of shifts used in current segment. -*> \endverbatim -*> -*> \param[in,out] DESIG -*> \verbatim -*> DESIG is DOUBLE PRECISION -*> Lower order part of SIGMA -*> \endverbatim -*> -*> \param[in] QMAX -*> \verbatim -*> QMAX is DOUBLE PRECISION -*> Maximum value of q. -*> \endverbatim -*> -*> \param[in,out] NFAIL -*> \verbatim -*> NFAIL is INTEGER -*> Increment NFAIL by 1 each time the shift was too big. -*> \endverbatim -*> -*> \param[in,out] ITER -*> \verbatim -*> ITER is INTEGER -*> Increment ITER by 1 for each iteration. -*> \endverbatim -*> -*> \param[in,out] NDIV -*> \verbatim -*> NDIV is INTEGER -*> Increment NDIV by 1 for each division. -*> \endverbatim -*> -*> \param[in] IEEE -*> \verbatim -*> IEEE is LOGICAL -*> Flag for IEEE or non IEEE arithmetic (passed to DLASQ5). -*> \endverbatim -*> -*> \param[in,out] TTYPE -*> \verbatim -*> TTYPE is INTEGER -*> Shift type. -*> \endverbatim -*> -*> \param[in,out] DMIN1 -*> \verbatim -*> DMIN1 is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in,out] DMIN2 -*> \verbatim -*> DMIN2 is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in,out] DN -*> \verbatim -*> DN is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in,out] DN1 -*> \verbatim -*> DN1 is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in,out] DN2 -*> \verbatim -*> DN2 is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in,out] G -*> \verbatim -*> G is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in,out] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION -*> -*> These are passed as arguments in order to save their values -*> between calls to DLASQ3. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -* ===================================================================== - SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, - $ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, - $ DN2, G, TAU ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - LOGICAL IEEE - INTEGER I0, ITER, N0, NDIV, NFAIL, PP - DOUBLE PRECISION DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, - $ QMAX, SIGMA, TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION Z( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION CBIAS - PARAMETER ( CBIAS = 1.50D0 ) - DOUBLE PRECISION ZERO, QURTR, HALF, ONE, TWO, HUNDRD - PARAMETER ( ZERO = 0.0D0, QURTR = 0.250D0, HALF = 0.5D0, - $ ONE = 1.0D0, TWO = 2.0D0, HUNDRD = 100.0D0 ) -* .. -* .. Local Scalars .. - INTEGER IPN4, J4, N0IN, NN, TTYPE - DOUBLE PRECISION EPS, S, T, TEMP, TOL, TOL2 -* .. -* .. External Subroutines .. - EXTERNAL DLASQ4, DLASQ5, DLASQ6 -* .. -* .. External Function .. - DOUBLE PRECISION DLAMCH - LOGICAL DISNAN - EXTERNAL DISNAN, DLAMCH -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - N0IN = N0 - EPS = DLAMCH( 'Precision' ) - TOL = EPS*HUNDRD - TOL2 = TOL**2 -* -* Check for deflation. -* - 10 CONTINUE -* - IF( N0.LT.I0 ) - $ RETURN - IF( N0.EQ.I0 ) - $ GO TO 20 - NN = 4*N0 + PP - IF( N0.EQ.( I0+1 ) ) - $ GO TO 40 -* -* Check whether E(N0-1) is negligible, 1 eigenvalue. -* - IF( Z( NN-5 ).GT.TOL2*( SIGMA+Z( NN-3 ) ) .AND. - $ Z( NN-2*PP-4 ).GT.TOL2*Z( NN-7 ) ) - $ GO TO 30 -* - 20 CONTINUE -* - Z( 4*N0-3 ) = Z( 4*N0+PP-3 ) + SIGMA - N0 = N0 - 1 - GO TO 10 -* -* Check whether E(N0-2) is negligible, 2 eigenvalues. -* - 30 CONTINUE -* - IF( Z( NN-9 ).GT.TOL2*SIGMA .AND. - $ Z( NN-2*PP-8 ).GT.TOL2*Z( NN-11 ) ) - $ GO TO 50 -* - 40 CONTINUE -* - IF( Z( NN-3 ).GT.Z( NN-7 ) ) THEN - S = Z( NN-3 ) - Z( NN-3 ) = Z( NN-7 ) - Z( NN-7 ) = S - END IF - T = HALF*( ( Z( NN-7 )-Z( NN-3 ) )+Z( NN-5 ) ) - IF( Z( NN-5 ).GT.Z( NN-3 )*TOL2.AND.T.NE.ZERO ) THEN - S = Z( NN-3 )*( Z( NN-5 ) / T ) - IF( S.LE.T ) THEN - S = Z( NN-3 )*( Z( NN-5 ) / - $ ( T*( ONE+SQRT( ONE+S / T ) ) ) ) - ELSE - S = Z( NN-3 )*( Z( NN-5 ) / ( T+SQRT( T )*SQRT( T+S ) ) ) - END IF - T = Z( NN-7 ) + ( S+Z( NN-5 ) ) - Z( NN-3 ) = Z( NN-3 )*( Z( NN-7 ) / T ) - Z( NN-7 ) = T - END IF - Z( 4*N0-7 ) = Z( NN-7 ) + SIGMA - Z( 4*N0-3 ) = Z( NN-3 ) + SIGMA - N0 = N0 - 2 - GO TO 10 -* - 50 CONTINUE - IF( PP.EQ.2 ) - $ PP = 0 -* -* Reverse the qd-array, if warranted. -* - IF( DMIN.LE.ZERO .OR. N0.LT.N0IN ) THEN - IF( CBIAS*Z( 4*I0+PP-3 ).LT.Z( 4*N0+PP-3 ) ) THEN - IPN4 = 4*( I0+N0 ) - DO 60 J4 = 4*I0, 2*( I0+N0-1 ), 4 - TEMP = Z( J4-3 ) - Z( J4-3 ) = Z( IPN4-J4-3 ) - Z( IPN4-J4-3 ) = TEMP - TEMP = Z( J4-2 ) - Z( J4-2 ) = Z( IPN4-J4-2 ) - Z( IPN4-J4-2 ) = TEMP - TEMP = Z( J4-1 ) - Z( J4-1 ) = Z( IPN4-J4-5 ) - Z( IPN4-J4-5 ) = TEMP - TEMP = Z( J4 ) - Z( J4 ) = Z( IPN4-J4-4 ) - Z( IPN4-J4-4 ) = TEMP - 60 CONTINUE - IF( N0-I0.LE.4 ) THEN - Z( 4*N0+PP-1 ) = Z( 4*I0+PP-1 ) - Z( 4*N0-PP ) = Z( 4*I0-PP ) - END IF - DMIN2 = MIN( DMIN2, Z( 4*N0+PP-1 ) ) - Z( 4*N0+PP-1 ) = MIN( Z( 4*N0+PP-1 ), Z( 4*I0+PP-1 ), - $ Z( 4*I0+PP+3 ) ) - Z( 4*N0-PP ) = MIN( Z( 4*N0-PP ), Z( 4*I0-PP ), - $ Z( 4*I0-PP+4 ) ) - QMAX = MAX( QMAX, Z( 4*I0+PP-3 ), Z( 4*I0+PP+1 ) ) - DMIN = -ZERO - END IF - END IF -* -* Choose a shift. -* - CALL DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1, - $ DN2, TAU, TTYPE, G ) -* -* Call dqds until DMIN > 0. -* - 70 CONTINUE -* - CALL DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, DN, - $ DN1, DN2, IEEE, EPS ) -* - NDIV = NDIV + ( N0-I0+2 ) - ITER = ITER + 1 -* -* Check status. -* - IF( DMIN.GE.ZERO .AND. DMIN1.GE.ZERO ) THEN -* -* Success. -* - GO TO 90 -* - ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND. - $ Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND. - $ ABS( DN ).LT.TOL*SIGMA ) THEN -* -* Convergence hidden by negative DN. -* - Z( 4*( N0-1 )-PP+2 ) = ZERO - DMIN = ZERO - GO TO 90 - ELSE IF( DMIN.LT.ZERO ) THEN -* -* TAU too big. Select new TAU and try again. -* - NFAIL = NFAIL + 1 - IF( TTYPE.LT.-22 ) THEN -* -* Failed twice. Play it safe. -* - TAU = ZERO - ELSE IF( DMIN1.GT.ZERO ) THEN -* -* Late failure. Gives excellent shift. -* - TAU = ( TAU+DMIN )*( ONE-TWO*EPS ) - TTYPE = TTYPE - 11 - ELSE -* -* Early failure. Divide by 4. -* - TAU = QURTR*TAU - TTYPE = TTYPE - 12 - END IF - GO TO 70 - ELSE IF( DISNAN( DMIN ) ) THEN -* -* NaN. -* - IF( TAU.EQ.ZERO ) THEN - GO TO 80 - ELSE - TAU = ZERO - GO TO 70 - END IF - ELSE -* -* Possible underflow. Play it safe. -* - GO TO 80 - END IF -* -* Risk of underflow. -* - 80 CONTINUE - CALL DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DN1, DN2 ) - NDIV = NDIV + ( N0-I0+2 ) - ITER = ITER + 1 - TAU = ZERO -* - 90 CONTINUE - IF( TAU.LT.SIGMA ) THEN - DESIG = DESIG + TAU - T = SIGMA + DESIG - DESIG = DESIG - ( T-SIGMA ) - ELSE - T = SIGMA + TAU - DESIG = SIGMA - ( T-TAU ) + DESIG - END IF - SIGMA = T -* - RETURN -* -* End of DLASQ3 -* - END diff --git a/lib/linalg/dlasq4.cpp b/lib/linalg/dlasq4.cpp new file mode 100644 index 0000000000..524c89a2ac --- /dev/null +++ b/lib/linalg/dlasq4.cpp @@ -0,0 +1,235 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dlasq4_(integer *i0, integer *n0, doublereal *z__, integer *pp, integer *n0in, + doublereal *dmin__, doublereal *dmin1, doublereal *dmin2, doublereal *dn, + doublereal *dn1, doublereal *dn2, doublereal *tau, integer *ttype, doublereal *g) +{ + integer i__1; + doublereal d__1, d__2; + double sqrt(doublereal); + doublereal s, a2, b1, b2; + integer i4, nn, np; + doublereal gam, gap1, gap2; + --z__; + if (*dmin__ <= 0.) { + *tau = -(*dmin__); + *ttype = -1; + return 0; + } + nn = (*n0 << 2) + *pp; + if (*n0in == *n0) { + if (*dmin__ == *dn || *dmin__ == *dn1) { + b1 = sqrt(z__[nn - 3]) * sqrt(z__[nn - 5]); + b2 = sqrt(z__[nn - 7]) * sqrt(z__[nn - 9]); + a2 = z__[nn - 7] + z__[nn - 5]; + if (*dmin__ == *dn && *dmin1 == *dn1) { + gap2 = *dmin2 - a2 - *dmin2 * .25; + if (gap2 > 0. && gap2 > b2) { + gap1 = a2 - *dn - b2 / gap2 * b2; + } else { + gap1 = a2 - *dn - (b1 + b2); + } + if (gap1 > 0. && gap1 > b1) { + d__1 = *dn - b1 / gap1 * b1, d__2 = *dmin__ * .5; + s = max(d__1, d__2); + *ttype = -2; + } else { + s = 0.; + if (*dn > b1) { + s = *dn - b1; + } + if (a2 > b1 + b2) { + d__1 = s, d__2 = a2 - (b1 + b2); + s = min(d__1, d__2); + } + d__1 = s, d__2 = *dmin__ * .333; + s = max(d__1, d__2); + *ttype = -3; + } + } else { + *ttype = -4; + s = *dmin__ * .25; + if (*dmin__ == *dn) { + gam = *dn; + a2 = 0.; + if (z__[nn - 5] > z__[nn - 7]) { + return 0; + } + b2 = z__[nn - 5] / z__[nn - 7]; + np = nn - 9; + } else { + np = nn - (*pp << 1); + gam = *dn1; + if (z__[np - 4] > z__[np - 2]) { + return 0; + } + a2 = z__[np - 4] / z__[np - 2]; + if (z__[nn - 9] > z__[nn - 11]) { + return 0; + } + b2 = z__[nn - 9] / z__[nn - 11]; + np = nn - 13; + } + a2 += b2; + i__1 = (*i0 << 2) - 1 + *pp; + for (i4 = np; i4 >= i__1; i4 += -4) { + if (b2 == 0.) { + goto L20; + } + b1 = b2; + if (z__[i4] > z__[i4 - 2]) { + return 0; + } + b2 *= z__[i4] / z__[i4 - 2]; + a2 += b2; + if (max(b2, b1) * 100. < a2 || .563 < a2) { + goto L20; + } + } + L20: + a2 *= 1.05; + if (a2 < .563) { + s = gam * (1. - sqrt(a2)) / (a2 + 1.); + } + } + } else if (*dmin__ == *dn2) { + *ttype = -5; + s = *dmin__ * .25; + np = nn - (*pp << 1); + b1 = z__[np - 2]; + b2 = z__[np - 6]; + gam = *dn2; + if (z__[np - 8] > b2 || z__[np - 4] > b1) { + return 0; + } + a2 = z__[np - 8] / b2 * (z__[np - 4] / b1 + 1.); + if (*n0 - *i0 > 2) { + b2 = z__[nn - 13] / z__[nn - 15]; + a2 += b2; + i__1 = (*i0 << 2) - 1 + *pp; + for (i4 = nn - 17; i4 >= i__1; i4 += -4) { + if (b2 == 0.) { + goto L40; + } + b1 = b2; + if (z__[i4] > z__[i4 - 2]) { + return 0; + } + b2 *= z__[i4] / z__[i4 - 2]; + a2 += b2; + if (max(b2, b1) * 100. < a2 || .563 < a2) { + goto L40; + } + } + L40: + a2 *= 1.05; + } + if (a2 < .563) { + s = gam * (1. - sqrt(a2)) / (a2 + 1.); + } + } else { + if (*ttype == -6) { + *g += (1. - *g) * .333; + } else if (*ttype == -18) { + *g = .083250000000000005; + } else { + *g = .25; + } + s = *g * *dmin__; + *ttype = -6; + } + } else if (*n0in == *n0 + 1) { + if (*dmin1 == *dn1 && *dmin2 == *dn2) { + *ttype = -7; + s = *dmin1 * .333; + if (z__[nn - 5] > z__[nn - 7]) { + return 0; + } + b1 = z__[nn - 5] / z__[nn - 7]; + b2 = b1; + if (b2 == 0.) { + goto L60; + } + i__1 = (*i0 << 2) - 1 + *pp; + for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) { + a2 = b1; + if (z__[i4] > z__[i4 - 2]) { + return 0; + } + b1 *= z__[i4] / z__[i4 - 2]; + b2 += b1; + if (max(b1, a2) * 100. < b2) { + goto L60; + } + } + L60: + b2 = sqrt(b2 * 1.05); + d__1 = b2; + a2 = *dmin1 / (d__1 * d__1 + 1.); + gap2 = *dmin2 * .5 - a2; + if (gap2 > 0. && gap2 > b2 * a2) { + d__1 = s, d__2 = a2 * (1. - a2 * 1.01 * (b2 / gap2) * b2); + s = max(d__1, d__2); + } else { + d__1 = s, d__2 = a2 * (1. - b2 * 1.01); + s = max(d__1, d__2); + *ttype = -8; + } + } else { + s = *dmin1 * .25; + if (*dmin1 == *dn1) { + s = *dmin1 * .5; + } + *ttype = -9; + } + } else if (*n0in == *n0 + 2) { + if (*dmin2 == *dn2 && z__[nn - 5] * 2. < z__[nn - 7]) { + *ttype = -10; + s = *dmin2 * .333; + if (z__[nn - 5] > z__[nn - 7]) { + return 0; + } + b1 = z__[nn - 5] / z__[nn - 7]; + b2 = b1; + if (b2 == 0.) { + goto L80; + } + i__1 = (*i0 << 2) - 1 + *pp; + for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) { + if (z__[i4] > z__[i4 - 2]) { + return 0; + } + b1 *= z__[i4] / z__[i4 - 2]; + b2 += b1; + if (b1 * 100. < b2) { + goto L80; + } + } + L80: + b2 = sqrt(b2 * 1.05); + d__1 = b2; + a2 = *dmin2 / (d__1 * d__1 + 1.); + gap2 = z__[nn - 7] + z__[nn - 9] - sqrt(z__[nn - 11]) * sqrt(z__[nn - 9]) - a2; + if (gap2 > 0. && gap2 > b2 * a2) { + d__1 = s, d__2 = a2 * (1. - a2 * 1.01 * (b2 / gap2) * b2); + s = max(d__1, d__2); + } else { + d__1 = s, d__2 = a2 * (1. - b2 * 1.01); + s = max(d__1, d__2); + } + } else { + s = *dmin2 * .25; + *ttype = -11; + } + } else if (*n0in > *n0 + 2) { + s = 0.; + *ttype = -12; + } + *tau = s; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlasq4.f b/lib/linalg/dlasq4.f deleted file mode 100644 index 2652ddb2ba..0000000000 --- a/lib/linalg/dlasq4.f +++ /dev/null @@ -1,421 +0,0 @@ -*> \brief \b DLASQ4 computes an approximation to the smallest eigenvalue using values of d from the previous transform. Used by sbdsqr. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASQ4 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, -* DN1, DN2, TAU, TTYPE, G ) -* -* .. Scalar Arguments .. -* INTEGER I0, N0, N0IN, PP, TTYPE -* DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU -* .. -* .. Array Arguments .. -* DOUBLE PRECISION Z( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLASQ4 computes an approximation TAU to the smallest eigenvalue -*> using values of d from the previous transform. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] I0 -*> \verbatim -*> I0 is INTEGER -*> First index. -*> \endverbatim -*> -*> \param[in] N0 -*> \verbatim -*> N0 is INTEGER -*> Last index. -*> \endverbatim -*> -*> \param[in] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension ( 4*N0 ) -*> Z holds the qd array. -*> \endverbatim -*> -*> \param[in] PP -*> \verbatim -*> PP is INTEGER -*> PP=0 for ping, PP=1 for pong. -*> \endverbatim -*> -*> \param[in] N0IN -*> \verbatim -*> N0IN is INTEGER -*> The value of N0 at start of EIGTEST. -*> \endverbatim -*> -*> \param[in] DMIN -*> \verbatim -*> DMIN is DOUBLE PRECISION -*> Minimum value of d. -*> \endverbatim -*> -*> \param[in] DMIN1 -*> \verbatim -*> DMIN1 is DOUBLE PRECISION -*> Minimum value of d, excluding D( N0 ). -*> \endverbatim -*> -*> \param[in] DMIN2 -*> \verbatim -*> DMIN2 is DOUBLE PRECISION -*> Minimum value of d, excluding D( N0 ) and D( N0-1 ). -*> \endverbatim -*> -*> \param[in] DN -*> \verbatim -*> DN is DOUBLE PRECISION -*> d(N) -*> \endverbatim -*> -*> \param[in] DN1 -*> \verbatim -*> DN1 is DOUBLE PRECISION -*> d(N-1) -*> \endverbatim -*> -*> \param[in] DN2 -*> \verbatim -*> DN2 is DOUBLE PRECISION -*> d(N-2) -*> \endverbatim -*> -*> \param[out] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION -*> This is the shift. -*> \endverbatim -*> -*> \param[out] TTYPE -*> \verbatim -*> TTYPE is INTEGER -*> Shift type. -*> \endverbatim -*> -*> \param[in,out] G -*> \verbatim -*> G is DOUBLE PRECISION -*> G is passed as an argument in order to save its value between -*> calls to DLASQ4. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> CNST1 = 9/16 -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, - $ DN1, DN2, TAU, TTYPE, G ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER I0, N0, N0IN, PP, TTYPE - DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION Z( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION CNST1, CNST2, CNST3 - PARAMETER ( CNST1 = 0.5630D0, CNST2 = 1.010D0, - $ CNST3 = 1.050D0 ) - DOUBLE PRECISION QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD - PARAMETER ( QURTR = 0.250D0, THIRD = 0.3330D0, - $ HALF = 0.50D0, ZERO = 0.0D0, ONE = 1.0D0, - $ TWO = 2.0D0, HUNDRD = 100.0D0 ) -* .. -* .. Local Scalars .. - INTEGER I4, NN, NP - DOUBLE PRECISION A2, B1, B2, GAM, GAP1, GAP2, S -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* -* A negative DMIN forces the shift to take that absolute value -* TTYPE records the type of shift. -* - IF( DMIN.LE.ZERO ) THEN - TAU = -DMIN - TTYPE = -1 - RETURN - END IF -* - NN = 4*N0 + PP - IF( N0IN.EQ.N0 ) THEN -* -* No eigenvalues deflated. -* - IF( DMIN.EQ.DN .OR. DMIN.EQ.DN1 ) THEN -* - B1 = SQRT( Z( NN-3 ) )*SQRT( Z( NN-5 ) ) - B2 = SQRT( Z( NN-7 ) )*SQRT( Z( NN-9 ) ) - A2 = Z( NN-7 ) + Z( NN-5 ) -* -* Cases 2 and 3. -* - IF( DMIN.EQ.DN .AND. DMIN1.EQ.DN1 ) THEN - GAP2 = DMIN2 - A2 - DMIN2*QURTR - IF( GAP2.GT.ZERO .AND. GAP2.GT.B2 ) THEN - GAP1 = A2 - DN - ( B2 / GAP2 )*B2 - ELSE - GAP1 = A2 - DN - ( B1+B2 ) - END IF - IF( GAP1.GT.ZERO .AND. GAP1.GT.B1 ) THEN - S = MAX( DN-( B1 / GAP1 )*B1, HALF*DMIN ) - TTYPE = -2 - ELSE - S = ZERO - IF( DN.GT.B1 ) - $ S = DN - B1 - IF( A2.GT.( B1+B2 ) ) - $ S = MIN( S, A2-( B1+B2 ) ) - S = MAX( S, THIRD*DMIN ) - TTYPE = -3 - END IF - ELSE -* -* Case 4. -* - TTYPE = -4 - S = QURTR*DMIN - IF( DMIN.EQ.DN ) THEN - GAM = DN - A2 = ZERO - IF( Z( NN-5 ) .GT. Z( NN-7 ) ) - $ RETURN - B2 = Z( NN-5 ) / Z( NN-7 ) - NP = NN - 9 - ELSE - NP = NN - 2*PP - GAM = DN1 - IF( Z( NP-4 ) .GT. Z( NP-2 ) ) - $ RETURN - A2 = Z( NP-4 ) / Z( NP-2 ) - IF( Z( NN-9 ) .GT. Z( NN-11 ) ) - $ RETURN - B2 = Z( NN-9 ) / Z( NN-11 ) - NP = NN - 13 - END IF -* -* Approximate contribution to norm squared from I < NN-1. -* - A2 = A2 + B2 - DO 10 I4 = NP, 4*I0 - 1 + PP, -4 - IF( B2.EQ.ZERO ) - $ GO TO 20 - B1 = B2 - IF( Z( I4 ) .GT. Z( I4-2 ) ) - $ RETURN - B2 = B2*( Z( I4 ) / Z( I4-2 ) ) - A2 = A2 + B2 - IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) - $ GO TO 20 - 10 CONTINUE - 20 CONTINUE - A2 = CNST3*A2 -* -* Rayleigh quotient residual bound. -* - IF( A2.LT.CNST1 ) - $ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 ) - END IF - ELSE IF( DMIN.EQ.DN2 ) THEN -* -* Case 5. -* - TTYPE = -5 - S = QURTR*DMIN -* -* Compute contribution to norm squared from I > NN-2. -* - NP = NN - 2*PP - B1 = Z( NP-2 ) - B2 = Z( NP-6 ) - GAM = DN2 - IF( Z( NP-8 ).GT.B2 .OR. Z( NP-4 ).GT.B1 ) - $ RETURN - A2 = ( Z( NP-8 ) / B2 )*( ONE+Z( NP-4 ) / B1 ) -* -* Approximate contribution to norm squared from I < NN-2. -* - IF( N0-I0.GT.2 ) THEN - B2 = Z( NN-13 ) / Z( NN-15 ) - A2 = A2 + B2 - DO 30 I4 = NN - 17, 4*I0 - 1 + PP, -4 - IF( B2.EQ.ZERO ) - $ GO TO 40 - B1 = B2 - IF( Z( I4 ) .GT. Z( I4-2 ) ) - $ RETURN - B2 = B2*( Z( I4 ) / Z( I4-2 ) ) - A2 = A2 + B2 - IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) - $ GO TO 40 - 30 CONTINUE - 40 CONTINUE - A2 = CNST3*A2 - END IF -* - IF( A2.LT.CNST1 ) - $ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 ) - ELSE -* -* Case 6, no information to guide us. -* - IF( TTYPE.EQ.-6 ) THEN - G = G + THIRD*( ONE-G ) - ELSE IF( TTYPE.EQ.-18 ) THEN - G = QURTR*THIRD - ELSE - G = QURTR - END IF - S = G*DMIN - TTYPE = -6 - END IF -* - ELSE IF( N0IN.EQ.( N0+1 ) ) THEN -* -* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN. -* - IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN -* -* Cases 7 and 8. -* - TTYPE = -7 - S = THIRD*DMIN1 - IF( Z( NN-5 ).GT.Z( NN-7 ) ) - $ RETURN - B1 = Z( NN-5 ) / Z( NN-7 ) - B2 = B1 - IF( B2.EQ.ZERO ) - $ GO TO 60 - DO 50 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4 - A2 = B1 - IF( Z( I4 ).GT.Z( I4-2 ) ) - $ RETURN - B1 = B1*( Z( I4 ) / Z( I4-2 ) ) - B2 = B2 + B1 - IF( HUNDRD*MAX( B1, A2 ).LT.B2 ) - $ GO TO 60 - 50 CONTINUE - 60 CONTINUE - B2 = SQRT( CNST3*B2 ) - A2 = DMIN1 / ( ONE+B2**2 ) - GAP2 = HALF*DMIN2 - A2 - IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN - S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) ) - ELSE - S = MAX( S, A2*( ONE-CNST2*B2 ) ) - TTYPE = -8 - END IF - ELSE -* -* Case 9. -* - S = QURTR*DMIN1 - IF( DMIN1.EQ.DN1 ) - $ S = HALF*DMIN1 - TTYPE = -9 - END IF -* - ELSE IF( N0IN.EQ.( N0+2 ) ) THEN -* -* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN. -* -* Cases 10 and 11. -* - IF( DMIN2.EQ.DN2 .AND. TWO*Z( NN-5 ).LT.Z( NN-7 ) ) THEN - TTYPE = -10 - S = THIRD*DMIN2 - IF( Z( NN-5 ).GT.Z( NN-7 ) ) - $ RETURN - B1 = Z( NN-5 ) / Z( NN-7 ) - B2 = B1 - IF( B2.EQ.ZERO ) - $ GO TO 80 - DO 70 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4 - IF( Z( I4 ).GT.Z( I4-2 ) ) - $ RETURN - B1 = B1*( Z( I4 ) / Z( I4-2 ) ) - B2 = B2 + B1 - IF( HUNDRD*B1.LT.B2 ) - $ GO TO 80 - 70 CONTINUE - 80 CONTINUE - B2 = SQRT( CNST3*B2 ) - A2 = DMIN2 / ( ONE+B2**2 ) - GAP2 = Z( NN-7 ) + Z( NN-9 ) - - $ SQRT( Z( NN-11 ) )*SQRT( Z( NN-9 ) ) - A2 - IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN - S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) ) - ELSE - S = MAX( S, A2*( ONE-CNST2*B2 ) ) - END IF - ELSE - S = QURTR*DMIN2 - TTYPE = -11 - END IF - ELSE IF( N0IN.GT.( N0+2 ) ) THEN -* -* Case 12, more than two eigenvalues deflated. No information. -* - S = ZERO - TTYPE = -12 - END IF -* - TAU = S - RETURN -* -* End of DLASQ4 -* - END diff --git a/lib/linalg/dlasq5.cpp b/lib/linalg/dlasq5.cpp new file mode 100644 index 0000000000..b242f3ceb8 --- /dev/null +++ b/lib/linalg/dlasq5.cpp @@ -0,0 +1,239 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dlasq5_(integer *i0, integer *n0, doublereal *z__, integer *pp, doublereal *tau, + doublereal *sigma, doublereal *dmin__, doublereal *dmin1, doublereal *dmin2, + doublereal *dn, doublereal *dnm1, doublereal *dnm2, logical *ieee, doublereal *eps) +{ + integer i__1; + doublereal d__1, d__2; + doublereal d__; + integer j4, j4p2; + doublereal emin, temp, dthresh; + --z__; + if (*n0 - *i0 - 1 <= 0) { + return 0; + } + dthresh = *eps * (*sigma + *tau); + if (*tau < dthresh * .5) { + *tau = 0.; + } + if (*tau != 0.) { + j4 = (*i0 << 2) + *pp - 3; + emin = z__[j4 + 4]; + d__ = z__[j4] - *tau; + *dmin__ = d__; + *dmin1 = -z__[j4]; + if (*ieee) { + if (*pp == 0) { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 2] = d__ + z__[j4 - 1]; + temp = z__[j4 + 1] / z__[j4 - 2]; + d__ = d__ * temp - *tau; + *dmin__ = min(*dmin__, d__); + z__[j4] = z__[j4 - 1] * temp; + d__1 = z__[j4]; + emin = min(d__1, emin); + } + } else { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 3] = d__ + z__[j4]; + temp = z__[j4 + 2] / z__[j4 - 3]; + d__ = d__ * temp - *tau; + *dmin__ = min(*dmin__, d__); + z__[j4 - 1] = z__[j4] * temp; + d__1 = z__[j4 - 1]; + emin = min(d__1, emin); + } + } + *dnm2 = d__; + *dmin2 = *dmin__; + j4 = (*n0 - 2 << 2) - *pp; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm2 + z__[j4p2]; + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau; + *dmin__ = min(*dmin__, *dnm1); + *dmin1 = *dmin__; + j4 += 4; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm1 + z__[j4p2]; + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau; + *dmin__ = min(*dmin__, *dn); + } else { + if (*pp == 0) { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 2] = d__ + z__[j4 - 1]; + if (d__ < 0.) { + return 0; + } else { + z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]); + d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]) - *tau; + } + *dmin__ = min(*dmin__, d__); + d__1 = emin, d__2 = z__[j4]; + emin = min(d__1, d__2); + } + } else { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 3] = d__ + z__[j4]; + if (d__ < 0.) { + return 0; + } else { + z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]); + d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]) - *tau; + } + *dmin__ = min(*dmin__, d__); + d__1 = emin, d__2 = z__[j4 - 1]; + emin = min(d__1, d__2); + } + } + *dnm2 = d__; + *dmin2 = *dmin__; + j4 = (*n0 - 2 << 2) - *pp; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm2 + z__[j4p2]; + if (*dnm2 < 0.) { + return 0; + } else { + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau; + } + *dmin__ = min(*dmin__, *dnm1); + *dmin1 = *dmin__; + j4 += 4; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm1 + z__[j4p2]; + if (*dnm1 < 0.) { + return 0; + } else { + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau; + } + *dmin__ = min(*dmin__, *dn); + } + } else { + j4 = (*i0 << 2) + *pp - 3; + emin = z__[j4 + 4]; + d__ = z__[j4] - *tau; + *dmin__ = d__; + *dmin1 = -z__[j4]; + if (*ieee) { + if (*pp == 0) { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 2] = d__ + z__[j4 - 1]; + temp = z__[j4 + 1] / z__[j4 - 2]; + d__ = d__ * temp - *tau; + if (d__ < dthresh) { + d__ = 0.; + } + *dmin__ = min(*dmin__, d__); + z__[j4] = z__[j4 - 1] * temp; + d__1 = z__[j4]; + emin = min(d__1, emin); + } + } else { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 3] = d__ + z__[j4]; + temp = z__[j4 + 2] / z__[j4 - 3]; + d__ = d__ * temp - *tau; + if (d__ < dthresh) { + d__ = 0.; + } + *dmin__ = min(*dmin__, d__); + z__[j4 - 1] = z__[j4] * temp; + d__1 = z__[j4 - 1]; + emin = min(d__1, emin); + } + } + *dnm2 = d__; + *dmin2 = *dmin__; + j4 = (*n0 - 2 << 2) - *pp; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm2 + z__[j4p2]; + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau; + *dmin__ = min(*dmin__, *dnm1); + *dmin1 = *dmin__; + j4 += 4; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm1 + z__[j4p2]; + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau; + *dmin__ = min(*dmin__, *dn); + } else { + if (*pp == 0) { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 2] = d__ + z__[j4 - 1]; + if (d__ < 0.) { + return 0; + } else { + z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]); + d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]) - *tau; + } + if (d__ < dthresh) { + d__ = 0.; + } + *dmin__ = min(*dmin__, d__); + d__1 = emin, d__2 = z__[j4]; + emin = min(d__1, d__2); + } + } else { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 3] = d__ + z__[j4]; + if (d__ < 0.) { + return 0; + } else { + z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]); + d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]) - *tau; + } + if (d__ < dthresh) { + d__ = 0.; + } + *dmin__ = min(*dmin__, d__); + d__1 = emin, d__2 = z__[j4 - 1]; + emin = min(d__1, d__2); + } + } + *dnm2 = d__; + *dmin2 = *dmin__; + j4 = (*n0 - 2 << 2) - *pp; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm2 + z__[j4p2]; + if (*dnm2 < 0.) { + return 0; + } else { + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau; + } + *dmin__ = min(*dmin__, *dnm1); + *dmin1 = *dmin__; + j4 += 4; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm1 + z__[j4p2]; + if (*dnm1 < 0.) { + return 0; + } else { + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau; + } + *dmin__ = min(*dmin__, *dn); + } + } + z__[j4 + 2] = *dn; + z__[(*n0 << 2) - *pp] = emin; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlasq5.f b/lib/linalg/dlasq5.f deleted file mode 100644 index 5679ab60a5..0000000000 --- a/lib/linalg/dlasq5.f +++ /dev/null @@ -1,407 +0,0 @@ -*> \brief \b DLASQ5 computes one dqds transform in ping-pong form. Used by sbdsqr and sstegr. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASQ5 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, DN, -* DNM1, DNM2, IEEE, EPS ) -* -* .. Scalar Arguments .. -* LOGICAL IEEE -* INTEGER I0, N0, PP -* DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU, SIGMA, EPS -* .. -* .. Array Arguments .. -* DOUBLE PRECISION Z( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLASQ5 computes one dqds transform in ping-pong form, one -*> version for IEEE machines another for non IEEE machines. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] I0 -*> \verbatim -*> I0 is INTEGER -*> First index. -*> \endverbatim -*> -*> \param[in] N0 -*> \verbatim -*> N0 is INTEGER -*> Last index. -*> \endverbatim -*> -*> \param[in] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension ( 4*N ) -*> Z holds the qd array. EMIN is stored in Z(4*N0) to avoid -*> an extra argument. -*> \endverbatim -*> -*> \param[in] PP -*> \verbatim -*> PP is INTEGER -*> PP=0 for ping, PP=1 for pong. -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION -*> This is the shift. -*> \endverbatim -*> -*> \param[in] SIGMA -*> \verbatim -*> SIGMA is DOUBLE PRECISION -*> This is the accumulated shift up to this step. -*> \endverbatim -*> -*> \param[out] DMIN -*> \verbatim -*> DMIN is DOUBLE PRECISION -*> Minimum value of d. -*> \endverbatim -*> -*> \param[out] DMIN1 -*> \verbatim -*> DMIN1 is DOUBLE PRECISION -*> Minimum value of d, excluding D( N0 ). -*> \endverbatim -*> -*> \param[out] DMIN2 -*> \verbatim -*> DMIN2 is DOUBLE PRECISION -*> Minimum value of d, excluding D( N0 ) and D( N0-1 ). -*> \endverbatim -*> -*> \param[out] DN -*> \verbatim -*> DN is DOUBLE PRECISION -*> d(N0), the last value of d. -*> \endverbatim -*> -*> \param[out] DNM1 -*> \verbatim -*> DNM1 is DOUBLE PRECISION -*> d(N0-1). -*> \endverbatim -*> -*> \param[out] DNM2 -*> \verbatim -*> DNM2 is DOUBLE PRECISION -*> d(N0-2). -*> \endverbatim -*> -*> \param[in] IEEE -*> \verbatim -*> IEEE is LOGICAL -*> Flag for IEEE or non IEEE arithmetic. -*> \endverbatim -*> -*> \param[in] EPS -*> \verbatim -*> EPS is DOUBLE PRECISION -*> This is the value of epsilon used. -*> \endverbatim -*> -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -* ===================================================================== - SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, - $ DN, DNM1, DNM2, IEEE, EPS ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - LOGICAL IEEE - INTEGER I0, N0, PP - DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU, - $ SIGMA, EPS -* .. -* .. Array Arguments .. - DOUBLE PRECISION Z( * ) -* .. -* -* ===================================================================== -* -* .. Parameter .. - DOUBLE PRECISION ZERO, HALF - PARAMETER ( ZERO = 0.0D0, HALF = 0.5 ) -* .. -* .. Local Scalars .. - INTEGER J4, J4P2 - DOUBLE PRECISION D, EMIN, TEMP, DTHRESH -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* - IF( ( N0-I0-1 ).LE.0 ) - $ RETURN -* - DTHRESH = EPS*(SIGMA+TAU) - IF( TAU.LT.DTHRESH*HALF ) TAU = ZERO - IF( TAU.NE.ZERO ) THEN - J4 = 4*I0 + PP - 3 - EMIN = Z( J4+4 ) - D = Z( J4 ) - TAU - DMIN = D - DMIN1 = -Z( J4 ) -* - IF( IEEE ) THEN -* -* Code for IEEE arithmetic. -* - IF( PP.EQ.0 ) THEN - DO 10 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-2 ) = D + Z( J4-1 ) - TEMP = Z( J4+1 ) / Z( J4-2 ) - D = D*TEMP - TAU - DMIN = MIN( DMIN, D ) - Z( J4 ) = Z( J4-1 )*TEMP - EMIN = MIN( Z( J4 ), EMIN ) - 10 CONTINUE - ELSE - DO 20 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-3 ) = D + Z( J4 ) - TEMP = Z( J4+2 ) / Z( J4-3 ) - D = D*TEMP - TAU - DMIN = MIN( DMIN, D ) - Z( J4-1 ) = Z( J4 )*TEMP - EMIN = MIN( Z( J4-1 ), EMIN ) - 20 CONTINUE - END IF -* -* Unroll last two steps. -* - DNM2 = D - DMIN2 = DMIN - J4 = 4*( N0-2 ) - PP - J4P2 = J4 + 2*PP - 1 - Z( J4-2 ) = DNM2 + Z( J4P2 ) - Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) - DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU - DMIN = MIN( DMIN, DNM1 ) -* - DMIN1 = DMIN - J4 = J4 + 4 - J4P2 = J4 + 2*PP - 1 - Z( J4-2 ) = DNM1 + Z( J4P2 ) - Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) - DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU - DMIN = MIN( DMIN, DN ) -* - ELSE -* -* Code for non IEEE arithmetic. -* - IF( PP.EQ.0 ) THEN - DO 30 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-2 ) = D + Z( J4-1 ) - IF( D.LT.ZERO ) THEN - RETURN - ELSE - Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) ) - D = Z( J4+1 )*( D / Z( J4-2 ) ) - TAU - END IF - DMIN = MIN( DMIN, D ) - EMIN = MIN( EMIN, Z( J4 ) ) - 30 CONTINUE - ELSE - DO 40 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-3 ) = D + Z( J4 ) - IF( D.LT.ZERO ) THEN - RETURN - ELSE - Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) ) - D = Z( J4+2 )*( D / Z( J4-3 ) ) - TAU - END IF - DMIN = MIN( DMIN, D ) - EMIN = MIN( EMIN, Z( J4-1 ) ) - 40 CONTINUE - END IF -* -* Unroll last two steps. -* - DNM2 = D - DMIN2 = DMIN - J4 = 4*( N0-2 ) - PP - J4P2 = J4 + 2*PP - 1 - Z( J4-2 ) = DNM2 + Z( J4P2 ) - IF( DNM2.LT.ZERO ) THEN - RETURN - ELSE - Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) - DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU - END IF - DMIN = MIN( DMIN, DNM1 ) -* - DMIN1 = DMIN - J4 = J4 + 4 - J4P2 = J4 + 2*PP - 1 - Z( J4-2 ) = DNM1 + Z( J4P2 ) - IF( DNM1.LT.ZERO ) THEN - RETURN - ELSE - Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) - DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU - END IF - DMIN = MIN( DMIN, DN ) -* - END IF - ELSE -* This is the version that sets d's to zero if they are small enough - J4 = 4*I0 + PP - 3 - EMIN = Z( J4+4 ) - D = Z( J4 ) - TAU - DMIN = D - DMIN1 = -Z( J4 ) - IF( IEEE ) THEN -* -* Code for IEEE arithmetic. -* - IF( PP.EQ.0 ) THEN - DO 50 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-2 ) = D + Z( J4-1 ) - TEMP = Z( J4+1 ) / Z( J4-2 ) - D = D*TEMP - TAU - IF( D.LT.DTHRESH ) D = ZERO - DMIN = MIN( DMIN, D ) - Z( J4 ) = Z( J4-1 )*TEMP - EMIN = MIN( Z( J4 ), EMIN ) - 50 CONTINUE - ELSE - DO 60 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-3 ) = D + Z( J4 ) - TEMP = Z( J4+2 ) / Z( J4-3 ) - D = D*TEMP - TAU - IF( D.LT.DTHRESH ) D = ZERO - DMIN = MIN( DMIN, D ) - Z( J4-1 ) = Z( J4 )*TEMP - EMIN = MIN( Z( J4-1 ), EMIN ) - 60 CONTINUE - END IF -* -* Unroll last two steps. -* - DNM2 = D - DMIN2 = DMIN - J4 = 4*( N0-2 ) - PP - J4P2 = J4 + 2*PP - 1 - Z( J4-2 ) = DNM2 + Z( J4P2 ) - Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) - DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU - DMIN = MIN( DMIN, DNM1 ) -* - DMIN1 = DMIN - J4 = J4 + 4 - J4P2 = J4 + 2*PP - 1 - Z( J4-2 ) = DNM1 + Z( J4P2 ) - Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) - DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU - DMIN = MIN( DMIN, DN ) -* - ELSE -* -* Code for non IEEE arithmetic. -* - IF( PP.EQ.0 ) THEN - DO 70 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-2 ) = D + Z( J4-1 ) - IF( D.LT.ZERO ) THEN - RETURN - ELSE - Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) ) - D = Z( J4+1 )*( D / Z( J4-2 ) ) - TAU - END IF - IF( D.LT.DTHRESH) D = ZERO - DMIN = MIN( DMIN, D ) - EMIN = MIN( EMIN, Z( J4 ) ) - 70 CONTINUE - ELSE - DO 80 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-3 ) = D + Z( J4 ) - IF( D.LT.ZERO ) THEN - RETURN - ELSE - Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) ) - D = Z( J4+2 )*( D / Z( J4-3 ) ) - TAU - END IF - IF( D.LT.DTHRESH) D = ZERO - DMIN = MIN( DMIN, D ) - EMIN = MIN( EMIN, Z( J4-1 ) ) - 80 CONTINUE - END IF -* -* Unroll last two steps. -* - DNM2 = D - DMIN2 = DMIN - J4 = 4*( N0-2 ) - PP - J4P2 = J4 + 2*PP - 1 - Z( J4-2 ) = DNM2 + Z( J4P2 ) - IF( DNM2.LT.ZERO ) THEN - RETURN - ELSE - Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) - DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU - END IF - DMIN = MIN( DMIN, DNM1 ) -* - DMIN1 = DMIN - J4 = J4 + 4 - J4P2 = J4 + 2*PP - 1 - Z( J4-2 ) = DNM1 + Z( J4P2 ) - IF( DNM1.LT.ZERO ) THEN - RETURN - ELSE - Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) - DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU - END IF - DMIN = MIN( DMIN, DN ) -* - END IF - END IF -* - Z( J4+2 ) = DN - Z( 4*N0-PP ) = EMIN - RETURN -* -* End of DLASQ5 -* - END diff --git a/lib/linalg/dlasq6.cpp b/lib/linalg/dlasq6.cpp new file mode 100644 index 0000000000..b60dcdd9d6 --- /dev/null +++ b/lib/linalg/dlasq6.cpp @@ -0,0 +1,111 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dlasq6_(integer *i0, integer *n0, doublereal *z__, integer *pp, doublereal *dmin__, + doublereal *dmin1, doublereal *dmin2, doublereal *dn, doublereal *dnm1, + doublereal *dnm2) +{ + integer i__1; + doublereal d__1, d__2; + doublereal d__; + integer j4, j4p2; + doublereal emin, temp; + extern doublereal dlamch_(char *, ftnlen); + doublereal safmin; + --z__; + if (*n0 - *i0 - 1 <= 0) { + return 0; + } + safmin = dlamch_((char *)"Safe minimum", (ftnlen)12); + j4 = (*i0 << 2) + *pp - 3; + emin = z__[j4 + 4]; + d__ = z__[j4]; + *dmin__ = d__; + if (*pp == 0) { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 2] = d__ + z__[j4 - 1]; + if (z__[j4 - 2] == 0.) { + z__[j4] = 0.; + d__ = z__[j4 + 1]; + *dmin__ = d__; + emin = 0.; + } else if (safmin * z__[j4 + 1] < z__[j4 - 2] && safmin * z__[j4 - 2] < z__[j4 + 1]) { + temp = z__[j4 + 1] / z__[j4 - 2]; + z__[j4] = z__[j4 - 1] * temp; + d__ *= temp; + } else { + z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]); + d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]); + } + *dmin__ = min(*dmin__, d__); + d__1 = emin, d__2 = z__[j4]; + emin = min(d__1, d__2); + } + } else { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 3] = d__ + z__[j4]; + if (z__[j4 - 3] == 0.) { + z__[j4 - 1] = 0.; + d__ = z__[j4 + 2]; + *dmin__ = d__; + emin = 0.; + } else if (safmin * z__[j4 + 2] < z__[j4 - 3] && safmin * z__[j4 - 3] < z__[j4 + 2]) { + temp = z__[j4 + 2] / z__[j4 - 3]; + z__[j4 - 1] = z__[j4] * temp; + d__ *= temp; + } else { + z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]); + d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]); + } + *dmin__ = min(*dmin__, d__); + d__1 = emin, d__2 = z__[j4 - 1]; + emin = min(d__1, d__2); + } + } + *dnm2 = d__; + *dmin2 = *dmin__; + j4 = (*n0 - 2 << 2) - *pp; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm2 + z__[j4p2]; + if (z__[j4 - 2] == 0.) { + z__[j4] = 0.; + *dnm1 = z__[j4p2 + 2]; + *dmin__ = *dnm1; + emin = 0.; + } else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] < z__[j4p2 + 2]) { + temp = z__[j4p2 + 2] / z__[j4 - 2]; + z__[j4] = z__[j4p2] * temp; + *dnm1 = *dnm2 * temp; + } else { + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]); + } + *dmin__ = min(*dmin__, *dnm1); + *dmin1 = *dmin__; + j4 += 4; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm1 + z__[j4p2]; + if (z__[j4 - 2] == 0.) { + z__[j4] = 0.; + *dn = z__[j4p2 + 2]; + *dmin__ = *dn; + emin = 0.; + } else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] < z__[j4p2 + 2]) { + temp = z__[j4p2 + 2] / z__[j4 - 2]; + z__[j4] = z__[j4p2] * temp; + *dn = *dnm1 * temp; + } else { + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]); + } + *dmin__ = min(*dmin__, *dn); + z__[j4 + 2] = *dn; + z__[(*n0 << 2) - *pp] = emin; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlasq6.f b/lib/linalg/dlasq6.f deleted file mode 100644 index 9218b5060e..0000000000 --- a/lib/linalg/dlasq6.f +++ /dev/null @@ -1,251 +0,0 @@ -*> \brief \b DLASQ6 computes one dqd transform in ping-pong form. Used by sbdsqr and sstegr. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASQ6 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, -* DNM1, DNM2 ) -* -* .. Scalar Arguments .. -* INTEGER I0, N0, PP -* DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2 -* .. -* .. Array Arguments .. -* DOUBLE PRECISION Z( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLASQ6 computes one dqd (shift equal to zero) transform in -*> ping-pong form, with protection against underflow and overflow. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] I0 -*> \verbatim -*> I0 is INTEGER -*> First index. -*> \endverbatim -*> -*> \param[in] N0 -*> \verbatim -*> N0 is INTEGER -*> Last index. -*> \endverbatim -*> -*> \param[in] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension ( 4*N ) -*> Z holds the qd array. EMIN is stored in Z(4*N0) to avoid -*> an extra argument. -*> \endverbatim -*> -*> \param[in] PP -*> \verbatim -*> PP is INTEGER -*> PP=0 for ping, PP=1 for pong. -*> \endverbatim -*> -*> \param[out] DMIN -*> \verbatim -*> DMIN is DOUBLE PRECISION -*> Minimum value of d. -*> \endverbatim -*> -*> \param[out] DMIN1 -*> \verbatim -*> DMIN1 is DOUBLE PRECISION -*> Minimum value of d, excluding D( N0 ). -*> \endverbatim -*> -*> \param[out] DMIN2 -*> \verbatim -*> DMIN2 is DOUBLE PRECISION -*> Minimum value of d, excluding D( N0 ) and D( N0-1 ). -*> \endverbatim -*> -*> \param[out] DN -*> \verbatim -*> DN is DOUBLE PRECISION -*> d(N0), the last value of d. -*> \endverbatim -*> -*> \param[out] DNM1 -*> \verbatim -*> DNM1 is DOUBLE PRECISION -*> d(N0-1). -*> \endverbatim -*> -*> \param[out] DNM2 -*> \verbatim -*> DNM2 is DOUBLE PRECISION -*> d(N0-2). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -* ===================================================================== - SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, - $ DNM1, DNM2 ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER I0, N0, PP - DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2 -* .. -* .. Array Arguments .. - DOUBLE PRECISION Z( * ) -* .. -* -* ===================================================================== -* -* .. Parameter .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -* .. -* .. Local Scalars .. - INTEGER J4, J4P2 - DOUBLE PRECISION D, EMIN, SAFMIN, TEMP -* .. -* .. External Function .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* - IF( ( N0-I0-1 ).LE.0 ) - $ RETURN -* - SAFMIN = DLAMCH( 'Safe minimum' ) - J4 = 4*I0 + PP - 3 - EMIN = Z( J4+4 ) - D = Z( J4 ) - DMIN = D -* - IF( PP.EQ.0 ) THEN - DO 10 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-2 ) = D + Z( J4-1 ) - IF( Z( J4-2 ).EQ.ZERO ) THEN - Z( J4 ) = ZERO - D = Z( J4+1 ) - DMIN = D - EMIN = ZERO - ELSE IF( SAFMIN*Z( J4+1 ).LT.Z( J4-2 ) .AND. - $ SAFMIN*Z( J4-2 ).LT.Z( J4+1 ) ) THEN - TEMP = Z( J4+1 ) / Z( J4-2 ) - Z( J4 ) = Z( J4-1 )*TEMP - D = D*TEMP - ELSE - Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) ) - D = Z( J4+1 )*( D / Z( J4-2 ) ) - END IF - DMIN = MIN( DMIN, D ) - EMIN = MIN( EMIN, Z( J4 ) ) - 10 CONTINUE - ELSE - DO 20 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-3 ) = D + Z( J4 ) - IF( Z( J4-3 ).EQ.ZERO ) THEN - Z( J4-1 ) = ZERO - D = Z( J4+2 ) - DMIN = D - EMIN = ZERO - ELSE IF( SAFMIN*Z( J4+2 ).LT.Z( J4-3 ) .AND. - $ SAFMIN*Z( J4-3 ).LT.Z( J4+2 ) ) THEN - TEMP = Z( J4+2 ) / Z( J4-3 ) - Z( J4-1 ) = Z( J4 )*TEMP - D = D*TEMP - ELSE - Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) ) - D = Z( J4+2 )*( D / Z( J4-3 ) ) - END IF - DMIN = MIN( DMIN, D ) - EMIN = MIN( EMIN, Z( J4-1 ) ) - 20 CONTINUE - END IF -* -* Unroll last two steps. -* - DNM2 = D - DMIN2 = DMIN - J4 = 4*( N0-2 ) - PP - J4P2 = J4 + 2*PP - 1 - Z( J4-2 ) = DNM2 + Z( J4P2 ) - IF( Z( J4-2 ).EQ.ZERO ) THEN - Z( J4 ) = ZERO - DNM1 = Z( J4P2+2 ) - DMIN = DNM1 - EMIN = ZERO - ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND. - $ SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN - TEMP = Z( J4P2+2 ) / Z( J4-2 ) - Z( J4 ) = Z( J4P2 )*TEMP - DNM1 = DNM2*TEMP - ELSE - Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) - DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - END IF - DMIN = MIN( DMIN, DNM1 ) -* - DMIN1 = DMIN - J4 = J4 + 4 - J4P2 = J4 + 2*PP - 1 - Z( J4-2 ) = DNM1 + Z( J4P2 ) - IF( Z( J4-2 ).EQ.ZERO ) THEN - Z( J4 ) = ZERO - DN = Z( J4P2+2 ) - DMIN = DN - EMIN = ZERO - ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND. - $ SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN - TEMP = Z( J4P2+2 ) / Z( J4-2 ) - Z( J4 ) = Z( J4P2 )*TEMP - DN = DNM1*TEMP - ELSE - Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) - DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - END IF - DMIN = MIN( DMIN, DN ) -* - Z( J4+2 ) = DN - Z( 4*N0-PP ) = EMIN - RETURN -* -* End of DLASQ6 -* - END diff --git a/lib/linalg/dlasr.cpp b/lib/linalg/dlasr.cpp new file mode 100644 index 0000000000..83784179fa --- /dev/null +++ b/lib/linalg/dlasr.cpp @@ -0,0 +1,227 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dlasr_(char *side, char *pivot, char *direct, integer *m, integer *n, doublereal *c__, + doublereal *s, doublereal *a, integer *lda, ftnlen side_len, ftnlen pivot_len, + ftnlen direct_len) +{ + integer a_dim1, a_offset, i__1, i__2; + integer i__, j, info; + doublereal temp; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + doublereal ctemp, stemp; + extern int xerbla_(char *, integer *, ftnlen); + --c__; + --s; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + info = 0; + if (!(lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1) || lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1))) { + info = 1; + } else if (!(lsame_(pivot, (char *)"V", (ftnlen)1, (ftnlen)1) || + lsame_(pivot, (char *)"T", (ftnlen)1, (ftnlen)1) || + lsame_(pivot, (char *)"B", (ftnlen)1, (ftnlen)1))) { + info = 2; + } else if (!(lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1) || + lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1))) { + info = 3; + } else if (*m < 0) { + info = 4; + } else if (*n < 0) { + info = 5; + } else if (*lda < max(1, *m)) { + info = 9; + } + if (info != 0) { + xerbla_((char *)"DLASR ", &info, (ftnlen)6); + return 0; + } + if (*m == 0 || *n == 0) { + return 0; + } + if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { + if (lsame_(pivot, (char *)"V", (ftnlen)1, (ftnlen)1)) { + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + i__1 = *m - 1; + for (j = 1; j <= i__1; ++j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = a[j + 1 + i__ * a_dim1]; + a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp * a[j + i__ * a_dim1]; + a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j + i__ * a_dim1]; + } + } + } + } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { + for (j = *m - 1; j >= 1; --j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = a[j + 1 + i__ * a_dim1]; + a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp * a[j + i__ * a_dim1]; + a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j + i__ * a_dim1]; + } + } + } + } + } else if (lsame_(pivot, (char *)"T", (ftnlen)1, (ftnlen)1)) { + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + i__1 = *m; + for (j = 2; j <= i__1; ++j) { + ctemp = c__[j - 1]; + stemp = s[j - 1]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = a[j + i__ * a_dim1]; + a[j + i__ * a_dim1] = ctemp * temp - stemp * a[i__ * a_dim1 + 1]; + a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[i__ * a_dim1 + 1]; + } + } + } + } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { + for (j = *m; j >= 2; --j) { + ctemp = c__[j - 1]; + stemp = s[j - 1]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = a[j + i__ * a_dim1]; + a[j + i__ * a_dim1] = ctemp * temp - stemp * a[i__ * a_dim1 + 1]; + a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[i__ * a_dim1 + 1]; + } + } + } + } + } else if (lsame_(pivot, (char *)"B", (ftnlen)1, (ftnlen)1)) { + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + i__1 = *m - 1; + for (j = 1; j <= i__1; ++j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = a[j + i__ * a_dim1]; + a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1] + ctemp * temp; + a[*m + i__ * a_dim1] = ctemp * a[*m + i__ * a_dim1] - stemp * temp; + } + } + } + } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { + for (j = *m - 1; j >= 1; --j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = a[j + i__ * a_dim1]; + a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1] + ctemp * temp; + a[*m + i__ * a_dim1] = ctemp * a[*m + i__ * a_dim1] - stemp * temp; + } + } + } + } + } + } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { + if (lsame_(pivot, (char *)"V", (ftnlen)1, (ftnlen)1)) { + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = a[i__ + (j + 1) * a_dim1]; + a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp * a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = stemp * temp + ctemp * a[i__ + j * a_dim1]; + } + } + } + } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { + for (j = *n - 1; j >= 1; --j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = a[i__ + (j + 1) * a_dim1]; + a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp * a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = stemp * temp + ctemp * a[i__ + j * a_dim1]; + } + } + } + } + } else if (lsame_(pivot, (char *)"T", (ftnlen)1, (ftnlen)1)) { + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + ctemp = c__[j - 1]; + stemp = s[j - 1]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = ctemp * temp - stemp * a[i__ + a_dim1]; + a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ + a_dim1]; + } + } + } + } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { + for (j = *n; j >= 2; --j) { + ctemp = c__[j - 1]; + stemp = s[j - 1]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = ctemp * temp - stemp * a[i__ + a_dim1]; + a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ + a_dim1]; + } + } + } + } + } else if (lsame_(pivot, (char *)"B", (ftnlen)1, (ftnlen)1)) { + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1] + ctemp * temp; + a[i__ + *n * a_dim1] = ctemp * a[i__ + *n * a_dim1] - stemp * temp; + } + } + } + } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { + for (j = *n - 1; j >= 1; --j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1] + ctemp * temp; + a[i__ + *n * a_dim1] = ctemp * a[i__ + *n * a_dim1] - stemp * temp; + } + } + } + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlasr.f b/lib/linalg/dlasr.f deleted file mode 100644 index dd0cedd85e..0000000000 --- a/lib/linalg/dlasr.f +++ /dev/null @@ -1,433 +0,0 @@ -*> \brief \b DLASR applies a sequence of plane rotations to a general rectangular matrix. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) -* -* .. Scalar Arguments .. -* CHARACTER DIRECT, PIVOT, SIDE -* INTEGER LDA, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), C( * ), S( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLASR applies a sequence of plane rotations to a real matrix A, -*> from either the left or the right. -*> -*> When SIDE = 'L', the transformation takes the form -*> -*> A := P*A -*> -*> and when SIDE = 'R', the transformation takes the form -*> -*> A := A*P**T -*> -*> where P is an orthogonal matrix consisting of a sequence of z plane -*> rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R', -*> and P**T is the transpose of P. -*> -*> When DIRECT = 'F' (Forward sequence), then -*> -*> P = P(z-1) * ... * P(2) * P(1) -*> -*> and when DIRECT = 'B' (Backward sequence), then -*> -*> P = P(1) * P(2) * ... * P(z-1) -*> -*> where P(k) is a plane rotation matrix defined by the 2-by-2 rotation -*> -*> R(k) = ( c(k) s(k) ) -*> = ( -s(k) c(k) ). -*> -*> When PIVOT = 'V' (Variable pivot), the rotation is performed -*> for the plane (k,k+1), i.e., P(k) has the form -*> -*> P(k) = ( 1 ) -*> ( ... ) -*> ( 1 ) -*> ( c(k) s(k) ) -*> ( -s(k) c(k) ) -*> ( 1 ) -*> ( ... ) -*> ( 1 ) -*> -*> where R(k) appears as a rank-2 modification to the identity matrix in -*> rows and columns k and k+1. -*> -*> When PIVOT = 'T' (Top pivot), the rotation is performed for the -*> plane (1,k+1), so P(k) has the form -*> -*> P(k) = ( c(k) s(k) ) -*> ( 1 ) -*> ( ... ) -*> ( 1 ) -*> ( -s(k) c(k) ) -*> ( 1 ) -*> ( ... ) -*> ( 1 ) -*> -*> where R(k) appears in rows and columns 1 and k+1. -*> -*> Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is -*> performed for the plane (k,z), giving P(k) the form -*> -*> P(k) = ( 1 ) -*> ( ... ) -*> ( 1 ) -*> ( c(k) s(k) ) -*> ( 1 ) -*> ( ... ) -*> ( 1 ) -*> ( -s(k) c(k) ) -*> -*> where R(k) appears in rows and columns k and z. The rotations are -*> performed without ever forming P(k) explicitly. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> Specifies whether the plane rotation matrix P is applied to -*> A on the left or the right. -*> = 'L': Left, compute A := P*A -*> = 'R': Right, compute A:= A*P**T -*> \endverbatim -*> -*> \param[in] PIVOT -*> \verbatim -*> PIVOT is CHARACTER*1 -*> Specifies the plane for which P(k) is a plane rotation -*> matrix. -*> = 'V': Variable pivot, the plane (k,k+1) -*> = 'T': Top pivot, the plane (1,k+1) -*> = 'B': Bottom pivot, the plane (k,z) -*> \endverbatim -*> -*> \param[in] DIRECT -*> \verbatim -*> DIRECT is CHARACTER*1 -*> Specifies whether P is a forward or backward sequence of -*> plane rotations. -*> = 'F': Forward, P = P(z-1)*...*P(2)*P(1) -*> = 'B': Backward, P = P(1)*P(2)*...*P(z-1) -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. If m <= 1, an immediate -*> return is effected. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. If n <= 1, an -*> immediate return is effected. -*> \endverbatim -*> -*> \param[in] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension -*> (M-1) if SIDE = 'L' -*> (N-1) if SIDE = 'R' -*> The cosines c(k) of the plane rotations. -*> \endverbatim -*> -*> \param[in] S -*> \verbatim -*> S is DOUBLE PRECISION array, dimension -*> (M-1) if SIDE = 'L' -*> (N-1) if SIDE = 'R' -*> The sines s(k) of the plane rotations. The 2-by-2 plane -*> rotation part of the matrix P(k), R(k), has the form -*> R(k) = ( c(k) s(k) ) -*> ( -s(k) c(k) ). -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> The M-by-N matrix A. On exit, A is overwritten by P*A if -*> SIDE = 'L' or by A*P**T if SIDE = 'R'. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER DIRECT, PIVOT, SIDE - INTEGER LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( * ), S( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, INFO, J - DOUBLE PRECISION CTEMP, STEMP, TEMP -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN - INFO = 1 - ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT, - $ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN - INFO = 2 - ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) ) - $ THEN - INFO = 3 - ELSE IF( M.LT.0 ) THEN - INFO = 4 - ELSE IF( N.LT.0 ) THEN - INFO = 5 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = 9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLASR ', INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) - $ RETURN - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form P * A -* - IF( LSAME( PIVOT, 'V' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 20 J = 1, M - 1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 10 I = 1, N - TEMP = A( J+1, I ) - A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) - A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) - 10 CONTINUE - END IF - 20 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 40 J = M - 1, 1, -1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 30 I = 1, N - TEMP = A( J+1, I ) - A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) - A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) - 30 CONTINUE - END IF - 40 CONTINUE - END IF - ELSE IF( LSAME( PIVOT, 'T' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 60 J = 2, M - CTEMP = C( J-1 ) - STEMP = S( J-1 ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 50 I = 1, N - TEMP = A( J, I ) - A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) - A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) - 50 CONTINUE - END IF - 60 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 80 J = M, 2, -1 - CTEMP = C( J-1 ) - STEMP = S( J-1 ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 70 I = 1, N - TEMP = A( J, I ) - A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) - A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) - 70 CONTINUE - END IF - 80 CONTINUE - END IF - ELSE IF( LSAME( PIVOT, 'B' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 100 J = 1, M - 1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 90 I = 1, N - TEMP = A( J, I ) - A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP - A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP - 90 CONTINUE - END IF - 100 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 120 J = M - 1, 1, -1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 110 I = 1, N - TEMP = A( J, I ) - A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP - A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP - 110 CONTINUE - END IF - 120 CONTINUE - END IF - END IF - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form A * P**T -* - IF( LSAME( PIVOT, 'V' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 140 J = 1, N - 1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 130 I = 1, M - TEMP = A( I, J+1 ) - A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) - A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) - 130 CONTINUE - END IF - 140 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 160 J = N - 1, 1, -1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 150 I = 1, M - TEMP = A( I, J+1 ) - A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) - A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) - 150 CONTINUE - END IF - 160 CONTINUE - END IF - ELSE IF( LSAME( PIVOT, 'T' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 180 J = 2, N - CTEMP = C( J-1 ) - STEMP = S( J-1 ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 170 I = 1, M - TEMP = A( I, J ) - A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) - A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) - 170 CONTINUE - END IF - 180 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 200 J = N, 2, -1 - CTEMP = C( J-1 ) - STEMP = S( J-1 ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 190 I = 1, M - TEMP = A( I, J ) - A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) - A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) - 190 CONTINUE - END IF - 200 CONTINUE - END IF - ELSE IF( LSAME( PIVOT, 'B' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 220 J = 1, N - 1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 210 I = 1, M - TEMP = A( I, J ) - A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP - A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP - 210 CONTINUE - END IF - 220 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 240 J = N - 1, 1, -1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 230 I = 1, M - TEMP = A( I, J ) - A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP - A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP - 230 CONTINUE - END IF - 240 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DLASR -* - END diff --git a/lib/linalg/dlasrt.cpp b/lib/linalg/dlasrt.cpp new file mode 100644 index 0000000000..9724ce322b --- /dev/null +++ b/lib/linalg/dlasrt.cpp @@ -0,0 +1,180 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dlasrt_(char *id, integer *n, doublereal *d__, integer *info, ftnlen id_len) +{ + integer i__1, i__2; + integer i__, j; + doublereal d1, d2, d3; + integer dir; + doublereal tmp; + integer endd; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + integer stack[64]; + doublereal dmnmx; + integer start; + extern int xerbla_(char *, integer *, ftnlen); + integer stkpnt; + --d__; + *info = 0; + dir = -1; + if (lsame_(id, (char *)"D", (ftnlen)1, (ftnlen)1)) { + dir = 0; + } else if (lsame_(id, (char *)"I", (ftnlen)1, (ftnlen)1)) { + dir = 1; + } + if (dir == -1) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DLASRT", &i__1, (ftnlen)6); + return 0; + } + if (*n <= 1) { + return 0; + } + stkpnt = 1; + stack[0] = 1; + stack[1] = *n; +L10: + start = stack[(stkpnt << 1) - 2]; + endd = stack[(stkpnt << 1) - 1]; + --stkpnt; + if (endd - start <= 20 && endd - start > 0) { + if (dir == 0) { + i__1 = endd; + for (i__ = start + 1; i__ <= i__1; ++i__) { + i__2 = start + 1; + for (j = i__; j >= i__2; --j) { + if (d__[j] > d__[j - 1]) { + dmnmx = d__[j]; + d__[j] = d__[j - 1]; + d__[j - 1] = dmnmx; + } else { + goto L30; + } + } + L30:; + } + } else { + i__1 = endd; + for (i__ = start + 1; i__ <= i__1; ++i__) { + i__2 = start + 1; + for (j = i__; j >= i__2; --j) { + if (d__[j] < d__[j - 1]) { + dmnmx = d__[j]; + d__[j] = d__[j - 1]; + d__[j - 1] = dmnmx; + } else { + goto L50; + } + } + L50:; + } + } + } else if (endd - start > 20) { + d1 = d__[start]; + d2 = d__[endd]; + i__ = (start + endd) / 2; + d3 = d__[i__]; + if (d1 < d2) { + if (d3 < d1) { + dmnmx = d1; + } else if (d3 < d2) { + dmnmx = d3; + } else { + dmnmx = d2; + } + } else { + if (d3 < d2) { + dmnmx = d2; + } else if (d3 < d1) { + dmnmx = d3; + } else { + dmnmx = d1; + } + } + if (dir == 0) { + i__ = start - 1; + j = endd + 1; + L60: + L70: + --j; + if (d__[j] < dmnmx) { + goto L70; + } + L80: + ++i__; + if (d__[i__] > dmnmx) { + goto L80; + } + if (i__ < j) { + tmp = d__[i__]; + d__[i__] = d__[j]; + d__[j] = tmp; + goto L60; + } + if (j - start > endd - j - 1) { + ++stkpnt; + stack[(stkpnt << 1) - 2] = start; + stack[(stkpnt << 1) - 1] = j; + ++stkpnt; + stack[(stkpnt << 1) - 2] = j + 1; + stack[(stkpnt << 1) - 1] = endd; + } else { + ++stkpnt; + stack[(stkpnt << 1) - 2] = j + 1; + stack[(stkpnt << 1) - 1] = endd; + ++stkpnt; + stack[(stkpnt << 1) - 2] = start; + stack[(stkpnt << 1) - 1] = j; + } + } else { + i__ = start - 1; + j = endd + 1; + L90: + L100: + --j; + if (d__[j] > dmnmx) { + goto L100; + } + L110: + ++i__; + if (d__[i__] < dmnmx) { + goto L110; + } + if (i__ < j) { + tmp = d__[i__]; + d__[i__] = d__[j]; + d__[j] = tmp; + goto L90; + } + if (j - start > endd - j - 1) { + ++stkpnt; + stack[(stkpnt << 1) - 2] = start; + stack[(stkpnt << 1) - 1] = j; + ++stkpnt; + stack[(stkpnt << 1) - 2] = j + 1; + stack[(stkpnt << 1) - 1] = endd; + } else { + ++stkpnt; + stack[(stkpnt << 1) - 2] = j + 1; + stack[(stkpnt << 1) - 1] = endd; + ++stkpnt; + stack[(stkpnt << 1) - 2] = start; + stack[(stkpnt << 1) - 1] = j; + } + } + } + if (stkpnt > 0) { + goto L10; + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlasrt.f b/lib/linalg/dlasrt.f deleted file mode 100644 index d789239e3d..0000000000 --- a/lib/linalg/dlasrt.f +++ /dev/null @@ -1,300 +0,0 @@ -*> \brief \b DLASRT sorts numbers in increasing or decreasing order. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASRT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLASRT( ID, N, D, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER ID -* INTEGER INFO, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION D( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> Sort the numbers in D in increasing order (if ID = 'I') or -*> in decreasing order (if ID = 'D' ). -*> -*> Use Quick Sort, reverting to Insertion sort on arrays of -*> size <= 20. Dimension of STACK limits N to about 2**32. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] ID -*> \verbatim -*> ID is CHARACTER*1 -*> = 'I': sort D in increasing order; -*> = 'D': sort D in decreasing order. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The length of the array D. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, the array to be sorted. -*> On exit, D has been sorted into increasing order -*> (D(1) <= ... <= D(N) ) or into decreasing order -*> (D(1) >= ... >= D(N) ), depending on ID. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -* ===================================================================== - SUBROUTINE DLASRT( ID, N, D, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER ID - INTEGER INFO, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - INTEGER SELECT - PARAMETER ( SELECT = 20 ) -* .. -* .. Local Scalars .. - INTEGER DIR, ENDD, I, J, START, STKPNT - DOUBLE PRECISION D1, D2, D3, DMNMX, TMP -* .. -* .. Local Arrays .. - INTEGER STACK( 2, 32 ) -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - DIR = -1 - IF( LSAME( ID, 'D' ) ) THEN - DIR = 0 - ELSE IF( LSAME( ID, 'I' ) ) THEN - DIR = 1 - END IF - IF( DIR.EQ.-1 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLASRT', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.1 ) - $ RETURN -* - STKPNT = 1 - STACK( 1, 1 ) = 1 - STACK( 2, 1 ) = N - 10 CONTINUE - START = STACK( 1, STKPNT ) - ENDD = STACK( 2, STKPNT ) - STKPNT = STKPNT - 1 - IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN -* -* Do Insertion sort on D( START:ENDD ) -* - IF( DIR.EQ.0 ) THEN -* -* Sort into decreasing order -* - DO 30 I = START + 1, ENDD - DO 20 J = I, START + 1, -1 - IF( D( J ).GT.D( J-1 ) ) THEN - DMNMX = D( J ) - D( J ) = D( J-1 ) - D( J-1 ) = DMNMX - ELSE - GO TO 30 - END IF - 20 CONTINUE - 30 CONTINUE -* - ELSE -* -* Sort into increasing order -* - DO 50 I = START + 1, ENDD - DO 40 J = I, START + 1, -1 - IF( D( J ).LT.D( J-1 ) ) THEN - DMNMX = D( J ) - D( J ) = D( J-1 ) - D( J-1 ) = DMNMX - ELSE - GO TO 50 - END IF - 40 CONTINUE - 50 CONTINUE -* - END IF -* - ELSE IF( ENDD-START.GT.SELECT ) THEN -* -* Partition D( START:ENDD ) and stack parts, largest one first -* -* Choose partition entry as median of 3 -* - D1 = D( START ) - D2 = D( ENDD ) - I = ( START+ENDD ) / 2 - D3 = D( I ) - IF( D1.LT.D2 ) THEN - IF( D3.LT.D1 ) THEN - DMNMX = D1 - ELSE IF( D3.LT.D2 ) THEN - DMNMX = D3 - ELSE - DMNMX = D2 - END IF - ELSE - IF( D3.LT.D2 ) THEN - DMNMX = D2 - ELSE IF( D3.LT.D1 ) THEN - DMNMX = D3 - ELSE - DMNMX = D1 - END IF - END IF -* - IF( DIR.EQ.0 ) THEN -* -* Sort into decreasing order -* - I = START - 1 - J = ENDD + 1 - 60 CONTINUE - 70 CONTINUE - J = J - 1 - IF( D( J ).LT.DMNMX ) - $ GO TO 70 - 80 CONTINUE - I = I + 1 - IF( D( I ).GT.DMNMX ) - $ GO TO 80 - IF( I.LT.J ) THEN - TMP = D( I ) - D( I ) = D( J ) - D( J ) = TMP - GO TO 60 - END IF - IF( J-START.GT.ENDD-J-1 ) THEN - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = START - STACK( 2, STKPNT ) = J - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = J + 1 - STACK( 2, STKPNT ) = ENDD - ELSE - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = J + 1 - STACK( 2, STKPNT ) = ENDD - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = START - STACK( 2, STKPNT ) = J - END IF - ELSE -* -* Sort into increasing order -* - I = START - 1 - J = ENDD + 1 - 90 CONTINUE - 100 CONTINUE - J = J - 1 - IF( D( J ).GT.DMNMX ) - $ GO TO 100 - 110 CONTINUE - I = I + 1 - IF( D( I ).LT.DMNMX ) - $ GO TO 110 - IF( I.LT.J ) THEN - TMP = D( I ) - D( I ) = D( J ) - D( J ) = TMP - GO TO 90 - END IF - IF( J-START.GT.ENDD-J-1 ) THEN - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = START - STACK( 2, STKPNT ) = J - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = J + 1 - STACK( 2, STKPNT ) = ENDD - ELSE - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = J + 1 - STACK( 2, STKPNT ) = ENDD - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = START - STACK( 2, STKPNT ) = J - END IF - END IF - END IF - IF( STKPNT.GT.0 ) - $ GO TO 10 - RETURN -* -* End of DLASRT -* - END diff --git a/lib/linalg/dlassq.cpp b/lib/linalg/dlassq.cpp new file mode 100644 index 0000000000..84e8690a14 --- /dev/null +++ b/lib/linalg/dlassq.cpp @@ -0,0 +1,34 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dlassq_(integer *n, doublereal *x, integer *incx, doublereal *scale, doublereal *sumsq) +{ + integer i__1, i__2; + doublereal d__1; + integer ix; + doublereal absxi; + extern logical disnan_(doublereal *); + --x; + if (*n > 0) { + i__1 = (*n - 1) * *incx + 1; + i__2 = *incx; + for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { + absxi = (d__1 = x[ix], abs(d__1)); + if (absxi > 0. || disnan_(&absxi)) { + if (*scale < absxi) { + d__1 = *scale / absxi; + *sumsq = *sumsq * (d__1 * d__1) + 1; + *scale = absxi; + } else { + d__1 = absxi / *scale; + *sumsq += d__1 * d__1; + } + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlassq.f b/lib/linalg/dlassq.f deleted file mode 100644 index 885395e3c9..0000000000 --- a/lib/linalg/dlassq.f +++ /dev/null @@ -1,155 +0,0 @@ -*> \brief \b DLASSQ updates a sum of squares represented in scaled form. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASSQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) -* -* .. Scalar Arguments .. -* INTEGER INCX, N -* DOUBLE PRECISION SCALE, SUMSQ -* .. -* .. Array Arguments .. -* DOUBLE PRECISION X( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLASSQ returns the values scl and smsq such that -*> -*> ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, -*> -*> where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is -*> assumed to be non-negative and scl returns the value -*> -*> scl = max( scale, abs( x( i ) ) ). -*> -*> scale and sumsq must be supplied in SCALE and SUMSQ and -*> scl and smsq are overwritten on SCALE and SUMSQ respectively. -*> -*> The routine makes only one pass through the vector x. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of elements to be used from the vector X. -*> \endverbatim -*> -*> \param[in] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension (N) -*> The vector for which a scaled sum of squares is computed. -*> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> The increment between successive values of the vector X. -*> INCX > 0. -*> \endverbatim -*> -*> \param[in,out] SCALE -*> \verbatim -*> SCALE is DOUBLE PRECISION -*> On entry, the value scale in the equation above. -*> On exit, SCALE is overwritten with scl , the scaling factor -*> for the sum of squares. -*> \endverbatim -*> -*> \param[in,out] SUMSQ -*> \verbatim -*> SUMSQ is DOUBLE PRECISION -*> On entry, the value sumsq in the equation above. -*> On exit, SUMSQ is overwritten with smsq , the basic sum of -*> squares from which scl has been factored out. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date December 2016 -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) -* -* -- LAPACK auxiliary routine (version 3.7.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - INTEGER INCX, N - DOUBLE PRECISION SCALE, SUMSQ -* .. -* .. Array Arguments .. - DOUBLE PRECISION X( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER IX - DOUBLE PRECISION ABSXI -* .. -* .. External Functions .. - LOGICAL DISNAN - EXTERNAL DISNAN -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS -* .. -* .. Executable Statements .. -* - IF( N.GT.0 ) THEN - DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX - ABSXI = ABS( X( IX ) ) - IF( ABSXI.GT.ZERO.OR.DISNAN( ABSXI ) ) THEN - IF( SCALE.LT.ABSXI ) THEN - SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2 - SCALE = ABSXI - ELSE - SUMSQ = SUMSQ + ( ABSXI / SCALE )**2 - END IF - END IF - 10 CONTINUE - END IF - RETURN -* -* End of DLASSQ -* - END diff --git a/lib/linalg/dlasv2.cpp b/lib/linalg/dlasv2.cpp new file mode 100644 index 0000000000..6de3269b8f --- /dev/null +++ b/lib/linalg/dlasv2.cpp @@ -0,0 +1,124 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static doublereal c_b3 = 2.; +static doublereal c_b4 = 1.; +int dlasv2_(doublereal *f, doublereal *g, doublereal *h__, doublereal *ssmin, doublereal *ssmax, + doublereal *snr, doublereal *csr, doublereal *snl, doublereal *csl) +{ + doublereal d__1; + double sqrt(doublereal), d_lmp_sign(doublereal *, doublereal *); + doublereal a, d__, l, m, r__, s, t, fa, ga, ha, ft, gt, ht, mm, tt, clt, crt, slt, srt; + integer pmax; + doublereal temp; + logical swap; + doublereal tsign; + extern doublereal dlamch_(char *, ftnlen); + logical gasmal; + ft = *f; + fa = abs(ft); + ht = *h__; + ha = abs(*h__); + pmax = 1; + swap = ha > fa; + if (swap) { + pmax = 3; + temp = ft; + ft = ht; + ht = temp; + temp = fa; + fa = ha; + ha = temp; + } + gt = *g; + ga = abs(gt); + if (ga == 0.) { + *ssmin = ha; + *ssmax = fa; + clt = 1.; + crt = 1.; + slt = 0.; + srt = 0.; + } else { + gasmal = TRUE_; + if (ga > fa) { + pmax = 2; + if (fa / ga < dlamch_((char *)"EPS", (ftnlen)3)) { + gasmal = FALSE_; + *ssmax = ga; + if (ha > 1.) { + *ssmin = fa / (ga / ha); + } else { + *ssmin = fa / ga * ha; + } + clt = 1.; + slt = ht / gt; + srt = 1.; + crt = ft / gt; + } + } + if (gasmal) { + d__ = fa - ha; + if (d__ == fa) { + l = 1.; + } else { + l = d__ / fa; + } + m = gt / ft; + t = 2. - l; + mm = m * m; + tt = t * t; + s = sqrt(tt + mm); + if (l == 0.) { + r__ = abs(m); + } else { + r__ = sqrt(l * l + mm); + } + a = (s + r__) * .5; + *ssmin = ha / a; + *ssmax = fa * a; + if (mm == 0.) { + if (l == 0.) { + t = d_lmp_sign(&c_b3, &ft) * d_lmp_sign(&c_b4, >); + } else { + t = gt / d_lmp_sign(&d__, &ft) + m / t; + } + } else { + t = (m / (s + t) + m / (r__ + l)) * (a + 1.); + } + l = sqrt(t * t + 4.); + crt = 2. / l; + srt = t / l; + clt = (crt + srt * m) / a; + slt = ht / ft * srt / a; + } + } + if (swap) { + *csl = srt; + *snl = crt; + *csr = slt; + *snr = clt; + } else { + *csl = clt; + *snl = slt; + *csr = crt; + *snr = srt; + } + if (pmax == 1) { + tsign = d_lmp_sign(&c_b4, csr) * d_lmp_sign(&c_b4, csl) * d_lmp_sign(&c_b4, f); + } + if (pmax == 2) { + tsign = d_lmp_sign(&c_b4, snr) * d_lmp_sign(&c_b4, csl) * d_lmp_sign(&c_b4, g); + } + if (pmax == 3) { + tsign = d_lmp_sign(&c_b4, snr) * d_lmp_sign(&c_b4, snl) * d_lmp_sign(&c_b4, h__); + } + *ssmax = d_lmp_sign(ssmax, &tsign); + d__1 = tsign * d_lmp_sign(&c_b4, f) * d_lmp_sign(&c_b4, h__); + *ssmin = d_lmp_sign(ssmin, &d__1); + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlasv2.f b/lib/linalg/dlasv2.f deleted file mode 100644 index 64a06dee1a..0000000000 --- a/lib/linalg/dlasv2.f +++ /dev/null @@ -1,322 +0,0 @@ -*> \brief \b DLASV2 computes the singular value decomposition of a 2-by-2 triangular matrix. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASV2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL ) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLASV2 computes the singular value decomposition of a 2-by-2 -*> triangular matrix -*> [ F G ] -*> [ 0 H ]. -*> On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the -*> smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and -*> right singular vectors for abs(SSMAX), giving the decomposition -*> -*> [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ] -*> [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ]. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] F -*> \verbatim -*> F is DOUBLE PRECISION -*> The (1,1) element of the 2-by-2 matrix. -*> \endverbatim -*> -*> \param[in] G -*> \verbatim -*> G is DOUBLE PRECISION -*> The (1,2) element of the 2-by-2 matrix. -*> \endverbatim -*> -*> \param[in] H -*> \verbatim -*> H is DOUBLE PRECISION -*> The (2,2) element of the 2-by-2 matrix. -*> \endverbatim -*> -*> \param[out] SSMIN -*> \verbatim -*> SSMIN is DOUBLE PRECISION -*> abs(SSMIN) is the smaller singular value. -*> \endverbatim -*> -*> \param[out] SSMAX -*> \verbatim -*> SSMAX is DOUBLE PRECISION -*> abs(SSMAX) is the larger singular value. -*> \endverbatim -*> -*> \param[out] SNL -*> \verbatim -*> SNL is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[out] CSL -*> \verbatim -*> CSL is DOUBLE PRECISION -*> The vector (CSL, SNL) is a unit left singular vector for the -*> singular value abs(SSMAX). -*> \endverbatim -*> -*> \param[out] SNR -*> \verbatim -*> SNR is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[out] CSR -*> \verbatim -*> CSR is DOUBLE PRECISION -*> The vector (CSR, SNR) is a unit right singular vector for the -*> singular value abs(SSMAX). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Any input parameter may be aliased with any output parameter. -*> -*> Barring over/underflow and assuming a guard digit in subtraction, all -*> output quantities are correct to within a few units in the last -*> place (ulps). -*> -*> In IEEE arithmetic, the code works correctly if one matrix element is -*> infinite. -*> -*> Overflow will not occur unless the largest singular value itself -*> overflows or is within a few ulps of overflow. (On machines with -*> partial overflow, like the Cray, overflow may occur if the largest -*> singular value is within a factor of 2 of overflow.) -*> -*> Underflow is harmless if underflow is gradual. Otherwise, results -*> may correspond to a matrix modified by perturbations of size near -*> the underflow threshold. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION HALF - PARAMETER ( HALF = 0.5D0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.0D0 ) - DOUBLE PRECISION FOUR - PARAMETER ( FOUR = 4.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL GASMAL, SWAP - INTEGER PMAX - DOUBLE PRECISION A, CLT, CRT, D, FA, FT, GA, GT, HA, HT, L, M, - $ MM, R, S, SLT, SRT, T, TEMP, TSIGN, TT -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SIGN, SQRT -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. Executable Statements .. -* - FT = F - FA = ABS( FT ) - HT = H - HA = ABS( H ) -* -* PMAX points to the maximum absolute element of matrix -* PMAX = 1 if F largest in absolute values -* PMAX = 2 if G largest in absolute values -* PMAX = 3 if H largest in absolute values -* - PMAX = 1 - SWAP = ( HA.GT.FA ) - IF( SWAP ) THEN - PMAX = 3 - TEMP = FT - FT = HT - HT = TEMP - TEMP = FA - FA = HA - HA = TEMP -* -* Now FA .ge. HA -* - END IF - GT = G - GA = ABS( GT ) - IF( GA.EQ.ZERO ) THEN -* -* Diagonal matrix -* - SSMIN = HA - SSMAX = FA - CLT = ONE - CRT = ONE - SLT = ZERO - SRT = ZERO - ELSE - GASMAL = .TRUE. - IF( GA.GT.FA ) THEN - PMAX = 2 - IF( ( FA / GA ).LT.DLAMCH( 'EPS' ) ) THEN -* -* Case of very large GA -* - GASMAL = .FALSE. - SSMAX = GA - IF( HA.GT.ONE ) THEN - SSMIN = FA / ( GA / HA ) - ELSE - SSMIN = ( FA / GA )*HA - END IF - CLT = ONE - SLT = HT / GT - SRT = ONE - CRT = FT / GT - END IF - END IF - IF( GASMAL ) THEN -* -* Normal case -* - D = FA - HA - IF( D.EQ.FA ) THEN -* -* Copes with infinite F or H -* - L = ONE - ELSE - L = D / FA - END IF -* -* Note that 0 .le. L .le. 1 -* - M = GT / FT -* -* Note that abs(M) .le. 1/macheps -* - T = TWO - L -* -* Note that T .ge. 1 -* - MM = M*M - TT = T*T - S = SQRT( TT+MM ) -* -* Note that 1 .le. S .le. 1 + 1/macheps -* - IF( L.EQ.ZERO ) THEN - R = ABS( M ) - ELSE - R = SQRT( L*L+MM ) - END IF -* -* Note that 0 .le. R .le. 1 + 1/macheps -* - A = HALF*( S+R ) -* -* Note that 1 .le. A .le. 1 + abs(M) -* - SSMIN = HA / A - SSMAX = FA*A - IF( MM.EQ.ZERO ) THEN -* -* Note that M is very tiny -* - IF( L.EQ.ZERO ) THEN - T = SIGN( TWO, FT )*SIGN( ONE, GT ) - ELSE - T = GT / SIGN( D, FT ) + M / T - END IF - ELSE - T = ( M / ( S+T )+M / ( R+L ) )*( ONE+A ) - END IF - L = SQRT( T*T+FOUR ) - CRT = TWO / L - SRT = T / L - CLT = ( CRT+SRT*M ) / A - SLT = ( HT / FT )*SRT / A - END IF - END IF - IF( SWAP ) THEN - CSL = SRT - SNL = CRT - CSR = SLT - SNR = CLT - ELSE - CSL = CLT - SNL = SLT - CSR = CRT - SNR = SRT - END IF -* -* Correct signs of SSMAX and SSMIN -* - IF( PMAX.EQ.1 ) - $ TSIGN = SIGN( ONE, CSR )*SIGN( ONE, CSL )*SIGN( ONE, F ) - IF( PMAX.EQ.2 ) - $ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, CSL )*SIGN( ONE, G ) - IF( PMAX.EQ.3 ) - $ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, SNL )*SIGN( ONE, H ) - SSMAX = SIGN( SSMAX, TSIGN ) - SSMIN = SIGN( SSMIN, TSIGN*SIGN( ONE, F )*SIGN( ONE, H ) ) - RETURN -* -* End of DLASV2 -* - END diff --git a/lib/linalg/dlaswp.cpp b/lib/linalg/dlaswp.cpp new file mode 100644 index 0000000000..d52226729f --- /dev/null +++ b/lib/linalg/dlaswp.cpp @@ -0,0 +1,71 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dlaswp_(integer *n, doublereal *a, integer *lda, integer *k1, integer *k2, integer *ipiv, + integer *incx) +{ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + integer i__, j, k, i1, i2, n32, ip, ix, ix0, inc; + doublereal 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) { + temp = a[i__ + k * a_dim1]; + a[i__ + k * a_dim1] = a[ip + k * a_dim1]; + a[ip + k * a_dim1] = temp; + } + } + 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) { + temp = a[i__ + k * a_dim1]; + a[i__ + k * a_dim1] = a[ip + k * a_dim1]; + a[ip + k * a_dim1] = temp; + } + } + ix += *incx; + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlaswp.f b/lib/linalg/dlaswp.f deleted file mode 100644 index b35729a205..0000000000 --- a/lib/linalg/dlaswp.f +++ /dev/null @@ -1,190 +0,0 @@ -*> \brief \b DLASWP performs a series of row interchanges on a general rectangular matrix. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLASWP + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) -* -* .. Scalar Arguments .. -* INTEGER INCX, K1, K2, LDA, N -* .. -* .. Array Arguments .. -* INTEGER IPIV( * ) -* DOUBLE PRECISION A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLASWP performs a series of row interchanges on the matrix A. -*> One row interchange is initiated for each of rows K1 through K2 of A. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the matrix of column dimension N to which the row -*> interchanges will be applied. -*> On exit, the permuted matrix. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. -*> \endverbatim -*> -*> \param[in] K1 -*> \verbatim -*> K1 is INTEGER -*> The first element of IPIV for which a row interchange will -*> be done. -*> \endverbatim -*> -*> \param[in] K2 -*> \verbatim -*> K2 is INTEGER -*> (K2-K1+1) is the number of elements of IPIV for which a row -*> interchange will be done. -*> \endverbatim -*> -*> \param[in] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (K1+(K2-K1)*abs(INCX)) -*> The vector of pivot indices. Only the elements in positions -*> K1 through K1+(K2-K1)*abs(INCX) of IPIV are accessed. -*> IPIV(K1+(K-K1)*abs(INCX)) = L implies rows K and L are to be -*> interchanged. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> The increment between successive values of IPIV. If INCX -*> is negative, the pivots are applied in reverse order. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Modified by -*> R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX, K1, K2, LDA, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 - DOUBLE PRECISION TEMP -* .. -* .. Executable Statements .. -* -* Interchange row I with row IPIV(K1+(I-K1)*abs(INCX)) for each of rows -* K1 through K2. -* - IF( INCX.GT.0 ) THEN - IX0 = K1 - I1 = K1 - I2 = K2 - INC = 1 - ELSE IF( INCX.LT.0 ) THEN - IX0 = K1 + ( K1-K2 )*INCX - I1 = K2 - I2 = K1 - INC = -1 - ELSE - RETURN - END IF -* - N32 = ( N / 32 )*32 - IF( N32.NE.0 ) THEN - DO 30 J = 1, N32, 32 - IX = IX0 - DO 20 I = I1, I2, INC - IP = IPIV( IX ) - IF( IP.NE.I ) THEN - DO 10 K = J, J + 31 - TEMP = A( I, K ) - A( I, K ) = A( IP, K ) - A( IP, K ) = TEMP - 10 CONTINUE - END IF - IX = IX + INCX - 20 CONTINUE - 30 CONTINUE - END IF - IF( N32.NE.N ) THEN - N32 = N32 + 1 - IX = IX0 - DO 50 I = I1, I2, INC - IP = IPIV( IX ) - IF( IP.NE.I ) THEN - DO 40 K = N32, N - TEMP = A( I, K ) - A( I, K ) = A( IP, K ) - A( IP, K ) = TEMP - 40 CONTINUE - END IF - IX = IX + INCX - 50 CONTINUE - END IF -* - RETURN -* -* End of DLASWP -* - END diff --git a/lib/linalg/dlatrd.cpp b/lib/linalg/dlatrd.cpp new file mode 100644 index 0000000000..32b131c233 --- /dev/null +++ b/lib/linalg/dlatrd.cpp @@ -0,0 +1,147 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static doublereal c_b5 = -1.; +static doublereal c_b6 = 1.; +static integer c__1 = 1; +static doublereal c_b16 = 0.; +int dlatrd_(char *uplo, integer *n, integer *nb, doublereal *a, integer *lda, doublereal *e, + doublereal *tau, doublereal *w, integer *ldw, ftnlen uplo_len) +{ + integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3; + integer i__, iw; + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *); + doublereal alpha; + extern int dscal_(integer *, doublereal *, doublereal *, integer *); + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern int dgemv_(char *, integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, ftnlen), + daxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *), + dsymv_(char *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, ftnlen), + dlarfg_(integer *, doublereal *, doublereal *, integer *, doublereal *); + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --e; + --tau; + w_dim1 = *ldw; + w_offset = 1 + w_dim1; + w -= w_offset; + if (*n <= 0) { + return 0; + } + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + i__1 = *n - *nb + 1; + for (i__ = *n; i__ >= i__1; --i__) { + iw = i__ - *n + *nb; + if (i__ < *n) { + i__2 = *n - i__; + dgemv_((char *)"No transpose", &i__, &i__2, &c_b5, &a[(i__ + 1) * a_dim1 + 1], lda, + &w[i__ + (iw + 1) * w_dim1], ldw, &c_b6, &a[i__ * a_dim1 + 1], &c__1, + (ftnlen)12); + i__2 = *n - i__; + dgemv_((char *)"No transpose", &i__, &i__2, &c_b5, &w[(iw + 1) * w_dim1 + 1], ldw, + &a[i__ + (i__ + 1) * a_dim1], lda, &c_b6, &a[i__ * a_dim1 + 1], &c__1, + (ftnlen)12); + } + if (i__ > 1) { + i__2 = i__ - 1; + dlarfg_(&i__2, &a[i__ - 1 + i__ * a_dim1], &a[i__ * a_dim1 + 1], &c__1, + &tau[i__ - 1]); + e[i__ - 1] = a[i__ - 1 + i__ * a_dim1]; + a[i__ - 1 + i__ * a_dim1] = 1.; + i__2 = i__ - 1; + dsymv_((char *)"Upper", &i__2, &c_b6, &a[a_offset], lda, &a[i__ * a_dim1 + 1], &c__1, + &c_b16, &w[iw * w_dim1 + 1], &c__1, (ftnlen)5); + if (i__ < *n) { + i__2 = i__ - 1; + i__3 = *n - i__; + dgemv_((char *)"Transpose", &i__2, &i__3, &c_b6, &w[(iw + 1) * w_dim1 + 1], ldw, + &a[i__ * a_dim1 + 1], &c__1, &c_b16, &w[i__ + 1 + iw * w_dim1], &c__1, + (ftnlen)9); + i__2 = i__ - 1; + i__3 = *n - i__; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[(i__ + 1) * a_dim1 + 1], lda, + &w[i__ + 1 + iw * w_dim1], &c__1, &c_b6, &w[iw * w_dim1 + 1], &c__1, + (ftnlen)12); + i__2 = i__ - 1; + i__3 = *n - i__; + dgemv_((char *)"Transpose", &i__2, &i__3, &c_b6, &a[(i__ + 1) * a_dim1 + 1], lda, + &a[i__ * a_dim1 + 1], &c__1, &c_b16, &w[i__ + 1 + iw * w_dim1], &c__1, + (ftnlen)9); + i__2 = i__ - 1; + i__3 = *n - i__; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &w[(iw + 1) * w_dim1 + 1], ldw, + &w[i__ + 1 + iw * w_dim1], &c__1, &c_b6, &w[iw * w_dim1 + 1], &c__1, + (ftnlen)12); + } + i__2 = i__ - 1; + dscal_(&i__2, &tau[i__ - 1], &w[iw * w_dim1 + 1], &c__1); + i__2 = i__ - 1; + alpha = tau[i__ - 1] * -.5 * + ddot_(&i__2, &w[iw * w_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &c__1); + i__2 = i__ - 1; + daxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &w[iw * w_dim1 + 1], &c__1); + } + } + } else { + i__1 = *nb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n - i__ + 1; + i__3 = i__ - 1; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[i__ + a_dim1], lda, &w[i__ + w_dim1], + ldw, &c_b6, &a[i__ + i__ * a_dim1], &c__1, (ftnlen)12); + i__2 = *n - i__ + 1; + i__3 = i__ - 1; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &w[i__ + w_dim1], ldw, &a[i__ + a_dim1], + lda, &c_b6, &a[i__ + i__ * a_dim1], &c__1, (ftnlen)12); + if (i__ < *n) { + i__2 = *n - 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__]); + e[i__] = a[i__ + 1 + i__ * a_dim1]; + a[i__ + 1 + i__ * a_dim1] = 1.; + i__2 = *n - i__; + dsymv_((char *)"Lower", &i__2, &c_b6, &a[i__ + 1 + (i__ + 1) * a_dim1], lda, + &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[i__ + 1 + i__ * w_dim1], &c__1, + (ftnlen)5); + i__2 = *n - i__; + i__3 = i__ - 1; + dgemv_((char *)"Transpose", &i__2, &i__3, &c_b6, &w[i__ + 1 + w_dim1], ldw, + &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[i__ * w_dim1 + 1], &c__1, + (ftnlen)9); + i__2 = *n - i__; + i__3 = i__ - 1; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + a_dim1], lda, + &w[i__ * w_dim1 + 1], &c__1, &c_b6, &w[i__ + 1 + i__ * w_dim1], &c__1, + (ftnlen)12); + i__2 = *n - i__; + i__3 = i__ - 1; + dgemv_((char *)"Transpose", &i__2, &i__3, &c_b6, &a[i__ + 1 + a_dim1], lda, + &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[i__ * w_dim1 + 1], &c__1, + (ftnlen)9); + i__2 = *n - i__; + i__3 = i__ - 1; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b5, &w[i__ + 1 + w_dim1], ldw, + &w[i__ * w_dim1 + 1], &c__1, &c_b6, &w[i__ + 1 + i__ * w_dim1], &c__1, + (ftnlen)12); + i__2 = *n - i__; + dscal_(&i__2, &tau[i__], &w[i__ + 1 + i__ * w_dim1], &c__1); + i__2 = *n - i__; + alpha = tau[i__] * -.5 * + ddot_(&i__2, &w[i__ + 1 + i__ * w_dim1], &c__1, &a[i__ + 1 + i__ * a_dim1], + &c__1); + i__2 = *n - i__; + daxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &w[i__ + 1 + i__ * w_dim1], + &c__1); + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlatrd.f b/lib/linalg/dlatrd.f deleted file mode 100644 index 010a85a212..0000000000 --- a/lib/linalg/dlatrd.f +++ /dev/null @@ -1,333 +0,0 @@ -*> \brief \b DLATRD reduces the first nb rows and columns of a symmetric/Hermitian matrix A to real tridiagonal form by an orthogonal similarity transformation. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLATRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER LDA, LDW, N, NB -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), E( * ), TAU( * ), W( LDW, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLATRD reduces NB rows and columns of a real symmetric matrix A to -*> symmetric tridiagonal form by an orthogonal similarity -*> transformation Q**T * A * Q, and returns the matrices V and W which are -*> needed to apply the transformation to the unreduced part of A. -*> -*> If UPLO = 'U', DLATRD reduces the last NB rows and columns of a -*> matrix, of which the upper triangle is supplied; -*> if UPLO = 'L', DLATRD reduces the first NB rows and columns of a -*> matrix, of which the lower triangle is supplied. -*> -*> This is an auxiliary routine called by DSYTRD. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> Specifies whether the upper or lower triangular part of the -*> symmetric matrix A is stored: -*> = 'U': Upper triangular -*> = 'L': Lower triangular -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. -*> \endverbatim -*> -*> \param[in] NB -*> \verbatim -*> NB is INTEGER -*> The number of rows and columns to be reduced. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the symmetric matrix A. If UPLO = 'U', the leading -*> n-by-n upper triangular part of A contains the upper -*> triangular part of the matrix A, and the strictly lower -*> triangular part of A is not referenced. If UPLO = 'L', the -*> leading n-by-n lower triangular part of A contains the lower -*> triangular part of the matrix A, and the strictly upper -*> triangular part of A is not referenced. -*> On exit: -*> if UPLO = 'U', the last NB columns have been reduced to -*> tridiagonal form, with the diagonal elements overwriting -*> the diagonal elements of A; the elements above the diagonal -*> with the array TAU, represent the orthogonal matrix Q as a -*> product of elementary reflectors; -*> if UPLO = 'L', the first NB columns have been reduced to -*> tridiagonal form, with the diagonal elements overwriting -*> the diagonal elements of A; the elements below the diagonal -*> with the array TAU, represent the orthogonal matrix Q as a -*> product of elementary reflectors. -*> See Further Details. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= (1,N). -*> \endverbatim -*> -*> \param[out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N-1) -*> If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal -*> elements of the last NB columns of the reduced matrix; -*> if UPLO = 'L', E(1:nb) contains the subdiagonal elements of -*> the first NB columns of the reduced matrix. -*> \endverbatim -*> -*> \param[out] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (N-1) -*> The scalar factors of the elementary reflectors, stored in -*> TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. -*> See Further Details. -*> \endverbatim -*> -*> \param[out] W -*> \verbatim -*> W is DOUBLE PRECISION array, dimension (LDW,NB) -*> The n-by-nb matrix W required to update the unreduced part -*> of A. -*> \endverbatim -*> -*> \param[in] LDW -*> \verbatim -*> LDW is INTEGER -*> The leading dimension of the array W. LDW >= max(1,N). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> If UPLO = 'U', the matrix Q is represented as a product of elementary -*> reflectors -*> -*> Q = H(n) H(n-1) . . . H(n-nb+1). -*> -*> Each H(i) has the form -*> -*> H(i) = I - tau * v * v**T -*> -*> where tau is a real scalar, and v is a real vector with -*> v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), -*> and tau in TAU(i-1). -*> -*> If UPLO = 'L', the matrix Q is represented as a product of elementary -*> reflectors -*> -*> Q = H(1) H(2) . . . H(nb). -*> -*> Each H(i) has the form -*> -*> H(i) = I - tau * v * v**T -*> -*> where tau is a real scalar, and v is a real vector with -*> v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), -*> and tau in TAU(i). -*> -*> The elements of the vectors v together form the n-by-nb matrix V -*> which is needed, with W, to apply the transformation to the unreduced -*> part of the matrix, using a symmetric rank-2k update of the form: -*> A := A - V*W**T - W*V**T. -*> -*> The contents of A on exit are illustrated by the following examples -*> with n = 5 and nb = 2: -*> -*> if UPLO = 'U': if UPLO = 'L': -*> -*> ( a a a v4 v5 ) ( d ) -*> ( a a v4 v5 ) ( 1 d ) -*> ( a 1 v5 ) ( v1 1 a ) -*> ( d 1 ) ( v1 v2 a a ) -*> ( d ) ( v1 v2 a a a ) -*> -*> where d denotes a diagonal element of the reduced matrix, a denotes -*> an element of the original matrix that is unchanged, and vi denotes -*> an element of the vector defining H(i). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, LDW, N, NB -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), E( * ), TAU( * ), W( LDW, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE, HALF - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, IW - DOUBLE PRECISION ALPHA -* .. -* .. External Subroutines .. - EXTERNAL DAXPY, DGEMV, DLARFG, DSCAL, DSYMV -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DDOT - EXTERNAL LSAME, DDOT -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* - IF( LSAME( UPLO, 'U' ) ) THEN -* -* Reduce last NB columns of upper triangle -* - DO 10 I = N, N - NB + 1, -1 - IW = I - N + NB - IF( I.LT.N ) THEN -* -* Update A(1:i,i) -* - CALL DGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ), - $ LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 ) - CALL DGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ), - $ LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 ) - END IF - IF( I.GT.1 ) THEN -* -* Generate elementary reflector H(i) to annihilate -* A(1:i-2,i) -* - CALL DLARFG( I-1, A( I-1, I ), A( 1, I ), 1, TAU( I-1 ) ) - E( I-1 ) = A( I-1, I ) - A( I-1, I ) = ONE -* -* Compute W(1:i-1,i) -* - CALL DSYMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1, - $ ZERO, W( 1, IW ), 1 ) - IF( I.LT.N ) THEN - CALL DGEMV( 'Transpose', I-1, N-I, ONE, W( 1, IW+1 ), - $ LDW, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I, -ONE, - $ A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE, - $ W( 1, IW ), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, A( 1, I+1 ), - $ LDA, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I, -ONE, - $ W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE, - $ W( 1, IW ), 1 ) - END IF - CALL DSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 ) - ALPHA = -HALF*TAU( I-1 )*DDOT( I-1, W( 1, IW ), 1, - $ A( 1, I ), 1 ) - CALL DAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 ) - END IF -* - 10 CONTINUE - ELSE -* -* Reduce first NB columns of lower triangle -* - DO 20 I = 1, NB -* -* Update A(i:n,i) -* - CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ), - $ LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 ) - CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ), - $ LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 ) - IF( I.LT.N ) THEN -* -* Generate elementary reflector H(i) to annihilate -* A(i+2:n,i) -* - CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, - $ TAU( I ) ) - E( I ) = A( I+1, I ) - A( I+1, I ) = ONE -* -* Compute W(i+1:n,i) -* - CALL DSYMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA, - $ A( I+1, I ), 1, ZERO, W( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, W( I+1, 1 ), LDW, - $ A( I+1, I ), 1, ZERO, W( 1, I ), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ), - $ LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA, - $ A( I+1, I ), 1, ZERO, W( 1, I ), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ), - $ LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) - CALL DSCAL( N-I, TAU( I ), W( I+1, I ), 1 ) - ALPHA = -HALF*TAU( I )*DDOT( N-I, W( I+1, I ), 1, - $ A( I+1, I ), 1 ) - CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 ) - END IF -* - 20 CONTINUE - END IF -* - RETURN -* -* End of DLATRD -* - END diff --git a/lib/linalg/dlatrs.cpp b/lib/linalg/dlatrs.cpp new file mode 100644 index 0000000000..bd2af669dc --- /dev/null +++ b/lib/linalg/dlatrs.cpp @@ -0,0 +1,432 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +static doublereal c_b46 = .5; +int dlatrs_(char *uplo, char *trans, char *diag, char *normin, integer *n, doublereal *a, + integer *lda, doublereal *x, doublereal *scale, doublereal *cnorm, integer *info, + ftnlen uplo_len, ftnlen trans_len, ftnlen diag_len, ftnlen normin_len) +{ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublereal d__1, d__2, d__3; + integer i__, j; + doublereal xj, rec, tjj; + integer jinc; + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *); + doublereal xbnd; + integer imax; + doublereal tmax, tjjs, xmax, grow, sumj; + extern int dscal_(integer *, doublereal *, doublereal *, integer *); + extern logical lsame_(char *, char *, ftnlen, ftnlen); + doublereal tscal, uscal; + extern doublereal dasum_(integer *, doublereal *, integer *); + integer jlast; + extern int daxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *); + logical upper; + extern int dtrsv_(char *, char *, char *, integer *, doublereal *, integer *, doublereal *, + integer *, ftnlen, ftnlen, ftnlen); + extern doublereal dlamch_(char *, ftnlen), + dlange_(char *, integer *, integer *, doublereal *, integer *, doublereal *, ftnlen); + extern integer idamax_(integer *, doublereal *, integer *); + extern int xerbla_(char *, integer *, ftnlen); + doublereal bignum; + logical notran; + integer jfirst; + doublereal smlnum; + logical nounit; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + --cnorm; + *info = 0; + upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); + notran = lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1); + nounit = lsame_(diag, (char *)"N", (ftnlen)1, (ftnlen)1); + if (!upper && !lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { + *info = -1; + } else if (!notran && !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 (!lsame_(normin, (char *)"Y", (ftnlen)1, (ftnlen)1) && + !lsame_(normin, (char *)"N", (ftnlen)1, (ftnlen)1)) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*lda < max(1, *n)) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DLATRS", &i__1, (ftnlen)6); + return 0; + } + *scale = 1.; + if (*n == 0) { + return 0; + } + smlnum = dlamch_((char *)"Safe minimum", (ftnlen)12) / dlamch_((char *)"Precision", (ftnlen)9); + bignum = 1. / smlnum; + if (lsame_(normin, (char *)"N", (ftnlen)1, (ftnlen)1)) { + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + cnorm[j] = dasum_(&i__2, &a[j * a_dim1 + 1], &c__1); + } + } else { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = *n - j; + cnorm[j] = dasum_(&i__2, &a[j + 1 + j * a_dim1], &c__1); + } + cnorm[*n] = 0.; + } + } + imax = idamax_(n, &cnorm[1], &c__1); + tmax = cnorm[imax]; + if (tmax <= bignum) { + tscal = 1.; + } else { + if (tmax <= dlamch_((char *)"Overflow", (ftnlen)8)) { + tscal = 1. / (smlnum * tmax); + dscal_(n, &tscal, &cnorm[1], &c__1); + } else { + tmax = 0.; + if (upper) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + i__2 = j - 1; + d__1 = dlange_((char *)"M", &i__2, &c__1, &a[j * a_dim1 + 1], &c__1, &sumj, (ftnlen)1); + tmax = max(d__1, tmax); + } + } else { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = *n - j; + d__1 = + dlange_((char *)"M", &i__2, &c__1, &a[j + 1 + j * a_dim1], &c__1, &sumj, (ftnlen)1); + tmax = max(d__1, tmax); + } + } + if (tmax <= dlamch_((char *)"Overflow", (ftnlen)8)) { + tscal = 1. / (smlnum * tmax); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (cnorm[j] <= dlamch_((char *)"Overflow", (ftnlen)8)) { + cnorm[j] *= tscal; + } else { + cnorm[j] = 0.; + if (upper) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + cnorm[j] += tscal * (d__1 = a[i__ + j * a_dim1], abs(d__1)); + } + } else { + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + cnorm[j] += tscal * (d__1 = a[i__ + j * a_dim1], abs(d__1)); + } + } + } + } + } else { + dtrsv_(uplo, trans, diag, n, &a[a_offset], lda, &x[1], &c__1, (ftnlen)1, (ftnlen)1, + (ftnlen)1); + return 0; + } + } + } + j = idamax_(n, &x[1], &c__1); + xmax = (d__1 = x[j], abs(d__1)); + xbnd = xmax; + if (notran) { + if (upper) { + jfirst = *n; + jlast = 1; + jinc = -1; + } else { + jfirst = 1; + jlast = *n; + jinc = 1; + } + if (tscal != 1.) { + grow = 0.; + goto L50; + } + if (nounit) { + grow = 1. / max(xbnd, smlnum); + xbnd = grow; + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + if (grow <= smlnum) { + goto L50; + } + tjj = (d__1 = a[j + j * a_dim1], abs(d__1)); + d__1 = xbnd, d__2 = min(1., tjj) * grow; + xbnd = min(d__1, d__2); + if (tjj + cnorm[j] >= smlnum) { + grow *= tjj / (tjj + cnorm[j]); + } else { + grow = 0.; + } + } + grow = xbnd; + } else { + d__1 = 1., d__2 = 1. / max(xbnd, smlnum); + grow = min(d__1, d__2); + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + if (grow <= smlnum) { + goto L50; + } + grow *= 1. / (cnorm[j] + 1.); + } + } + L50:; + } else { + if (upper) { + jfirst = 1; + jlast = *n; + jinc = 1; + } else { + jfirst = *n; + jlast = 1; + jinc = -1; + } + if (tscal != 1.) { + grow = 0.; + goto L80; + } + if (nounit) { + grow = 1. / max(xbnd, smlnum); + xbnd = grow; + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + if (grow <= smlnum) { + goto L80; + } + xj = cnorm[j] + 1.; + d__1 = grow, d__2 = xbnd / xj; + grow = min(d__1, d__2); + tjj = (d__1 = a[j + j * a_dim1], abs(d__1)); + if (xj > tjj) { + xbnd *= tjj / xj; + } + } + grow = min(grow, xbnd); + } else { + d__1 = 1., d__2 = 1. / max(xbnd, smlnum); + grow = min(d__1, d__2); + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + if (grow <= smlnum) { + goto L80; + } + xj = cnorm[j] + 1.; + grow /= xj; + } + } + L80:; + } + if (grow * tscal > smlnum) { + dtrsv_(uplo, trans, diag, n, &a[a_offset], lda, &x[1], &c__1, (ftnlen)1, (ftnlen)1, + (ftnlen)1); + } else { + if (xmax > bignum) { + *scale = bignum / xmax; + dscal_(n, scale, &x[1], &c__1); + xmax = bignum; + } + if (notran) { + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + xj = (d__1 = x[j], abs(d__1)); + if (nounit) { + tjjs = a[j + j * a_dim1] * tscal; + } else { + tjjs = tscal; + if (tscal == 1.) { + goto L100; + } + } + tjj = abs(tjjs); + if (tjj > smlnum) { + if (tjj < 1.) { + if (xj > tjj * bignum) { + rec = 1. / xj; + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + x[j] /= tjjs; + xj = (d__1 = x[j], abs(d__1)); + } else if (tjj > 0.) { + if (xj > tjj * bignum) { + rec = tjj * bignum / xj; + if (cnorm[j] > 1.) { + rec /= cnorm[j]; + } + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + x[j] /= tjjs; + xj = (d__1 = x[j], abs(d__1)); + } else { + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + x[i__] = 0.; + } + x[j] = 1.; + xj = 1.; + *scale = 0.; + xmax = 0.; + } + L100: + if (xj > 1.) { + rec = 1. / xj; + if (cnorm[j] > (bignum - xmax) * rec) { + rec *= .5; + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + } + } else if (xj * cnorm[j] > bignum - xmax) { + dscal_(n, &c_b46, &x[1], &c__1); + *scale *= .5; + } + if (upper) { + if (j > 1) { + i__3 = j - 1; + d__1 = -x[j] * tscal; + daxpy_(&i__3, &d__1, &a[j * a_dim1 + 1], &c__1, &x[1], &c__1); + i__3 = j - 1; + i__ = idamax_(&i__3, &x[1], &c__1); + xmax = (d__1 = x[i__], abs(d__1)); + } + } else { + if (j < *n) { + i__3 = *n - j; + d__1 = -x[j] * tscal; + daxpy_(&i__3, &d__1, &a[j + 1 + j * a_dim1], &c__1, &x[j + 1], &c__1); + i__3 = *n - j; + i__ = j + idamax_(&i__3, &x[j + 1], &c__1); + xmax = (d__1 = x[i__], abs(d__1)); + } + } + } + } else { + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + xj = (d__1 = x[j], abs(d__1)); + uscal = tscal; + rec = 1. / max(xmax, 1.); + if (cnorm[j] > (bignum - xj) * rec) { + rec *= .5; + if (nounit) { + tjjs = a[j + j * a_dim1] * tscal; + } else { + tjjs = tscal; + } + tjj = abs(tjjs); + if (tjj > 1.) { + d__1 = 1., d__2 = rec * tjj; + rec = min(d__1, d__2); + uscal /= tjjs; + } + if (rec < 1.) { + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + sumj = 0.; + if (uscal == 1.) { + if (upper) { + i__3 = j - 1; + sumj = ddot_(&i__3, &a[j * a_dim1 + 1], &c__1, &x[1], &c__1); + } else if (j < *n) { + i__3 = *n - j; + sumj = ddot_(&i__3, &a[j + 1 + j * a_dim1], &c__1, &x[j + 1], &c__1); + } + } else { + if (upper) { + i__3 = j - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + sumj += a[i__ + j * a_dim1] * uscal * x[i__]; + } + } else if (j < *n) { + i__3 = *n; + for (i__ = j + 1; i__ <= i__3; ++i__) { + sumj += a[i__ + j * a_dim1] * uscal * x[i__]; + } + } + } + if (uscal == tscal) { + x[j] -= sumj; + xj = (d__1 = x[j], abs(d__1)); + if (nounit) { + tjjs = a[j + j * a_dim1] * tscal; + } else { + tjjs = tscal; + if (tscal == 1.) { + goto L150; + } + } + tjj = abs(tjjs); + if (tjj > smlnum) { + if (tjj < 1.) { + if (xj > tjj * bignum) { + rec = 1. / xj; + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + x[j] /= tjjs; + } else if (tjj > 0.) { + if (xj > tjj * bignum) { + rec = tjj * bignum / xj; + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + x[j] /= tjjs; + } else { + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + x[i__] = 0.; + } + x[j] = 1.; + *scale = 0.; + xmax = 0.; + } + L150:; + } else { + x[j] = x[j] / tjjs - sumj; + } + d__2 = xmax, d__3 = (d__1 = x[j], abs(d__1)); + xmax = max(d__2, d__3); + } + } + *scale /= tscal; + } + if (tscal != 1.) { + d__1 = 1. / tscal; + dscal_(n, &d__1, &cnorm[1], &c__1); + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dlatrs.f b/lib/linalg/dlatrs.f deleted file mode 100644 index be156bee20..0000000000 --- a/lib/linalg/dlatrs.f +++ /dev/null @@ -1,843 +0,0 @@ -*> \brief \b DLATRS solves a triangular system of equations with the scale factor set to prevent overflow. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLATRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, -* CNORM, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER DIAG, NORMIN, TRANS, UPLO -* INTEGER INFO, LDA, N -* DOUBLE PRECISION SCALE -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), CNORM( * ), X( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DLATRS solves one of the triangular systems -*> -*> A *x = s*b or A**T *x = s*b -*> -*> with scaling to prevent overflow. Here A is an upper or lower -*> triangular matrix, A**T denotes the transpose of A, x and b are -*> n-element vectors, and s is a scaling factor, usually less than -*> or equal to 1, chosen so that the components of x will be less than -*> the overflow threshold. If the unscaled problem will not cause -*> overflow, the Level 2 BLAS routine DTRSV is called. If the matrix A -*> is singular (A(j,j) = 0 for some j), then s is set to 0 and a -*> non-trivial solution to A*x = 0 is returned. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> Specifies whether the matrix A is upper or lower triangular. -*> = 'U': Upper triangular -*> = 'L': Lower triangular -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> Specifies the operation applied to A. -*> = 'N': Solve A * x = s*b (No transpose) -*> = 'T': Solve A**T* x = s*b (Transpose) -*> = 'C': Solve A**T* x = s*b (Conjugate transpose = Transpose) -*> \endverbatim -*> -*> \param[in] DIAG -*> \verbatim -*> DIAG is CHARACTER*1 -*> Specifies whether or not the matrix A is unit triangular. -*> = 'N': Non-unit triangular -*> = 'U': Unit triangular -*> \endverbatim -*> -*> \param[in] NORMIN -*> \verbatim -*> NORMIN is CHARACTER*1 -*> Specifies whether CNORM has been set or not. -*> = 'Y': CNORM contains the column norms on entry -*> = 'N': CNORM is not set on entry. On exit, the norms will -*> be computed and stored in CNORM. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> The triangular matrix A. If UPLO = 'U', the leading n by n -*> upper triangular part of the array A contains the upper -*> triangular matrix, and the strictly lower triangular part of -*> A is not referenced. If UPLO = 'L', the leading n by n lower -*> triangular part of the array A contains the lower triangular -*> matrix, and the strictly upper triangular part of A is not -*> referenced. If DIAG = 'U', the diagonal elements of A are -*> also not referenced and are assumed to be 1. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max (1,N). -*> \endverbatim -*> -*> \param[in,out] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension (N) -*> On entry, the right hand side b of the triangular system. -*> On exit, X is overwritten by the solution vector x. -*> \endverbatim -*> -*> \param[out] SCALE -*> \verbatim -*> SCALE is DOUBLE PRECISION -*> The scaling factor s for the triangular system -*> A * x = s*b or A**T* x = s*b. -*> If SCALE = 0, the matrix A is singular or badly scaled, and -*> the vector x is an exact or approximate solution to A*x = 0. -*> \endverbatim -*> -*> \param[in,out] CNORM -*> \verbatim -*> CNORM is DOUBLE PRECISION array, dimension (N) -*> -*> If NORMIN = 'Y', CNORM is an input argument and CNORM(j) -*> contains the norm of the off-diagonal part of the j-th column -*> of A. If TRANS = 'N', CNORM(j) must be greater than or equal -*> to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) -*> must be greater than or equal to the 1-norm. -*> -*> If NORMIN = 'N', CNORM is an output argument and CNORM(j) -*> returns the 1-norm of the offdiagonal part of the j-th column -*> of A. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -k, the k-th argument had an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> A rough bound on x is computed; if that is less than overflow, DTRSV -*> is called, otherwise, specific code is used which checks for possible -*> overflow or divide-by-zero at every operation. -*> -*> A columnwise scheme is used for solving A*x = b. The basic algorithm -*> if A is lower triangular is -*> -*> x[1:n] := b[1:n] -*> for j = 1, ..., n -*> x(j) := x(j) / A(j,j) -*> x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] -*> end -*> -*> Define bounds on the components of x after j iterations of the loop: -*> M(j) = bound on x[1:j] -*> G(j) = bound on x[j+1:n] -*> Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. -*> -*> Then for iteration j+1 we have -*> M(j+1) <= G(j) / | A(j+1,j+1) | -*> G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | -*> <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) -*> -*> where CNORM(j+1) is greater than or equal to the infinity-norm of -*> column j+1 of A, not counting the diagonal. Hence -*> -*> G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) -*> 1<=i<=j -*> and -*> -*> |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) -*> 1<=i< j -*> -*> Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTRSV if the -*> reciprocal of the largest M(j), j=1,..,n, is larger than -*> max(underflow, 1/overflow). -*> -*> The bound on x(j) is also used to determine when a step in the -*> columnwise method can be performed without fear of overflow. If -*> the computed bound is greater than a large constant, x is scaled to -*> prevent overflow, but if the bound overflows, x is set to 0, x(j) to -*> 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. -*> -*> Similarly, a row-wise scheme is used to solve A**T*x = b. The basic -*> algorithm for A upper triangular is -*> -*> for j = 1, ..., n -*> x(j) := ( b(j) - A[1:j-1,j]**T * x[1:j-1] ) / A(j,j) -*> end -*> -*> We simultaneously compute two bounds -*> G(j) = bound on ( b(i) - A[1:i-1,i]**T * x[1:i-1] ), 1<=i<=j -*> M(j) = bound on x(i), 1<=i<=j -*> -*> The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we -*> add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. -*> Then the bound on x(j) is -*> -*> M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | -*> -*> <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) -*> 1<=i<=j -*> -*> and we can safely call DTRSV if 1/M(n) and 1/G(n) are both greater -*> than max(underflow, 1/overflow). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, - $ CNORM, INFO ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER DIAG, NORMIN, TRANS, UPLO - INTEGER INFO, LDA, N - DOUBLE PRECISION SCALE -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), CNORM( * ), X( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOTRAN, NOUNIT, UPPER - INTEGER I, IMAX, J, JFIRST, JINC, JLAST - DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS, - $ TMAX, TSCAL, USCAL, XBND, XJ, XMAX -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - DOUBLE PRECISION DASUM, DDOT, DLAMCH, DLANGE - EXTERNAL LSAME, IDAMAX, DASUM, DDOT, DLAMCH, DLANGE -* .. -* .. External Subroutines .. - EXTERNAL DAXPY, DSCAL, DTRSV, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. -* .. Executable Statements .. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - NOTRAN = LSAME( TRANS, 'N' ) - NOUNIT = LSAME( DIAG, 'N' ) -* -* Test the input parameters. -* - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -2 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -3 - ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT. - $ LSAME( NORMIN, 'N' ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLATRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - SCALE = ONE - IF( N.EQ.0 ) - $ RETURN -* -* Determine machine dependent parameters to control overflow. -* - SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) - BIGNUM = ONE / SMLNUM -* - IF( LSAME( NORMIN, 'N' ) ) THEN -* -* Compute the 1-norm of each column, not including the diagonal. -* - IF( UPPER ) THEN -* -* A is upper triangular. -* - DO 10 J = 1, N - CNORM( J ) = DASUM( J-1, A( 1, J ), 1 ) - 10 CONTINUE - ELSE -* -* A is lower triangular. -* - DO 20 J = 1, N - 1 - CNORM( J ) = DASUM( N-J, A( J+1, J ), 1 ) - 20 CONTINUE - CNORM( N ) = ZERO - END IF - END IF -* -* Scale the column norms by TSCAL if the maximum element in CNORM is -* greater than BIGNUM. -* - IMAX = IDAMAX( N, CNORM, 1 ) - TMAX = CNORM( IMAX ) - IF( TMAX.LE.BIGNUM ) THEN - TSCAL = ONE - ELSE -* -* Avoid NaN generation if entries in CNORM exceed the -* overflow threshold -* - IF( TMAX.LE.DLAMCH('Overflow') ) THEN -* Case 1: All entries in CNORM are valid floating-point numbers - TSCAL = ONE / ( SMLNUM*TMAX ) - CALL DSCAL( N, TSCAL, CNORM, 1 ) - ELSE -* Case 2: At least one column norm of A cannot be represented -* as floating-point number. Find the offdiagonal entry A( I, J ) -* with the largest absolute value. If this entry is not +/- Infinity, -* use this value as TSCAL. - TMAX = ZERO - IF( UPPER ) THEN -* -* A is upper triangular. -* - DO J = 2, N - TMAX = MAX( DLANGE( 'M', J-1, 1, A( 1, J ), 1, SUMJ ), - $ TMAX ) - END DO - ELSE -* -* A is lower triangular. -* - DO J = 1, N - 1 - TMAX = MAX( DLANGE( 'M', N-J, 1, A( J+1, J ), 1, - $ SUMJ ), TMAX ) - END DO - END IF -* - IF( TMAX.LE.DLAMCH('Overflow') ) THEN - TSCAL = ONE / ( SMLNUM*TMAX ) - DO J = 1, N - IF( CNORM( J ).LE.DLAMCH('Overflow') ) THEN - CNORM( J ) = CNORM( J )*TSCAL - ELSE -* Recompute the 1-norm without introducing Infinity -* in the summation - CNORM( J ) = ZERO - IF( UPPER ) THEN - DO I = 1, J - 1 - CNORM( J ) = CNORM( J ) + - $ TSCAL * ABS( A( I, J ) ) - END DO - ELSE - DO I = J + 1, N - CNORM( J ) = CNORM( J ) + - $ TSCAL * ABS( A( I, J ) ) - END DO - END IF - END IF - END DO - ELSE -* At least one entry of A is not a valid floating-point entry. -* Rely on TRSV to propagate Inf and NaN. - CALL DTRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 ) - RETURN - END IF - END IF - END IF -* -* Compute a bound on the computed solution vector to see if the -* Level 2 BLAS routine DTRSV can be used. -* - J = IDAMAX( N, X, 1 ) - XMAX = ABS( X( J ) ) - XBND = XMAX - IF( NOTRAN ) THEN -* -* Compute the growth in A * x = b. -* - IF( UPPER ) THEN - JFIRST = N - JLAST = 1 - JINC = -1 - ELSE - JFIRST = 1 - JLAST = N - JINC = 1 - END IF -* - IF( TSCAL.NE.ONE ) THEN - GROW = ZERO - GO TO 50 - END IF -* - IF( NOUNIT ) THEN -* -* A is non-unit triangular. -* -* Compute GROW = 1/G(j) and XBND = 1/M(j). -* Initially, G(0) = max{x(i), i=1,...,n}. -* - GROW = ONE / MAX( XBND, SMLNUM ) - XBND = GROW - DO 30 J = JFIRST, JLAST, JINC -* -* Exit the loop if the growth factor is too small. -* - IF( GROW.LE.SMLNUM ) - $ GO TO 50 -* -* M(j) = G(j-1) / abs(A(j,j)) -* - TJJ = ABS( A( J, J ) ) - XBND = MIN( XBND, MIN( ONE, TJJ )*GROW ) - IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN -* -* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) -* - GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) ) - ELSE -* -* G(j) could overflow, set GROW to 0. -* - GROW = ZERO - END IF - 30 CONTINUE - GROW = XBND - ELSE -* -* A is unit triangular. -* -* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. -* - GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) ) - DO 40 J = JFIRST, JLAST, JINC -* -* Exit the loop if the growth factor is too small. -* - IF( GROW.LE.SMLNUM ) - $ GO TO 50 -* -* G(j) = G(j-1)*( 1 + CNORM(j) ) -* - GROW = GROW*( ONE / ( ONE+CNORM( J ) ) ) - 40 CONTINUE - END IF - 50 CONTINUE -* - ELSE -* -* Compute the growth in A**T * x = b. -* - IF( UPPER ) THEN - JFIRST = 1 - JLAST = N - JINC = 1 - ELSE - JFIRST = N - JLAST = 1 - JINC = -1 - END IF -* - IF( TSCAL.NE.ONE ) THEN - GROW = ZERO - GO TO 80 - END IF -* - IF( NOUNIT ) THEN -* -* A is non-unit triangular. -* -* Compute GROW = 1/G(j) and XBND = 1/M(j). -* Initially, M(0) = max{x(i), i=1,...,n}. -* - GROW = ONE / MAX( XBND, SMLNUM ) - XBND = GROW - DO 60 J = JFIRST, JLAST, JINC -* -* Exit the loop if the growth factor is too small. -* - IF( GROW.LE.SMLNUM ) - $ GO TO 80 -* -* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) -* - XJ = ONE + CNORM( J ) - GROW = MIN( GROW, XBND / XJ ) -* -* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) -* - TJJ = ABS( A( J, J ) ) - IF( XJ.GT.TJJ ) - $ XBND = XBND*( TJJ / XJ ) - 60 CONTINUE - GROW = MIN( GROW, XBND ) - ELSE -* -* A is unit triangular. -* -* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. -* - GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) ) - DO 70 J = JFIRST, JLAST, JINC -* -* Exit the loop if the growth factor is too small. -* - IF( GROW.LE.SMLNUM ) - $ GO TO 80 -* -* G(j) = ( 1 + CNORM(j) )*G(j-1) -* - XJ = ONE + CNORM( J ) - GROW = GROW / XJ - 70 CONTINUE - END IF - 80 CONTINUE - END IF -* - IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN -* -* Use the Level 2 BLAS solve if the reciprocal of the bound on -* elements of X is not too small. -* - CALL DTRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 ) - ELSE -* -* Use a Level 1 BLAS solve, scaling intermediate results. -* - IF( XMAX.GT.BIGNUM ) THEN -* -* Scale X so that its components are less than or equal to -* BIGNUM in absolute value. -* - SCALE = BIGNUM / XMAX - CALL DSCAL( N, SCALE, X, 1 ) - XMAX = BIGNUM - END IF -* - IF( NOTRAN ) THEN -* -* Solve A * x = b -* - DO 110 J = JFIRST, JLAST, JINC -* -* Compute x(j) = b(j) / A(j,j), scaling x if necessary. -* - XJ = ABS( X( J ) ) - IF( NOUNIT ) THEN - TJJS = A( J, J )*TSCAL - ELSE - TJJS = TSCAL - IF( TSCAL.EQ.ONE ) - $ GO TO 100 - END IF - TJJ = ABS( TJJS ) - IF( TJJ.GT.SMLNUM ) THEN -* -* abs(A(j,j)) > SMLNUM: -* - IF( TJJ.LT.ONE ) THEN - IF( XJ.GT.TJJ*BIGNUM ) THEN -* -* Scale x by 1/b(j). -* - REC = ONE / XJ - CALL DSCAL( N, REC, X, 1 ) - SCALE = SCALE*REC - XMAX = XMAX*REC - END IF - END IF - X( J ) = X( J ) / TJJS - XJ = ABS( X( J ) ) - ELSE IF( TJJ.GT.ZERO ) THEN -* -* 0 < abs(A(j,j)) <= SMLNUM: -* - IF( XJ.GT.TJJ*BIGNUM ) THEN -* -* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM -* to avoid overflow when dividing by A(j,j). -* - REC = ( TJJ*BIGNUM ) / XJ - IF( CNORM( J ).GT.ONE ) THEN -* -* Scale by 1/CNORM(j) to avoid overflow when -* multiplying x(j) times column j. -* - REC = REC / CNORM( J ) - END IF - CALL DSCAL( N, REC, X, 1 ) - SCALE = SCALE*REC - XMAX = XMAX*REC - END IF - X( J ) = X( J ) / TJJS - XJ = ABS( X( J ) ) - ELSE -* -* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and -* scale = 0, and compute a solution to A*x = 0. -* - DO 90 I = 1, N - X( I ) = ZERO - 90 CONTINUE - X( J ) = ONE - XJ = ONE - SCALE = ZERO - XMAX = ZERO - END IF - 100 CONTINUE -* -* Scale x if necessary to avoid overflow when adding a -* multiple of column j of A. -* - IF( XJ.GT.ONE ) THEN - REC = ONE / XJ - IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN -* -* Scale x by 1/(2*abs(x(j))). -* - REC = REC*HALF - CALL DSCAL( N, REC, X, 1 ) - SCALE = SCALE*REC - END IF - ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN -* -* Scale x by 1/2. -* - CALL DSCAL( N, HALF, X, 1 ) - SCALE = SCALE*HALF - END IF -* - IF( UPPER ) THEN - IF( J.GT.1 ) THEN -* -* Compute the update -* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) -* - CALL DAXPY( J-1, -X( J )*TSCAL, A( 1, J ), 1, X, - $ 1 ) - I = IDAMAX( J-1, X, 1 ) - XMAX = ABS( X( I ) ) - END IF - ELSE - IF( J.LT.N ) THEN -* -* Compute the update -* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) -* - CALL DAXPY( N-J, -X( J )*TSCAL, A( J+1, J ), 1, - $ X( J+1 ), 1 ) - I = J + IDAMAX( N-J, X( J+1 ), 1 ) - XMAX = ABS( X( I ) ) - END IF - END IF - 110 CONTINUE -* - ELSE -* -* Solve A**T * x = b -* - DO 160 J = JFIRST, JLAST, JINC -* -* Compute x(j) = b(j) - sum A(k,j)*x(k). -* k<>j -* - XJ = ABS( X( J ) ) - USCAL = TSCAL - REC = ONE / MAX( XMAX, ONE ) - IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN -* -* If x(j) could overflow, scale x by 1/(2*XMAX). -* - REC = REC*HALF - IF( NOUNIT ) THEN - TJJS = A( J, J )*TSCAL - ELSE - TJJS = TSCAL - END IF - TJJ = ABS( TJJS ) - IF( TJJ.GT.ONE ) THEN -* -* Divide by A(j,j) when scaling x if A(j,j) > 1. -* - REC = MIN( ONE, REC*TJJ ) - USCAL = USCAL / TJJS - END IF - IF( REC.LT.ONE ) THEN - CALL DSCAL( N, REC, X, 1 ) - SCALE = SCALE*REC - XMAX = XMAX*REC - END IF - END IF -* - SUMJ = ZERO - IF( USCAL.EQ.ONE ) THEN -* -* If the scaling needed for A in the dot product is 1, -* call DDOT to perform the dot product. -* - IF( UPPER ) THEN - SUMJ = DDOT( J-1, A( 1, J ), 1, X, 1 ) - ELSE IF( J.LT.N ) THEN - SUMJ = DDOT( N-J, A( J+1, J ), 1, X( J+1 ), 1 ) - END IF - ELSE -* -* Otherwise, use in-line code for the dot product. -* - IF( UPPER ) THEN - DO 120 I = 1, J - 1 - SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I ) - 120 CONTINUE - ELSE IF( J.LT.N ) THEN - DO 130 I = J + 1, N - SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I ) - 130 CONTINUE - END IF - END IF -* - IF( USCAL.EQ.TSCAL ) THEN -* -* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) -* was not used to scale the dotproduct. -* - X( J ) = X( J ) - SUMJ - XJ = ABS( X( J ) ) - IF( NOUNIT ) THEN - TJJS = A( J, J )*TSCAL - ELSE - TJJS = TSCAL - IF( TSCAL.EQ.ONE ) - $ GO TO 150 - END IF -* -* Compute x(j) = x(j) / A(j,j), scaling if necessary. -* - TJJ = ABS( TJJS ) - IF( TJJ.GT.SMLNUM ) THEN -* -* abs(A(j,j)) > SMLNUM: -* - IF( TJJ.LT.ONE ) THEN - IF( XJ.GT.TJJ*BIGNUM ) THEN -* -* Scale X by 1/abs(x(j)). -* - REC = ONE / XJ - CALL DSCAL( N, REC, X, 1 ) - SCALE = SCALE*REC - XMAX = XMAX*REC - END IF - END IF - X( J ) = X( J ) / TJJS - ELSE IF( TJJ.GT.ZERO ) THEN -* -* 0 < abs(A(j,j)) <= SMLNUM: -* - IF( XJ.GT.TJJ*BIGNUM ) THEN -* -* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. -* - REC = ( TJJ*BIGNUM ) / XJ - CALL DSCAL( N, REC, X, 1 ) - SCALE = SCALE*REC - XMAX = XMAX*REC - END IF - X( J ) = X( J ) / TJJS - ELSE -* -* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and -* scale = 0, and compute a solution to A**T*x = 0. -* - DO 140 I = 1, N - X( I ) = ZERO - 140 CONTINUE - X( J ) = ONE - SCALE = ZERO - XMAX = ZERO - END IF - 150 CONTINUE - ELSE -* -* Compute x(j) := x(j) / A(j,j) - sumj if the dot -* product has already been divided by 1/A(j,j). -* - X( J ) = X( J ) / TJJS - SUMJ - END IF - XMAX = MAX( XMAX, ABS( X( J ) ) ) - 160 CONTINUE - END IF - SCALE = SCALE / TSCAL - END IF -* -* Scale the column norms by 1/TSCAL for return. -* - IF( TSCAL.NE.ONE ) THEN - CALL DSCAL( N, ONE / TSCAL, CNORM, 1 ) - END IF -* - RETURN -* -* End of DLATRS -* - END diff --git a/lib/linalg/dnrm2.cpp b/lib/linalg/dnrm2.cpp new file mode 100644 index 0000000000..fc34e88c78 --- /dev/null +++ b/lib/linalg/dnrm2.cpp @@ -0,0 +1,42 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +doublereal dnrm2_(integer *n, doublereal *x, integer *incx) +{ + integer i__1, i__2; + doublereal ret_val, d__1; + double sqrt(doublereal); + integer ix; + doublereal ssq, norm, scale, absxi; + --x; + if (*n < 1 || *incx < 1) { + norm = 0.; + } else if (*n == 1) { + norm = abs(x[1]); + } else { + scale = 0.; + ssq = 1.; + i__1 = (*n - 1) * *incx + 1; + i__2 = *incx; + for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { + if (x[ix] != 0.) { + absxi = (d__1 = x[ix], abs(d__1)); + if (scale < absxi) { + d__1 = scale / absxi; + ssq = ssq * (d__1 * d__1) + 1.; + scale = absxi; + } else { + d__1 = absxi / scale; + ssq += d__1 * d__1; + } + } + } + norm = scale * sqrt(ssq); + } + ret_val = norm; + return ret_val; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dnrm2.f b/lib/linalg/dnrm2.f deleted file mode 100644 index 30552e1d1d..0000000000 --- a/lib/linalg/dnrm2.f +++ /dev/null @@ -1,132 +0,0 @@ -*> \brief \b DNRM2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX) -* -* .. Scalar Arguments .. -* INTEGER INCX,N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION X(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DNRM2 returns the euclidean norm of a vector via the function -*> name, so that -*> -*> DNRM2 := sqrt( x'*x ) -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> number of elements in input vector(s) -*> \endverbatim -*> -*> \param[in] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> storage spacing between elements of DX -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date December 2016 -* -*> \ingroup double_blas_level1 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> -- This version written on 25-October-1982. -*> Modified on 14-October-1993 to inline the call to DLASSQ. -*> Sven Hammarling, Nag Ltd. -*> \endverbatim -*> -* ===================================================================== - DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX) -* -* -- Reference BLAS level1 routine (version 3.7.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - INTEGER INCX,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION X(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION ABSXI,NORM,SCALE,SSQ - INTEGER IX -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS,SQRT -* .. - IF (N.LT.1 .OR. INCX.LT.1) THEN - NORM = ZERO - ELSE IF (N.EQ.1) THEN - NORM = ABS(X(1)) - ELSE - SCALE = ZERO - SSQ = ONE -* The following loop is equivalent to this call to the LAPACK -* auxiliary routine: -* CALL DLASSQ( N, X, INCX, SCALE, SSQ ) -* - DO 10 IX = 1,1 + (N-1)*INCX,INCX - IF (X(IX).NE.ZERO) THEN - ABSXI = ABS(X(IX)) - IF (SCALE.LT.ABSXI) THEN - SSQ = ONE + SSQ* (SCALE/ABSXI)**2 - SCALE = ABSXI - ELSE - SSQ = SSQ + (ABSXI/SCALE)**2 - END IF - END IF - 10 CONTINUE - NORM = SCALE*SQRT(SSQ) - END IF -* - DNRM2 = NORM - RETURN -* -* End of DNRM2. -* - END diff --git a/lib/linalg/dorg2l.cpp b/lib/linalg/dorg2l.cpp new file mode 100644 index 0000000000..42899af042 --- /dev/null +++ b/lib/linalg/dorg2l.cpp @@ -0,0 +1,68 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +int dorg2l_(integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, + doublereal *work, integer *info) +{ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublereal d__1; + integer i__, j, l, ii; + extern int dscal_(integer *, doublereal *, doublereal *, integer *), + dlarf_(char *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, ftnlen), + xerbla_(char *, integer *, ftnlen); + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + --work; + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0 || *n > *m) { + *info = -2; + } else if (*k < 0 || *k > *n) { + *info = -3; + } else if (*lda < max(1, *m)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DORG2L", &i__1, (ftnlen)6); + return 0; + } + if (*n <= 0) { + return 0; + } + i__1 = *n - *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (l = 1; l <= i__2; ++l) { + a[l + j * a_dim1] = 0.; + } + a[*m - *n + j + j * a_dim1] = 1.; + } + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + ii = *n - *k + i__; + a[*m - *n + ii + ii * a_dim1] = 1.; + i__2 = *m - *n + ii; + i__3 = ii - 1; + dlarf_((char *)"Left", &i__2, &i__3, &a[ii * a_dim1 + 1], &c__1, &tau[i__], &a[a_offset], lda, + &work[1], (ftnlen)4); + i__2 = *m - *n + ii - 1; + d__1 = -tau[i__]; + dscal_(&i__2, &d__1, &a[ii * a_dim1 + 1], &c__1); + a[*m - *n + ii + ii * a_dim1] = 1. - tau[i__]; + i__2 = *m; + for (l = *m - *n + ii + 1; l <= i__2; ++l) { + a[l + ii * a_dim1] = 0.; + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dorg2l.f b/lib/linalg/dorg2l.f deleted file mode 100644 index 0a42d4cf5a..0000000000 --- a/lib/linalg/dorg2l.f +++ /dev/null @@ -1,195 +0,0 @@ -*> \brief \b DORG2L generates all or part of the orthogonal matrix Q from a QL factorization determined by sgeqlf (unblocked algorithm). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORG2L + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, K, LDA, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DORG2L generates an m by n real matrix Q with orthonormal columns, -*> which is defined as the last n columns of a product of k elementary -*> reflectors of order m -*> -*> Q = H(k) . . . H(2) H(1) -*> -*> as returned by DGEQLF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix Q. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix Q. M >= N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines the -*> matrix Q. N >= K >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the (n-k+i)-th column must contain the vector which -*> defines the elementary reflector H(i), for i = 1,2,...,k, as -*> returned by DGEQLF in the last k columns of its array -*> argument A. -*> On exit, the m by n matrix Q. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The first dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by DGEQLF. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (N) -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument has an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, II, J, L -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORG2L', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* -* Initialise columns 1:n-k to columns of the unit matrix -* - DO 20 J = 1, N - K - DO 10 L = 1, M - A( L, J ) = ZERO - 10 CONTINUE - A( M-N+J, J ) = ONE - 20 CONTINUE -* - DO 40 I = 1, K - II = N - K + I -* -* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left -* - A( M-N+II, II ) = ONE - CALL DLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A, - $ LDA, WORK ) - CALL DSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 ) - A( M-N+II, II ) = ONE - TAU( I ) -* -* Set A(m-k+i+1:m,n-k+i) to zero -* - DO 30 L = M - N + II + 1, M - A( L, II ) = ZERO - 30 CONTINUE - 40 CONTINUE - RETURN -* -* End of DORG2L -* - END diff --git a/lib/linalg/dorg2r.cpp b/lib/linalg/dorg2r.cpp new file mode 100644 index 0000000000..b9be1488c9 --- /dev/null +++ b/lib/linalg/dorg2r.cpp @@ -0,0 +1,70 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +int dorg2r_(integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, + doublereal *work, integer *info) +{ + integer a_dim1, a_offset, i__1, i__2; + doublereal d__1; + integer i__, j, l; + extern int dscal_(integer *, doublereal *, doublereal *, integer *), + dlarf_(char *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, ftnlen), + xerbla_(char *, integer *, ftnlen); + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + --work; + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0 || *n > *m) { + *info = -2; + } else if (*k < 0 || *k > *n) { + *info = -3; + } else if (*lda < max(1, *m)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DORG2R", &i__1, (ftnlen)6); + return 0; + } + if (*n <= 0) { + return 0; + } + i__1 = *n; + for (j = *k + 1; j <= i__1; ++j) { + i__2 = *m; + for (l = 1; l <= i__2; ++l) { + a[l + j * a_dim1] = 0.; + } + a[j + j * a_dim1] = 1.; + } + for (i__ = *k; i__ >= 1; --i__) { + if (i__ < *n) { + a[i__ + i__ * a_dim1] = 1.; + i__1 = *m - i__ + 1; + i__2 = *n - i__; + dlarf_((char *)"Left", &i__1, &i__2, &a[i__ + i__ * a_dim1], &c__1, &tau[i__], + &a[i__ + (i__ + 1) * a_dim1], lda, &work[1], (ftnlen)4); + } + if (i__ < *m) { + i__1 = *m - i__; + d__1 = -tau[i__]; + dscal_(&i__1, &d__1, &a[i__ + 1 + i__ * a_dim1], &c__1); + } + a[i__ + i__ * a_dim1] = 1. - tau[i__]; + i__1 = i__ - 1; + for (l = 1; l <= i__1; ++l) { + a[l + i__ * a_dim1] = 0.; + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dorg2r.f b/lib/linalg/dorg2r.f deleted file mode 100644 index c64ad4b0ac..0000000000 --- a/lib/linalg/dorg2r.f +++ /dev/null @@ -1,197 +0,0 @@ -*> \brief \b DORG2R generates all or part of the orthogonal matrix Q from a QR factorization determined by sgeqrf (unblocked algorithm). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORG2R + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, K, LDA, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DORG2R generates an m by n real matrix Q with orthonormal columns, -*> which is defined as the first n columns of a product of k elementary -*> reflectors of order m -*> -*> Q = H(1) H(2) . . . H(k) -*> -*> as returned by DGEQRF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix Q. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix Q. M >= N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines the -*> matrix Q. N >= K >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the i-th column must contain the vector which -*> defines the elementary reflector H(i), for i = 1,2,...,k, as -*> returned by DGEQRF in the first k columns of its array -*> argument A. -*> On exit, the m-by-n matrix Q. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The first dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by DGEQRF. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (N) -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument has an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J, L -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORG2R', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* -* Initialise columns k+1:n to columns of the unit matrix -* - DO 20 J = K + 1, N - DO 10 L = 1, M - A( L, J ) = ZERO - 10 CONTINUE - A( J, J ) = ONE - 20 CONTINUE -* - DO 40 I = K, 1, -1 -* -* Apply H(i) to A(i:m,i:n) from the left -* - IF( I.LT.N ) THEN - A( I, I ) = ONE - CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), - $ A( I, I+1 ), LDA, WORK ) - END IF - IF( I.LT.M ) - $ CALL DSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) - A( I, I ) = ONE - TAU( I ) -* -* Set A(1:i-1,i) to zero -* - DO 30 L = 1, I - 1 - A( L, I ) = ZERO - 30 CONTINUE - 40 CONTINUE - RETURN -* -* End of DORG2R -* - END diff --git a/lib/linalg/dorgbr.cpp b/lib/linalg/dorgbr.cpp new file mode 100644 index 0000000000..27f94eb51f --- /dev/null +++ b/lib/linalg/dorgbr.cpp @@ -0,0 +1,140 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c_n1 = -1; +int dorgbr_(char *vect, integer *m, integer *n, integer *k, doublereal *a, integer *lda, + doublereal *tau, doublereal *work, integer *lwork, integer *info, ftnlen vect_len) +{ + integer a_dim1, a_offset, i__1, i__2, i__3; + integer i__, j, mn; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + integer iinfo; + logical wantq; + extern int xerbla_(char *, integer *, ftnlen), + dorglq_(integer *, integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *, integer *), + 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; + wantq = lsame_(vect, (char *)"Q", (ftnlen)1, (ftnlen)1); + mn = min(*m, *n); + lquery = *lwork == -1; + if (!wantq && !lsame_(vect, (char *)"P", (ftnlen)1, (ftnlen)1)) { + *info = -1; + } else if (*m < 0) { + *info = -2; + } else if (*n < 0 || wantq && (*n > *m || *n < min(*m, *k)) || + !wantq && (*m > *n || *m < min(*n, *k))) { + *info = -3; + } else if (*k < 0) { + *info = -4; + } else if (*lda < max(1, *m)) { + *info = -6; + } else if (*lwork < max(1, mn) && !lquery) { + *info = -9; + } + if (*info == 0) { + work[1] = 1.; + if (wantq) { + if (*m >= *k) { + dorgqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], &c_n1, &iinfo); + } else { + if (*m > 1) { + i__1 = *m - 1; + i__2 = *m - 1; + i__3 = *m - 1; + dorgqr_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], &c_n1, + &iinfo); + } + } + } else { + if (*k < *n) { + dorglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], &c_n1, &iinfo); + } else { + if (*n > 1) { + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + dorglq_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], &c_n1, + &iinfo); + } + } + } + lwkopt = (integer)work[1]; + lwkopt = max(lwkopt, mn); + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DORGBR", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + work[1] = (doublereal)lwkopt; + return 0; + } + if (*m == 0 || *n == 0) { + work[1] = 1.; + return 0; + } + if (wantq) { + if (*m >= *k) { + dorgqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, &iinfo); + } else { + for (j = *m; j >= 2; --j) { + a[j * a_dim1 + 1] = 0.; + i__1 = *m; + for (i__ = j + 1; i__ <= i__1; ++i__) { + a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1]; + } + } + a[a_dim1 + 1] = 1.; + i__1 = *m; + for (i__ = 2; i__ <= i__1; ++i__) { + a[i__ + a_dim1] = 0.; + } + if (*m > 1) { + i__1 = *m - 1; + i__2 = *m - 1; + i__3 = *m - 1; + dorgqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[1], &work[1], lwork, + &iinfo); + } + } + } else { + if (*k < *n) { + dorglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, &iinfo); + } else { + a[a_dim1 + 1] = 1.; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + a[i__ + a_dim1] = 0.; + } + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + for (i__ = j - 1; i__ >= 2; --i__) { + a[i__ + j * a_dim1] = a[i__ - 1 + j * a_dim1]; + } + a[j * a_dim1 + 1] = 0.; + } + if (*n > 1) { + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + dorglq_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[1], &work[1], lwork, + &iinfo); + } + } + } + work[1] = (doublereal)lwkopt; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dorgbr.f b/lib/linalg/dorgbr.f deleted file mode 100644 index 7dfd03961e..0000000000 --- a/lib/linalg/dorgbr.f +++ /dev/null @@ -1,334 +0,0 @@ -*> \brief \b DORGBR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORGBR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER VECT -* INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DORGBR generates one of the real orthogonal matrices Q or P**T -*> determined by DGEBRD when reducing a real matrix A to bidiagonal -*> form: A = Q * B * P**T. Q and P**T are defined as products of -*> elementary reflectors H(i) or G(i) respectively. -*> -*> If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q -*> is of order M: -*> if m >= k, Q = H(1) H(2) . . . H(k) and DORGBR returns the first n -*> columns of Q, where m >= n >= k; -*> if m < k, Q = H(1) H(2) . . . H(m-1) and DORGBR returns Q as an -*> M-by-M matrix. -*> -*> If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T -*> is of order N: -*> if k < n, P**T = G(k) . . . G(2) G(1) and DORGBR returns the first m -*> rows of P**T, where n >= m >= k; -*> if k >= n, P**T = G(n-1) . . . G(2) G(1) and DORGBR returns P**T as -*> an N-by-N matrix. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] VECT -*> \verbatim -*> VECT is CHARACTER*1 -*> Specifies whether the matrix Q or the matrix P**T is -*> required, as defined in the transformation applied by DGEBRD: -*> = 'Q': generate Q; -*> = 'P': generate P**T. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix Q or P**T to be returned. -*> M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix Q or P**T to be returned. -*> N >= 0. -*> If VECT = 'Q', M >= N >= min(M,K); -*> if VECT = 'P', N >= M >= min(N,K). -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> If VECT = 'Q', the number of columns in the original M-by-K -*> matrix reduced by DGEBRD. -*> If VECT = 'P', the number of rows in the original K-by-N -*> matrix reduced by DGEBRD. -*> K >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the vectors which define the elementary reflectors, -*> as returned by DGEBRD. -*> On exit, the M-by-N matrix Q or P**T. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension -*> (min(M,K)) if VECT = 'Q' -*> (min(N,K)) if VECT = 'P' -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i) or G(i), which determines Q or P**T, as -*> returned by DGEBRD in its array argument TAUQ or TAUP. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. LWORK >= max(1,min(M,N)). -*> For optimum performance LWORK >= min(M,N)*NB, where NB -*> is the optimal blocksize. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal size of the WORK array, returns -*> this value as the first entry of the WORK array, and no error -*> message related to LWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleGBcomputational -* -* ===================================================================== - SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER VECT - INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY, WANTQ - INTEGER I, IINFO, J, LWKOPT, MN -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DORGLQ, DORGQR, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - WANTQ = LSAME( VECT, 'Q' ) - MN = MIN( M, N ) - LQUERY = ( LWORK.EQ.-1 ) - IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 .OR. ( WANTQ .AND. ( N.GT.M .OR. N.LT.MIN( M, - $ K ) ) ) .OR. ( .NOT.WANTQ .AND. ( M.GT.N .OR. M.LT. - $ MIN( N, K ) ) ) ) THEN - INFO = -3 - ELSE IF( K.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -6 - ELSE IF( LWORK.LT.MAX( 1, MN ) .AND. .NOT.LQUERY ) THEN - INFO = -9 - END IF -* - IF( INFO.EQ.0 ) THEN - WORK( 1 ) = 1 - IF( WANTQ ) THEN - IF( M.GE.K ) THEN - CALL DORGQR( M, N, K, A, LDA, TAU, WORK, -1, IINFO ) - ELSE - IF( M.GT.1 ) THEN - CALL DORGQR( M-1, M-1, M-1, A, LDA, TAU, WORK, -1, - $ IINFO ) - END IF - END IF - ELSE - IF( K.LT.N ) THEN - CALL DORGLQ( M, N, K, A, LDA, TAU, WORK, -1, IINFO ) - ELSE - IF( N.GT.1 ) THEN - CALL DORGLQ( N-1, N-1, N-1, A, LDA, TAU, WORK, -1, - $ IINFO ) - END IF - END IF - END IF - LWKOPT = INT( WORK( 1 ) ) - LWKOPT = MAX (LWKOPT, MN) - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORGBR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - WORK( 1 ) = LWKOPT - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - IF( WANTQ ) THEN -* -* Form Q, determined by a call to DGEBRD to reduce an m-by-k -* matrix -* - IF( M.GE.K ) THEN -* -* If m >= k, assume m >= n >= k -* - CALL DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO ) -* - ELSE -* -* If m < k, assume m = n -* -* Shift the vectors which define the elementary reflectors one -* column to the right, and set the first row and column of Q -* to those of the unit matrix -* - DO 20 J = M, 2, -1 - A( 1, J ) = ZERO - DO 10 I = J + 1, M - A( I, J ) = A( I, J-1 ) - 10 CONTINUE - 20 CONTINUE - A( 1, 1 ) = ONE - DO 30 I = 2, M - A( I, 1 ) = ZERO - 30 CONTINUE - IF( M.GT.1 ) THEN -* -* Form Q(2:m,2:m) -* - CALL DORGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK, - $ LWORK, IINFO ) - END IF - END IF - ELSE -* -* Form P**T, determined by a call to DGEBRD to reduce a k-by-n -* matrix -* - IF( K.LT.N ) THEN -* -* If k < n, assume k <= m <= n -* - CALL DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO ) -* - ELSE -* -* If k >= n, assume m = n -* -* Shift the vectors which define the elementary reflectors one -* row downward, and set the first row and column of P**T to -* those of the unit matrix -* - A( 1, 1 ) = ONE - DO 40 I = 2, N - A( I, 1 ) = ZERO - 40 CONTINUE - DO 60 J = 2, N - DO 50 I = J - 1, 2, -1 - A( I, J ) = A( I-1, J ) - 50 CONTINUE - A( 1, J ) = ZERO - 60 CONTINUE - IF( N.GT.1 ) THEN -* -* Form P**T(2:n,2:n) -* - CALL DORGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, - $ LWORK, IINFO ) - END IF - END IF - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of DORGBR -* - END diff --git a/lib/linalg/dorgl2.cpp b/lib/linalg/dorgl2.cpp new file mode 100644 index 0000000000..78561a4ba8 --- /dev/null +++ b/lib/linalg/dorgl2.cpp @@ -0,0 +1,73 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dorgl2_(integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, + doublereal *work, integer *info) +{ + integer a_dim1, a_offset, i__1, i__2; + doublereal d__1; + integer i__, j, l; + extern int dscal_(integer *, doublereal *, doublereal *, integer *), + dlarf_(char *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, doublereal *, ftnlen), + xerbla_(char *, integer *, ftnlen); + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + --work; + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < *m) { + *info = -2; + } else if (*k < 0 || *k > *m) { + *info = -3; + } else if (*lda < max(1, *m)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DORGL2", &i__1, (ftnlen)6); + return 0; + } + if (*m <= 0) { + return 0; + } + if (*k < *m) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (l = *k + 1; l <= i__2; ++l) { + a[l + j * a_dim1] = 0.; + } + if (j > *k && j <= *m) { + a[j + j * a_dim1] = 1.; + } + } + } + for (i__ = *k; i__ >= 1; --i__) { + if (i__ < *n) { + if (i__ < *m) { + a[i__ + i__ * a_dim1] = 1.; + i__1 = *m - i__; + i__2 = *n - i__ + 1; + dlarf_((char *)"Right", &i__1, &i__2, &a[i__ + i__ * a_dim1], lda, &tau[i__], + &a[i__ + 1 + i__ * a_dim1], lda, &work[1], (ftnlen)5); + } + i__1 = *n - i__; + d__1 = -tau[i__]; + dscal_(&i__1, &d__1, &a[i__ + (i__ + 1) * a_dim1], lda); + } + a[i__ + i__ * a_dim1] = 1. - tau[i__]; + i__1 = i__ - 1; + for (l = 1; l <= i__1; ++l) { + a[i__ + l * a_dim1] = 0.; + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dorgl2.f b/lib/linalg/dorgl2.f deleted file mode 100644 index ce1d2c6750..0000000000 --- a/lib/linalg/dorgl2.f +++ /dev/null @@ -1,201 +0,0 @@ -*> \brief \b DORGL2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORGL2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, K, LDA, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DORGL2 generates an m by n real matrix Q with orthonormal rows, -*> which is defined as the first m rows of a product of k elementary -*> reflectors of order n -*> -*> Q = H(k) . . . H(2) H(1) -*> -*> as returned by DGELQF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix Q. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix Q. N >= M. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines the -*> matrix Q. M >= K >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the i-th row must contain the vector which defines -*> the elementary reflector H(i), for i = 1,2,...,k, as returned -*> by DGELQF in the first k rows of its array argument A. -*> On exit, the m-by-n matrix Q. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The first dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by DGELQF. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (M) -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument has an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J, L -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.M ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORGL2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.LE.0 ) - $ RETURN -* - IF( K.LT.M ) THEN -* -* Initialise rows k+1:m to rows of the unit matrix -* - DO 20 J = 1, N - DO 10 L = K + 1, M - A( L, J ) = ZERO - 10 CONTINUE - IF( J.GT.K .AND. J.LE.M ) - $ A( J, J ) = ONE - 20 CONTINUE - END IF -* - DO 40 I = K, 1, -1 -* -* Apply H(i) to A(i:m,i:n) from the right -* - IF( I.LT.N ) THEN - IF( I.LT.M ) THEN - A( I, I ) = ONE - CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, - $ TAU( I ), A( I+1, I ), LDA, WORK ) - END IF - CALL DSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA ) - END IF - A( I, I ) = ONE - TAU( I ) -* -* Set A(i,1:i-1) to zero -* - DO 30 L = 1, I - 1 - A( I, L ) = ZERO - 30 CONTINUE - 40 CONTINUE - RETURN -* -* End of DORGL2 -* - END diff --git a/lib/linalg/dorglq.cpp b/lib/linalg/dorglq.cpp new file mode 100644 index 0000000000..a43e7e86d2 --- /dev/null +++ b/lib/linalg/dorglq.cpp @@ -0,0 +1,127 @@ +#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; +int dorglq_(integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, + doublereal *work, integer *lwork, integer *info) +{ + integer a_dim1, a_offset, i__1, i__2, i__3; + integer i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo; + extern int dorgl2_(integer *, integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *), + dlarfb_(char *, char *, char *, char *, integer *, integer *, integer *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, ftnlen, ftnlen, ftnlen, ftnlen), + dlarft_(char *, char *, integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *, 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; + nb = ilaenv_(&c__1, (char *)"DORGLQ", (char *)" ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1); + lwkopt = max(1, *m) * nb; + work[1] = (doublereal)lwkopt; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < *m) { + *info = -2; + } else if (*k < 0 || *k > *m) { + *info = -3; + } else if (*lda < max(1, *m)) { + *info = -5; + } else if (*lwork < max(1, *m) && !lquery) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DORGLQ", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + if (*m <= 0) { + work[1] = 1.; + return 0; + } + nbmin = 2; + nx = 0; + iws = *m; + if (nb > 1 && nb < *k) { + i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DORGLQ", (char *)" ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1); + nx = max(i__1, i__2); + if (nx < *k) { + ldwork = *m; + iws = ldwork * nb; + if (*lwork < iws) { + nb = *lwork / ldwork; + i__1 = 2, + i__2 = ilaenv_(&c__2, (char *)"DORGLQ", (char *)" ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1); + nbmin = max(i__1, i__2); + } + } + } + if (nb >= nbmin && nb < *k && nx < *k) { + ki = (*k - nx - 1) / nb * nb; + i__1 = *k, i__2 = ki + nb; + kk = min(i__1, i__2); + i__1 = kk; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = kk + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; + } + } + } else { + kk = 0; + } + if (kk < *m) { + i__1 = *m - kk; + i__2 = *n - kk; + i__3 = *k - kk; + dorgl2_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, &tau[kk + 1], &work[1], + &iinfo); + } + if (kk > 0) { + i__1 = -nb; + for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { + i__2 = nb, i__3 = *k - i__ + 1; + ib = min(i__2, i__3); + if (i__ + ib <= *m) { + i__2 = *n - i__ + 1; + dlarft_((char *)"Forward", (char *)"Rowwise", &i__2, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], + &work[1], &ldwork, (ftnlen)7, (ftnlen)7); + i__2 = *m - i__ - ib + 1; + i__3 = *n - i__ + 1; + dlarfb_((char *)"Right", (char *)"Transpose", (char *)"Forward", (char *)"Rowwise", &i__2, &i__3, &ib, + &a[i__ + i__ * a_dim1], lda, &work[1], &ldwork, &a[i__ + ib + i__ * a_dim1], + lda, &work[ib + 1], &ldwork, (ftnlen)5, (ftnlen)9, (ftnlen)7, (ftnlen)7); + } + i__2 = *n - i__ + 1; + dorgl2_(&ib, &i__2, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1], &iinfo); + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + ib - 1; + for (l = i__; l <= i__3; ++l) { + a[l + j * a_dim1] = 0.; + } + } + } + } + work[1] = (doublereal)iws; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dorglq.f b/lib/linalg/dorglq.f deleted file mode 100644 index 8c37c18b75..0000000000 --- a/lib/linalg/dorglq.f +++ /dev/null @@ -1,286 +0,0 @@ -*> \brief \b DORGLQ -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORGLQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DORGLQ generates an M-by-N real matrix Q with orthonormal rows, -*> which is defined as the first M rows of a product of K elementary -*> reflectors of order N -*> -*> Q = H(k) . . . H(2) H(1) -*> -*> as returned by DGELQF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix Q. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix Q. N >= M. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines the -*> matrix Q. M >= K >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the i-th row must contain the vector which defines -*> the elementary reflector H(i), for i = 1,2,...,k, as returned -*> by DGELQF in the first k rows of its array argument A. -*> On exit, the M-by-N matrix Q. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The first dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by DGELQF. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. LWORK >= max(1,M). -*> For optimum performance LWORK >= M*NB, where NB is -*> the optimal blocksize. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal size of the WORK array, returns -*> this value as the first entry of the WORK array, and no error -*> message related to LWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument has an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, - $ LWKOPT, NB, NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL DLARFB, DLARFT, DORGL2, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - NB = ILAENV( 1, 'DORGLQ', ' ', M, N, K, -1 ) - LWKOPT = MAX( 1, M )*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.M ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORGLQ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.LE.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - NX = 0 - IWS = M - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'DORGLQ', ' ', M, N, K, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = M - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORGLQ', ' ', M, N, K, -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code after the last block. -* The first kk rows are handled by the block method. -* - KI = ( ( K-NX-1 ) / NB )*NB - KK = MIN( K, KI+NB ) -* -* Set A(kk+1:m,1:kk) to zero. -* - DO 20 J = 1, KK - DO 10 I = KK + 1, M - A( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - KK = 0 - END IF -* -* Use unblocked code for the last or only block. -* - IF( KK.LT.M ) - $ CALL DORGL2( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, - $ TAU( KK+1 ), WORK, IINFO ) -* - IF( KK.GT.0 ) THEN -* -* Use blocked code -* - DO 50 I = KI + 1, 1, -NB - IB = MIN( NB, K-I+1 ) - IF( I+IB.LE.M ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ), - $ LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H**T to A(i+ib:m,i:n) from the right -* - CALL DLARFB( 'Right', 'Transpose', 'Forward', 'Rowwise', - $ M-I-IB+1, N-I+1, IB, A( I, I ), LDA, WORK, - $ LDWORK, A( I+IB, I ), LDA, WORK( IB+1 ), - $ LDWORK ) - END IF -* -* Apply H**T to columns i:n of current block -* - CALL DORGL2( IB, N-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) -* -* Set columns 1:i-1 of current block to zero -* - DO 40 J = 1, I - 1 - DO 30 L = I, I + IB - 1 - A( L, J ) = ZERO - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - END IF -* - WORK( 1 ) = IWS - RETURN -* -* End of DORGLQ -* - END diff --git a/lib/linalg/dorgql.cpp b/lib/linalg/dorgql.cpp new file mode 100644 index 0000000000..53c6e01be0 --- /dev/null +++ b/lib/linalg/dorgql.cpp @@ -0,0 +1,131 @@ +#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; +int dorgql_(integer *m, integer *n, integer *k, 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, l, ib, nb, kk, nx, iws, nbmin, iinfo; + extern int dorg2l_(integer *, integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *), + dlarfb_(char *, char *, char *, char *, integer *, integer *, integer *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, ftnlen, ftnlen, ftnlen, ftnlen), + dlarft_(char *, char *, integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *, 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 (*m < 0) { + *info = -1; + } else if (*n < 0 || *n > *m) { + *info = -2; + } else if (*k < 0 || *k > *n) { + *info = -3; + } else if (*lda < max(1, *m)) { + *info = -5; + } + if (*info == 0) { + if (*n == 0) { + lwkopt = 1; + } else { + nb = ilaenv_(&c__1, (char *)"DORGQL", (char *)" ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1); + lwkopt = *n * nb; + } + work[1] = (doublereal)lwkopt; + if (*lwork < max(1, *n) && !lquery) { + *info = -8; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DORGQL", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + if (*n <= 0) { + return 0; + } + nbmin = 2; + nx = 0; + iws = *n; + if (nb > 1 && nb < *k) { + i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DORGQL", (char *)" ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1); + nx = max(i__1, i__2); + if (nx < *k) { + ldwork = *n; + iws = ldwork * nb; + if (*lwork < iws) { + nb = *lwork / ldwork; + i__1 = 2, + i__2 = ilaenv_(&c__2, (char *)"DORGQL", (char *)" ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1); + nbmin = max(i__1, i__2); + } + } + } + if (nb >= nbmin && nb < *k && nx < *k) { + i__1 = *k, i__2 = (*k - nx + nb - 1) / nb * nb; + kk = min(i__1, i__2); + i__1 = *n - kk; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = *m - kk + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; + } + } + } else { + kk = 0; + } + i__1 = *m - kk; + i__2 = *n - kk; + i__3 = *k - kk; + dorg2l_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], &iinfo); + if (kk > 0) { + i__1 = *k; + i__2 = nb; + for (i__ = *k - kk + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + i__3 = nb, i__4 = *k - i__ + 1; + ib = min(i__3, i__4); + if (*n - *k + i__ > 1) { + i__3 = *m - *k + i__ + ib - 1; + dlarft_((char *)"Backward", (char *)"Columnwise", &i__3, &ib, &a[(*n - *k + i__) * a_dim1 + 1], lda, + &tau[i__], &work[1], &ldwork, (ftnlen)8, (ftnlen)10); + i__3 = *m - *k + i__ + ib - 1; + i__4 = *n - *k + i__ - 1; + dlarfb_((char *)"Left", (char *)"No transpose", (char *)"Backward", (char *)"Columnwise", &i__3, &i__4, &ib, + &a[(*n - *k + i__) * a_dim1 + 1], lda, &work[1], &ldwork, &a[a_offset], lda, + &work[ib + 1], &ldwork, (ftnlen)4, (ftnlen)12, (ftnlen)8, (ftnlen)10); + } + i__3 = *m - *k + i__ + ib - 1; + dorg2l_(&i__3, &ib, &ib, &a[(*n - *k + i__) * a_dim1 + 1], lda, &tau[i__], &work[1], + &iinfo); + i__3 = *n - *k + i__ + ib - 1; + for (j = *n - *k + i__; j <= i__3; ++j) { + i__4 = *m; + for (l = *m - *k + i__ + ib; l <= i__4; ++l) { + a[l + j * a_dim1] = 0.; + } + } + } + } + work[1] = (doublereal)iws; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dorgql.f b/lib/linalg/dorgql.f deleted file mode 100644 index 45e5bf19f1..0000000000 --- a/lib/linalg/dorgql.f +++ /dev/null @@ -1,293 +0,0 @@ -*> \brief \b DORGQL -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORGQL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DORGQL generates an M-by-N real matrix Q with orthonormal columns, -*> which is defined as the last N columns of a product of K elementary -*> reflectors of order M -*> -*> Q = H(k) . . . H(2) H(1) -*> -*> as returned by DGEQLF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix Q. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix Q. M >= N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines the -*> matrix Q. N >= K >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the (n-k+i)-th column must contain the vector which -*> defines the elementary reflector H(i), for i = 1,2,...,k, as -*> returned by DGEQLF in the last k columns of its array -*> argument A. -*> On exit, the M-by-N matrix Q. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The first dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by DGEQLF. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. LWORK >= max(1,N). -*> For optimum performance LWORK >= N*NB, where NB is the -*> optimal blocksize. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal size of the WORK array, returns -*> this value as the first entry of the WORK array, and no error -*> message related to LWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument has an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT, - $ NB, NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL DLARFB, DLARFT, DORG2L, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - END IF -* - IF( INFO.EQ.0 ) THEN - IF( N.EQ.0 ) THEN - LWKOPT = 1 - ELSE - NB = ILAENV( 1, 'DORGQL', ' ', M, N, K, -1 ) - LWKOPT = N*NB - END IF - WORK( 1 ) = LWKOPT -* - IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -8 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORGQL', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) THEN - RETURN - END IF -* - NBMIN = 2 - NX = 0 - IWS = N - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'DORGQL', ' ', M, N, K, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORGQL', ' ', M, N, K, -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code after the first block. -* The last kk columns are handled by the block method. -* - KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB ) -* -* Set A(m-kk+1:m,1:n-kk) to zero. -* - DO 20 J = 1, N - KK - DO 10 I = M - KK + 1, M - A( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - KK = 0 - END IF -* -* Use unblocked code for the first or only block. -* - CALL DORG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO ) -* - IF( KK.GT.0 ) THEN -* -* Use blocked code -* - DO 50 I = K - KK + 1, K, NB - IB = MIN( NB, K-I+1 ) - IF( N-K+I.GT.1 ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i+ib-1) . . . H(i+1) H(i) -* - CALL DLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB, - $ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left -* - CALL DLARFB( 'Left', 'No transpose', 'Backward', - $ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB, - $ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA, - $ WORK( IB+1 ), LDWORK ) - END IF -* -* Apply H to rows 1:m-k+i+ib-1 of current block -* - CALL DORG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA, - $ TAU( I ), WORK, IINFO ) -* -* Set rows m-k+i+ib:m of current block to zero -* - DO 40 J = N - K + I, N - K + I + IB - 1 - DO 30 L = M - K + I + IB, M - A( L, J ) = ZERO - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - END IF -* - WORK( 1 ) = IWS - RETURN -* -* End of DORGQL -* - END diff --git a/lib/linalg/dorgqr.cpp b/lib/linalg/dorgqr.cpp new file mode 100644 index 0000000000..9f4e8f5da1 --- /dev/null +++ b/lib/linalg/dorgqr.cpp @@ -0,0 +1,128 @@ +#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; +int dorgqr_(integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, + doublereal *work, integer *lwork, integer *info) +{ + integer a_dim1, a_offset, i__1, i__2, i__3; + integer i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo; + extern int dorg2r_(integer *, integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *), + dlarfb_(char *, char *, char *, char *, integer *, integer *, integer *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, ftnlen, ftnlen, ftnlen, ftnlen), + dlarft_(char *, char *, integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *, 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; + nb = ilaenv_(&c__1, (char *)"DORGQR", (char *)" ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1); + lwkopt = max(1, *n) * nb; + work[1] = (doublereal)lwkopt; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0 || *n > *m) { + *info = -2; + } else if (*k < 0 || *k > *n) { + *info = -3; + } else if (*lda < max(1, *m)) { + *info = -5; + } else if (*lwork < max(1, *n) && !lquery) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DORGQR", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + if (*n <= 0) { + work[1] = 1.; + return 0; + } + nbmin = 2; + nx = 0; + iws = *n; + if (nb > 1 && nb < *k) { + i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"DORGQR", (char *)" ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1); + nx = max(i__1, i__2); + if (nx < *k) { + ldwork = *n; + iws = ldwork * nb; + if (*lwork < iws) { + nb = *lwork / ldwork; + i__1 = 2, + i__2 = ilaenv_(&c__2, (char *)"DORGQR", (char *)" ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1); + nbmin = max(i__1, i__2); + } + } + } + if (nb >= nbmin && nb < *k && nx < *k) { + ki = (*k - nx - 1) / nb * nb; + i__1 = *k, i__2 = ki + nb; + kk = min(i__1, i__2); + i__1 = *n; + for (j = kk + 1; j <= i__1; ++j) { + i__2 = kk; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; + } + } + } else { + kk = 0; + } + if (kk < *n) { + i__1 = *m - kk; + i__2 = *n - kk; + i__3 = *k - kk; + dorg2r_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, &tau[kk + 1], &work[1], + &iinfo); + } + if (kk > 0) { + i__1 = -nb; + for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { + i__2 = nb, i__3 = *k - i__ + 1; + ib = min(i__2, i__3); + if (i__ + ib <= *n) { + i__2 = *m - i__ + 1; + dlarft_((char *)"Forward", (char *)"Columnwise", &i__2, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], + &work[1], &ldwork, (ftnlen)7, (ftnlen)10); + i__2 = *m - i__ + 1; + i__3 = *n - i__ - ib + 1; + dlarfb_((char *)"Left", (char *)"No transpose", (char *)"Forward", (char *)"Columnwise", &i__2, &i__3, &ib, + &a[i__ + i__ * a_dim1], lda, &work[1], &ldwork, + &a[i__ + (i__ + ib) * a_dim1], lda, &work[ib + 1], &ldwork, (ftnlen)4, + (ftnlen)12, (ftnlen)7, (ftnlen)10); + } + i__2 = *m - i__ + 1; + dorg2r_(&i__2, &ib, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1], &iinfo); + i__2 = i__ + ib - 1; + for (j = i__; j <= i__2; ++j) { + i__3 = i__ - 1; + for (l = 1; l <= i__3; ++l) { + a[l + j * a_dim1] = 0.; + } + } + } + } + work[1] = (doublereal)iws; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dorgqr.f b/lib/linalg/dorgqr.f deleted file mode 100644 index a41ce7ed56..0000000000 --- a/lib/linalg/dorgqr.f +++ /dev/null @@ -1,287 +0,0 @@ -*> \brief \b DORGQR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORGQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DORGQR generates an M-by-N real matrix Q with orthonormal columns, -*> which is defined as the first N columns of a product of K elementary -*> reflectors of order M -*> -*> Q = H(1) H(2) . . . H(k) -*> -*> as returned by DGEQRF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix Q. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix Q. M >= N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines the -*> matrix Q. N >= K >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the i-th column must contain the vector which -*> defines the elementary reflector H(i), for i = 1,2,...,k, as -*> returned by DGEQRF in the first k columns of its array -*> argument A. -*> On exit, the M-by-N matrix Q. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The first dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by DGEQRF. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. LWORK >= max(1,N). -*> For optimum performance LWORK >= N*NB, where NB is the -*> optimal blocksize. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal size of the WORK array, returns -*> this value as the first entry of the WORK array, and no error -*> message related to LWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument has an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, - $ LWKOPT, NB, NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL DLARFB, DLARFT, DORG2R, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 ) - LWKOPT = MAX( 1, N )*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORGQR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - NX = 0 - IWS = N - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'DORGQR', ' ', M, N, K, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORGQR', ' ', M, N, K, -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code after the last block. -* The first kk columns are handled by the block method. -* - KI = ( ( K-NX-1 ) / NB )*NB - KK = MIN( K, KI+NB ) -* -* Set A(1:kk,kk+1:n) to zero. -* - DO 20 J = KK + 1, N - DO 10 I = 1, KK - A( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - KK = 0 - END IF -* -* Use unblocked code for the last or only block. -* - IF( KK.LT.N ) - $ CALL DORG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, - $ TAU( KK+1 ), WORK, IINFO ) -* - IF( KK.GT.0 ) THEN -* -* Use blocked code -* - DO 50 I = KI + 1, 1, -NB - IB = MIN( NB, K-I+1 ) - IF( I+IB.LE.N ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, - $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H to A(i:m,i+ib:n) from the left -* - CALL DLARFB( 'Left', 'No transpose', 'Forward', - $ 'Columnwise', M-I+1, N-I-IB+1, IB, - $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), - $ LDA, WORK( IB+1 ), LDWORK ) - END IF -* -* Apply H to rows i:m of current block -* - CALL DORG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) -* -* Set rows 1:i-1 of current block to zero -* - DO 40 J = I, I + IB - 1 - DO 30 L = 1, I - 1 - A( L, J ) = ZERO - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - END IF -* - WORK( 1 ) = IWS - RETURN -* -* End of DORGQR -* - END diff --git a/lib/linalg/dorgtr.cpp b/lib/linalg/dorgtr.cpp new file mode 100644 index 0000000000..692b6c4945 --- /dev/null +++ b/lib/linalg/dorgtr.cpp @@ -0,0 +1,115 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +static integer c_n1 = -1; +int dorgtr_(char *uplo, integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal *work, + integer *lwork, integer *info, ftnlen uplo_len) +{ + integer a_dim1, a_offset, i__1, i__2, i__3; + integer i__, j, nb; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + integer iinfo; + logical upper; + extern int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, + ftnlen, ftnlen); + extern int dorgql_(integer *, integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *, integer *), + 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; + lquery = *lwork == -1; + 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; + } else { + i__1 = 1, i__2 = *n - 1; + if (*lwork < max(i__1, i__2) && !lquery) { + *info = -7; + } + } + if (*info == 0) { + if (upper) { + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + nb = ilaenv_(&c__1, (char *)"DORGQL", (char *)" ", &i__1, &i__2, &i__3, &c_n1, (ftnlen)6, (ftnlen)1); + } else { + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + nb = ilaenv_(&c__1, (char *)"DORGQR", (char *)" ", &i__1, &i__2, &i__3, &c_n1, (ftnlen)6, (ftnlen)1); + } + i__1 = 1, i__2 = *n - 1; + lwkopt = max(i__1, i__2) * nb; + work[1] = (doublereal)lwkopt; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DORGTR", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + if (*n == 0) { + work[1] = 1.; + return 0; + } + if (upper) { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = a[i__ + (j + 1) * a_dim1]; + } + a[*n + j * a_dim1] = 0.; + } + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + a[i__ + *n * a_dim1] = 0.; + } + a[*n + *n * a_dim1] = 1.; + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + dorgql_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], lwork, &iinfo); + } else { + for (j = *n; j >= 2; --j) { + a[j * a_dim1 + 1] = 0.; + i__1 = *n; + for (i__ = j + 1; i__ <= i__1; ++i__) { + a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1]; + } + } + a[a_dim1 + 1] = 1.; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + a[i__ + a_dim1] = 0.; + } + if (*n > 1) { + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + dorgqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[1], &work[1], lwork, + &iinfo); + } + } + work[1] = (doublereal)lwkopt; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dorgtr.f b/lib/linalg/dorgtr.f deleted file mode 100644 index 0a0ab15a78..0000000000 --- a/lib/linalg/dorgtr.f +++ /dev/null @@ -1,252 +0,0 @@ -*> \brief \b DORGTR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORGTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DORGTR generates a real orthogonal matrix Q which is defined as the -*> product of n-1 elementary reflectors of order N, as returned by -*> DSYTRD: -*> -*> if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), -*> -*> if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A contains elementary reflectors -*> from DSYTRD; -*> = 'L': Lower triangle of A contains elementary reflectors -*> from DSYTRD. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix Q. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the vectors which define the elementary reflectors, -*> as returned by DSYTRD. -*> On exit, the N-by-N orthogonal matrix Q. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (N-1) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by DSYTRD. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. LWORK >= max(1,N-1). -*> For optimum performance LWORK >= (N-1)*NB, where NB is -*> the optimal blocksize. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal size of the WORK array, returns -*> this value as the first entry of the WORK array, and no error -*> message related to LWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY, UPPER - INTEGER I, IINFO, J, LWKOPT, NB -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DORGQL, DORGQR, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN - INFO = -7 - END IF -* - IF( INFO.EQ.0 ) THEN - IF( UPPER ) THEN - NB = ILAENV( 1, 'DORGQL', ' ', N-1, N-1, N-1, -1 ) - ELSE - NB = ILAENV( 1, 'DORGQR', ' ', N-1, N-1, N-1, -1 ) - END IF - LWKOPT = MAX( 1, N-1 )*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORGTR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - IF( UPPER ) THEN -* -* Q was determined by a call to DSYTRD with UPLO = 'U' -* -* Shift the vectors which define the elementary reflectors one -* column to the left, and set the last row and column of Q to -* those of the unit matrix -* - DO 20 J = 1, N - 1 - DO 10 I = 1, J - 1 - A( I, J ) = A( I, J+1 ) - 10 CONTINUE - A( N, J ) = ZERO - 20 CONTINUE - DO 30 I = 1, N - 1 - A( I, N ) = ZERO - 30 CONTINUE - A( N, N ) = ONE -* -* Generate Q(1:n-1,1:n-1) -* - CALL DORGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO ) -* - ELSE -* -* Q was determined by a call to DSYTRD with UPLO = 'L'. -* -* Shift the vectors which define the elementary reflectors one -* column to the right, and set the first row and column of Q to -* those of the unit matrix -* - DO 50 J = N, 2, -1 - A( 1, J ) = ZERO - DO 40 I = J + 1, N - A( I, J ) = A( I, J-1 ) - 40 CONTINUE - 50 CONTINUE - A( 1, 1 ) = ONE - DO 60 I = 2, N - A( I, 1 ) = ZERO - 60 CONTINUE - IF( N.GT.1 ) THEN -* -* Generate Q(2:n,2:n) -* - CALL DORGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, - $ LWORK, IINFO ) - END IF - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of DORGTR -* - END diff --git a/lib/linalg/dorm2l.cpp b/lib/linalg/dorm2l.cpp new file mode 100644 index 0000000000..35d3b346a5 --- /dev/null +++ b/lib/linalg/dorm2l.cpp @@ -0,0 +1,90 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +int dorm2l_(char *side, char *trans, integer *m, integer *n, integer *k, doublereal *a, + integer *lda, doublereal *tau, doublereal *c__, integer *ldc, doublereal *work, + integer *info, ftnlen side_len, ftnlen trans_len) +{ + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; + integer i__, i1, i2, i3, mi, ni, nq; + doublereal aii; + logical left; + extern int dlarf_(char *, integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *, doublereal *, ftnlen); + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern int xerbla_(char *, integer *, ftnlen); + logical notran; + 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; + left = lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1); + notran = lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1); + if (left) { + nq = *m; + } else { + nq = *n; + } + if (!left && !lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { + *info = -1; + } else if (!notran && !lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0 || *k > nq) { + *info = -5; + } else if (*lda < max(1, nq)) { + *info = -7; + } else if (*ldc < max(1, *m)) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DORM2L", &i__1, (ftnlen)6); + return 0; + } + if (*m == 0 || *n == 0 || *k == 0) { + return 0; + } + if (left && notran || !left && !notran) { + i1 = 1; + i2 = *k; + i3 = 1; + } else { + i1 = *k; + i2 = 1; + i3 = -1; + } + if (left) { + ni = *n; + } else { + mi = *m; + } + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + if (left) { + mi = *m - *k + i__; + } else { + ni = *n - *k + i__; + } + aii = a[nq - *k + i__ + i__ * a_dim1]; + a[nq - *k + i__ + i__ * a_dim1] = 1.; + dlarf_(side, &mi, &ni, &a[i__ * a_dim1 + 1], &c__1, &tau[i__], &c__[c_offset], ldc, + &work[1], (ftnlen)1); + a[nq - *k + i__ + i__ * a_dim1] = aii; + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dorm2l.f b/lib/linalg/dorm2l.f deleted file mode 100644 index c99039c541..0000000000 --- a/lib/linalg/dorm2l.f +++ /dev/null @@ -1,275 +0,0 @@ -*> \brief \b DORM2L multiplies a general matrix by the orthogonal matrix from a QL factorization determined by sgeqlf (unblocked algorithm). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORM2L + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, -* WORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER SIDE, TRANS -* INTEGER INFO, K, LDA, LDC, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DORM2L overwrites the general real m by n matrix C with -*> -*> Q * C if SIDE = 'L' and TRANS = 'N', or -*> -*> Q**T * C if SIDE = 'L' and TRANS = 'T', or -*> -*> C * Q if SIDE = 'R' and TRANS = 'N', or -*> -*> C * Q**T if SIDE = 'R' and TRANS = 'T', -*> -*> where Q is a real orthogonal matrix defined as the product of k -*> elementary reflectors -*> -*> Q = H(k) . . . H(2) H(1) -*> -*> as returned by DGEQLF. Q is of order m if SIDE = 'L' and of order n -*> if SIDE = 'R'. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': apply Q or Q**T from the Left -*> = 'R': apply Q or Q**T from the Right -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> = 'N': apply Q (No transpose) -*> = 'T': apply Q**T (Transpose) -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines -*> the matrix Q. -*> If SIDE = 'L', M >= K >= 0; -*> if SIDE = 'R', N >= K >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,K) -*> The i-th column must contain the vector which defines the -*> elementary reflector H(i), for i = 1,2,...,k, as returned by -*> DGEQLF in the last k columns of its array argument A. -*> A is modified by the routine but restored on exit. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. -*> If SIDE = 'L', LDA >= max(1,M); -*> if SIDE = 'R', LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by DGEQLF. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension (LDC,N) -*> On entry, the m by n matrix C. -*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension -*> (N) if SIDE = 'L', -*> (M) if SIDE = 'R' -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, NOTRAN - INTEGER I, I1, I2, I3, MI, NI, NQ - DOUBLE PRECISION AII -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLARF, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) -* -* NQ is the order of Q -* - IF( LEFT ) THEN - NQ = M - ELSE - NQ = N - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORM2L', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN -* - IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) - $ THEN - I1 = 1 - I2 = K - I3 = 1 - ELSE - I1 = K - I2 = 1 - I3 = -1 - END IF -* - IF( LEFT ) THEN - NI = N - ELSE - MI = M - END IF -* - DO 10 I = I1, I2, I3 - IF( LEFT ) THEN -* -* H(i) is applied to C(1:m-k+i,1:n) -* - MI = M - K + I - ELSE -* -* H(i) is applied to C(1:m,1:n-k+i) -* - NI = N - K + I - END IF -* -* Apply H(i) -* - AII = A( NQ-K+I, I ) - A( NQ-K+I, I ) = ONE - CALL DLARF( SIDE, MI, NI, A( 1, I ), 1, TAU( I ), C, LDC, - $ WORK ) - A( NQ-K+I, I ) = AII - 10 CONTINUE - RETURN -* -* End of DORM2L -* - END diff --git a/lib/linalg/dorm2r.cpp b/lib/linalg/dorm2r.cpp new file mode 100644 index 0000000000..6594725f24 --- /dev/null +++ b/lib/linalg/dorm2r.cpp @@ -0,0 +1,94 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +int dorm2r_(char *side, char *trans, integer *m, integer *n, integer *k, doublereal *a, + integer *lda, doublereal *tau, doublereal *c__, integer *ldc, doublereal *work, + integer *info, ftnlen side_len, ftnlen trans_len) +{ + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; + integer i__, i1, i2, i3, ic, jc, mi, ni, nq; + doublereal aii; + logical left; + extern int dlarf_(char *, integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *, doublereal *, ftnlen); + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern int xerbla_(char *, integer *, ftnlen); + logical notran; + 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; + left = lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1); + notran = lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1); + if (left) { + nq = *m; + } else { + nq = *n; + } + if (!left && !lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { + *info = -1; + } else if (!notran && !lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0 || *k > nq) { + *info = -5; + } else if (*lda < max(1, nq)) { + *info = -7; + } else if (*ldc < max(1, *m)) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DORM2R", &i__1, (ftnlen)6); + return 0; + } + if (*m == 0 || *n == 0 || *k == 0) { + return 0; + } + if (left && !notran || !left && notran) { + i1 = 1; + i2 = *k; + i3 = 1; + } else { + i1 = *k; + i2 = 1; + i3 = -1; + } + if (left) { + ni = *n; + jc = 1; + } else { + mi = *m; + ic = 1; + } + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + if (left) { + mi = *m - i__ + 1; + ic = i__; + } else { + ni = *n - i__ + 1; + jc = i__; + } + aii = a[i__ + i__ * a_dim1]; + a[i__ + i__ * a_dim1] = 1.; + dlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], &c__1, &tau[i__], &c__[ic + jc * c_dim1], + ldc, &work[1], (ftnlen)1); + a[i__ + i__ * a_dim1] = aii; + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dorm2r.f b/lib/linalg/dorm2r.f deleted file mode 100644 index ac88eec8dc..0000000000 --- a/lib/linalg/dorm2r.f +++ /dev/null @@ -1,279 +0,0 @@ -*> \brief \b DORM2R multiplies a general matrix by the orthogonal matrix from a QR factorization determined by sgeqrf (unblocked algorithm). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORM2R + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, -* WORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER SIDE, TRANS -* INTEGER INFO, K, LDA, LDC, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DORM2R overwrites the general real m by n matrix C with -*> -*> Q * C if SIDE = 'L' and TRANS = 'N', or -*> -*> Q**T* C if SIDE = 'L' and TRANS = 'T', or -*> -*> C * Q if SIDE = 'R' and TRANS = 'N', or -*> -*> C * Q**T if SIDE = 'R' and TRANS = 'T', -*> -*> where Q is a real orthogonal matrix defined as the product of k -*> elementary reflectors -*> -*> Q = H(1) H(2) . . . H(k) -*> -*> as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n -*> if SIDE = 'R'. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': apply Q or Q**T from the Left -*> = 'R': apply Q or Q**T from the Right -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> = 'N': apply Q (No transpose) -*> = 'T': apply Q**T (Transpose) -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines -*> the matrix Q. -*> If SIDE = 'L', M >= K >= 0; -*> if SIDE = 'R', N >= K >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,K) -*> The i-th column must contain the vector which defines the -*> elementary reflector H(i), for i = 1,2,...,k, as returned by -*> DGEQRF in the first k columns of its array argument A. -*> A is modified by the routine but restored on exit. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. -*> If SIDE = 'L', LDA >= max(1,M); -*> if SIDE = 'R', LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by DGEQRF. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension (LDC,N) -*> On entry, the m by n matrix C. -*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension -*> (N) if SIDE = 'L', -*> (M) if SIDE = 'R' -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, NOTRAN - INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ - DOUBLE PRECISION AII -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLARF, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) -* -* NQ is the order of Q -* - IF( LEFT ) THEN - NQ = M - ELSE - NQ = N - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORM2R', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN -* - IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) - $ THEN - I1 = 1 - I2 = K - I3 = 1 - ELSE - I1 = K - I2 = 1 - I3 = -1 - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - DO 10 I = I1, I2, I3 - IF( LEFT ) THEN -* -* H(i) is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H(i) is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H(i) -* - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ), - $ LDC, WORK ) - A( I, I ) = AII - 10 CONTINUE - RETURN -* -* End of DORM2R -* - END diff --git a/lib/linalg/dormbr.cpp b/lib/linalg/dormbr.cpp new file mode 100644 index 0000000000..8be8ab13d8 --- /dev/null +++ b/lib/linalg/dormbr.cpp @@ -0,0 +1,175 @@ +#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 dormbr_(char *vect, char *side, char *trans, integer *m, integer *n, integer *k, doublereal *a, + integer *lda, doublereal *tau, doublereal *c__, integer *ldc, doublereal *work, + integer *lwork, integer *info, ftnlen vect_len, ftnlen side_len, ftnlen trans_len) +{ + address a__1[2]; + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2]; + char ch__1[2]; + int s_lmp_cat(char *, char **, integer *, integer *, ftnlen); + integer i1, i2, nb, mi, 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 dormlq_(char *, char *, integer *, integer *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, integer *, + ftnlen, ftnlen); + logical notran; + extern int dormqr_(char *, char *, integer *, integer *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, integer *, + ftnlen, ftnlen); + logical applyq; + char transt[1]; + 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; + applyq = lsame_(vect, (char *)"Q", (ftnlen)1, (ftnlen)1); + left = lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1); + notran = lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1); + lquery = *lwork == -1; + if (left) { + nq = *m; + nw = max(1, *n); + } else { + nq = *n; + nw = max(1, *m); + } + if (!applyq && !lsame_(vect, (char *)"P", (ftnlen)1, (ftnlen)1)) { + *info = -1; + } else if (!left && !lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { + *info = -2; + } else if (!notran && !lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*k < 0) { + *info = -6; + } else { + i__1 = 1, i__2 = min(nq, *k); + if (applyq && *lda < max(1, nq) || !applyq && *lda < max(i__1, i__2)) { + *info = -8; + } else if (*ldc < max(1, *m)) { + *info = -11; + } else if (*lwork < nw && !lquery) { + *info = -13; + } + } + if (*info == 0) { + if (applyq) { + if (left) { + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_lmp_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = *m - 1; + i__2 = *m - 1; + nb = ilaenv_(&c__1, (char *)"DORMQR", ch__1, &i__1, n, &i__2, &c_n1, (ftnlen)6, (ftnlen)2); + } else { + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_lmp_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = *n - 1; + i__2 = *n - 1; + nb = ilaenv_(&c__1, (char *)"DORMQR", ch__1, m, &i__1, &i__2, &c_n1, (ftnlen)6, (ftnlen)2); + } + } else { + if (left) { + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_lmp_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = *m - 1; + i__2 = *m - 1; + nb = ilaenv_(&c__1, (char *)"DORMLQ", ch__1, &i__1, n, &i__2, &c_n1, (ftnlen)6, (ftnlen)2); + } else { + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_lmp_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = *n - 1; + i__2 = *n - 1; + nb = ilaenv_(&c__1, (char *)"DORMLQ", ch__1, m, &i__1, &i__2, &c_n1, (ftnlen)6, (ftnlen)2); + } + } + lwkopt = nw * nb; + work[1] = (doublereal)lwkopt; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DORMBR", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + work[1] = 1.; + if (*m == 0 || *n == 0) { + return 0; + } + if (applyq) { + if (nq >= *k) { + dormqr_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[c_offset], ldc, &work[1], + lwork, &iinfo, (ftnlen)1, (ftnlen)1); + } else if (nq > 1) { + if (left) { + mi = *m - 1; + ni = *n; + i1 = 2; + i2 = 1; + } else { + mi = *m; + ni = *n - 1; + i1 = 1; + i2 = 2; + } + i__1 = nq - 1; + dormqr_(side, trans, &mi, &ni, &i__1, &a[a_dim1 + 2], lda, &tau[1], + &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo, (ftnlen)1, (ftnlen)1); + } + } else { + if (notran) { + *(unsigned char *)transt = 'T'; + } else { + *(unsigned char *)transt = 'N'; + } + if (nq > *k) { + dormlq_(side, transt, m, n, k, &a[a_offset], lda, &tau[1], &c__[c_offset], ldc, + &work[1], lwork, &iinfo, (ftnlen)1, (ftnlen)1); + } else if (nq > 1) { + if (left) { + mi = *m - 1; + ni = *n; + i1 = 2; + i2 = 1; + } else { + mi = *m; + ni = *n - 1; + i1 = 1; + i2 = 2; + } + i__1 = nq - 1; + dormlq_(side, transt, &mi, &ni, &i__1, &a[(a_dim1 << 1) + 1], lda, &tau[1], + &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo, (ftnlen)1, (ftnlen)1); + } + } + work[1] = (doublereal)lwkopt; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dormbr.f b/lib/linalg/dormbr.f deleted file mode 100644 index 86abb10072..0000000000 --- a/lib/linalg/dormbr.f +++ /dev/null @@ -1,369 +0,0 @@ -*> \brief \b DORMBR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORMBR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, -* LDC, WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER SIDE, TRANS, VECT -* INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> If VECT = 'Q', DORMBR overwrites the general real M-by-N matrix C -*> with -*> SIDE = 'L' SIDE = 'R' -*> TRANS = 'N': Q * C C * Q -*> TRANS = 'T': Q**T * C C * Q**T -*> -*> If VECT = 'P', DORMBR overwrites the general real M-by-N matrix C -*> with -*> SIDE = 'L' SIDE = 'R' -*> TRANS = 'N': P * C C * P -*> TRANS = 'T': P**T * C C * P**T -*> -*> Here Q and P**T are the orthogonal matrices determined by DGEBRD when -*> reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and -*> P**T are defined as products of elementary reflectors H(i) and G(i) -*> respectively. -*> -*> Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the -*> order of the orthogonal matrix Q or P**T that is applied. -*> -*> If VECT = 'Q', A is assumed to have been an NQ-by-K matrix: -*> if nq >= k, Q = H(1) H(2) . . . H(k); -*> if nq < k, Q = H(1) H(2) . . . H(nq-1). -*> -*> If VECT = 'P', A is assumed to have been a K-by-NQ matrix: -*> if k < nq, P = G(1) G(2) . . . G(k); -*> if k >= nq, P = G(1) G(2) . . . G(nq-1). -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] VECT -*> \verbatim -*> VECT is CHARACTER*1 -*> = 'Q': apply Q or Q**T; -*> = 'P': apply P or P**T. -*> \endverbatim -*> -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': apply Q, Q**T, P or P**T from the Left; -*> = 'R': apply Q, Q**T, P or P**T from the Right. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> = 'N': No transpose, apply Q or P; -*> = 'T': Transpose, apply Q**T or P**T. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> If VECT = 'Q', the number of columns in the original -*> matrix reduced by DGEBRD. -*> If VECT = 'P', the number of rows in the original -*> matrix reduced by DGEBRD. -*> K >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension -*> (LDA,min(nq,K)) if VECT = 'Q' -*> (LDA,nq) if VECT = 'P' -*> The vectors which define the elementary reflectors H(i) and -*> G(i), whose products determine the matrices Q and P, as -*> returned by DGEBRD. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. -*> If VECT = 'Q', LDA >= max(1,nq); -*> if VECT = 'P', LDA >= max(1,min(nq,K)). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (min(nq,K)) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i) or G(i) which determines Q or P, as returned -*> by DGEBRD in the array argument TAUQ or TAUP. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension (LDC,N) -*> On entry, the M-by-N matrix C. -*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q -*> or P*C or P**T*C or C*P or C*P**T. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. -*> If SIDE = 'L', LWORK >= max(1,N); -*> if SIDE = 'R', LWORK >= max(1,M). -*> For optimum performance LWORK >= N*NB if SIDE = 'L', and -*> LWORK >= M*NB if SIDE = 'R', where NB is the optimal -*> blocksize. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal size of the WORK array, returns -*> this value as the first entry of the WORK array, and no error -*> message related to LWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, - $ LDC, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS, VECT - INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN - CHARACTER TRANST - INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DORMLQ, DORMQR, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - APPLYQ = LSAME( VECT, 'Q' ) - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) - LQUERY = ( LWORK.EQ.-1 ) -* -* NQ is the order of Q or P and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = MAX( 1, N ) - ELSE - NQ = N - NW = MAX( 1, M ) - END IF - IF( .NOT.APPLYQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -2 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( K.LT.0 ) THEN - INFO = -6 - ELSE IF( ( APPLYQ .AND. LDA.LT.MAX( 1, NQ ) ) .OR. - $ ( .NOT.APPLYQ .AND. LDA.LT.MAX( 1, MIN( NQ, K ) ) ) ) - $ THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -11 - ELSE IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN - INFO = -13 - END IF -* - IF( INFO.EQ.0 ) THEN - IF( APPLYQ ) THEN - IF( LEFT ) THEN - NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M-1, N, M-1, - $ -1 ) - ELSE - NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N-1, N-1, - $ -1 ) - END IF - ELSE - IF( LEFT ) THEN - NB = ILAENV( 1, 'DORMLQ', SIDE // TRANS, M-1, N, M-1, - $ -1 ) - ELSE - NB = ILAENV( 1, 'DORMLQ', SIDE // TRANS, M, N-1, N-1, - $ -1 ) - END IF - END IF - LWKOPT = NW*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORMBR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - WORK( 1 ) = 1 - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* - IF( APPLYQ ) THEN -* -* Apply Q -* - IF( NQ.GE.K ) THEN -* -* Q was determined by a call to DGEBRD with nq >= k -* - CALL DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, IINFO ) - ELSE IF( NQ.GT.1 ) THEN -* -* Q was determined by a call to DGEBRD with nq < k -* - IF( LEFT ) THEN - MI = M - 1 - NI = N - I1 = 2 - I2 = 1 - ELSE - MI = M - NI = N - 1 - I1 = 1 - I2 = 2 - END IF - CALL DORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, - $ C( I1, I2 ), LDC, WORK, LWORK, IINFO ) - END IF - ELSE -* -* Apply P -* - IF( NOTRAN ) THEN - TRANST = 'T' - ELSE - TRANST = 'N' - END IF - IF( NQ.GT.K ) THEN -* -* P was determined by a call to DGEBRD with nq > k -* - CALL DORMLQ( SIDE, TRANST, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, IINFO ) - ELSE IF( NQ.GT.1 ) THEN -* -* P was determined by a call to DGEBRD with nq <= k -* - IF( LEFT ) THEN - MI = M - 1 - NI = N - I1 = 2 - I2 = 1 - ELSE - MI = M - NI = N - 1 - I1 = 1 - I2 = 2 - END IF - CALL DORMLQ( SIDE, TRANST, MI, NI, NQ-1, A( 1, 2 ), LDA, - $ TAU, C( I1, I2 ), LDC, WORK, LWORK, IINFO ) - END IF - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of DORMBR -* - END diff --git a/lib/linalg/dorml2.cpp b/lib/linalg/dorml2.cpp new file mode 100644 index 0000000000..109315fb14 --- /dev/null +++ b/lib/linalg/dorml2.cpp @@ -0,0 +1,93 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dorml2_(char *side, char *trans, integer *m, integer *n, integer *k, doublereal *a, + integer *lda, doublereal *tau, doublereal *c__, integer *ldc, doublereal *work, + integer *info, ftnlen side_len, ftnlen trans_len) +{ + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; + integer i__, i1, i2, i3, ic, jc, mi, ni, nq; + doublereal aii; + logical left; + extern int dlarf_(char *, integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *, doublereal *, ftnlen); + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern int xerbla_(char *, integer *, ftnlen); + logical notran; + 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; + left = lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1); + notran = lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1); + if (left) { + nq = *m; + } else { + nq = *n; + } + if (!left && !lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { + *info = -1; + } else if (!notran && !lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0 || *k > nq) { + *info = -5; + } else if (*lda < max(1, *k)) { + *info = -7; + } else if (*ldc < max(1, *m)) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DORML2", &i__1, (ftnlen)6); + return 0; + } + if (*m == 0 || *n == 0 || *k == 0) { + return 0; + } + if (left && notran || !left && !notran) { + i1 = 1; + i2 = *k; + i3 = 1; + } else { + i1 = *k; + i2 = 1; + i3 = -1; + } + if (left) { + ni = *n; + jc = 1; + } else { + mi = *m; + ic = 1; + } + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + if (left) { + mi = *m - i__ + 1; + ic = i__; + } else { + ni = *n - i__ + 1; + jc = i__; + } + aii = a[i__ + i__ * a_dim1]; + a[i__ + i__ * a_dim1] = 1.; + dlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], lda, &tau[i__], &c__[ic + jc * c_dim1], ldc, + &work[1], (ftnlen)1); + a[i__ + i__ * a_dim1] = aii; + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dorml2.f b/lib/linalg/dorml2.f deleted file mode 100644 index a9ddd460d8..0000000000 --- a/lib/linalg/dorml2.f +++ /dev/null @@ -1,279 +0,0 @@ -*> \brief \b DORML2 multiplies a general matrix by the orthogonal matrix from a LQ factorization determined by sgelqf (unblocked algorithm). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORML2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, -* WORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER SIDE, TRANS -* INTEGER INFO, K, LDA, LDC, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DORML2 overwrites the general real m by n matrix C with -*> -*> Q * C if SIDE = 'L' and TRANS = 'N', or -*> -*> Q**T* C if SIDE = 'L' and TRANS = 'T', or -*> -*> C * Q if SIDE = 'R' and TRANS = 'N', or -*> -*> C * Q**T if SIDE = 'R' and TRANS = 'T', -*> -*> where Q is a real orthogonal matrix defined as the product of k -*> elementary reflectors -*> -*> Q = H(k) . . . H(2) H(1) -*> -*> as returned by DGELQF. Q is of order m if SIDE = 'L' and of order n -*> if SIDE = 'R'. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': apply Q or Q**T from the Left -*> = 'R': apply Q or Q**T from the Right -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> = 'N': apply Q (No transpose) -*> = 'T': apply Q**T (Transpose) -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines -*> the matrix Q. -*> If SIDE = 'L', M >= K >= 0; -*> if SIDE = 'R', N >= K >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension -*> (LDA,M) if SIDE = 'L', -*> (LDA,N) if SIDE = 'R' -*> The i-th row must contain the vector which defines the -*> elementary reflector H(i), for i = 1,2,...,k, as returned by -*> DGELQF in the first k rows of its array argument A. -*> A is modified by the routine but restored on exit. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,K). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by DGELQF. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension (LDC,N) -*> On entry, the m by n matrix C. -*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension -*> (N) if SIDE = 'L', -*> (M) if SIDE = 'R' -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, NOTRAN - INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ - DOUBLE PRECISION AII -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLARF, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) -* -* NQ is the order of Q -* - IF( LEFT ) THEN - NQ = M - ELSE - NQ = N - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, K ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORML2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN -* - IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) - $ THEN - I1 = 1 - I2 = K - I3 = 1 - ELSE - I1 = K - I2 = 1 - I3 = -1 - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - DO 10 I = I1, I2, I3 - IF( LEFT ) THEN -* -* H(i) is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H(i) is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H(i) -* - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( SIDE, MI, NI, A( I, I ), LDA, TAU( I ), - $ C( IC, JC ), LDC, WORK ) - A( I, I ) = AII - 10 CONTINUE - RETURN -* -* End of DORML2 -* - END diff --git a/lib/linalg/dormlq.cpp b/lib/linalg/dormlq.cpp new file mode 100644 index 0000000000..d8bedae2f9 --- /dev/null +++ b/lib/linalg/dormlq.cpp @@ -0,0 +1,156 @@ +#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 integer c__65 = 65; +int dormlq_(char *side, char *trans, integer *m, integer *n, integer *k, 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, i__2, i__3[2], i__4, i__5; + char ch__1[2]; + int s_lmp_cat(char *, char **, integer *, integer *, ftnlen); + integer i__, i1, i2, i3, ib, ic, jc, nb, mi, ni, nq, nw, iwt; + logical left; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + integer nbmin, iinfo; + extern int dorml2_(char *, char *, integer *, integer *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, ftnlen, + ftnlen), + dlarfb_(char *, char *, char *, char *, integer *, integer *, integer *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, ftnlen, ftnlen, ftnlen, ftnlen), + dlarft_(char *, char *, integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *, ftnlen, ftnlen), + xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, + ftnlen, ftnlen); + logical notran; + integer ldwork; + char transt[1]; + 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; + left = lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1); + notran = lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1); + lquery = *lwork == -1; + if (left) { + nq = *m; + nw = max(1, *n); + } else { + nq = *n; + nw = max(1, *m); + } + if (!left && !lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { + *info = -1; + } else if (!notran && !lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0 || *k > nq) { + *info = -5; + } else if (*lda < max(1, *k)) { + *info = -7; + } else if (*ldc < max(1, *m)) { + *info = -10; + } else if (*lwork < nw && !lquery) { + *info = -12; + } + if (*info == 0) { + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_lmp_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = 64, i__2 = ilaenv_(&c__1, (char *)"DORMLQ", ch__1, m, n, k, &c_n1, (ftnlen)6, (ftnlen)2); + nb = min(i__1, i__2); + lwkopt = nw * nb + 4160; + work[1] = (doublereal)lwkopt; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DORMLQ", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + if (*m == 0 || *n == 0 || *k == 0) { + work[1] = 1.; + return 0; + } + nbmin = 2; + ldwork = nw; + if (nb > 1 && nb < *k) { + if (*lwork < lwkopt) { + nb = (*lwork - 4160) / ldwork; + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_lmp_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DORMLQ", ch__1, m, n, k, &c_n1, (ftnlen)6, (ftnlen)2); + nbmin = max(i__1, i__2); + } + } + if (nb < nbmin || nb >= *k) { + dorml2_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[c_offset], ldc, &work[1], + &iinfo, (ftnlen)1, (ftnlen)1); + } else { + iwt = nw * nb + 1; + if (left && notran || !left && !notran) { + i1 = 1; + i2 = *k; + i3 = nb; + } else { + i1 = (*k - 1) / nb * nb + 1; + i2 = 1; + i3 = -nb; + } + if (left) { + ni = *n; + jc = 1; + } else { + mi = *m; + ic = 1; + } + if (notran) { + *(unsigned char *)transt = 'T'; + } else { + *(unsigned char *)transt = 'N'; + } + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + i__4 = nb, i__5 = *k - i__ + 1; + ib = min(i__4, i__5); + i__4 = nq - i__ + 1; + dlarft_((char *)"Forward", (char *)"Rowwise", &i__4, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], + &work[iwt], &c__65, (ftnlen)7, (ftnlen)7); + if (left) { + mi = *m - i__ + 1; + ic = i__; + } else { + ni = *n - i__ + 1; + jc = i__; + } + dlarfb_(side, transt, (char *)"Forward", (char *)"Rowwise", &mi, &ni, &ib, &a[i__ + i__ * a_dim1], lda, + &work[iwt], &c__65, &c__[ic + jc * c_dim1], ldc, &work[1], &ldwork, (ftnlen)1, + (ftnlen)1, (ftnlen)7, (ftnlen)7); + } + } + work[1] = (doublereal)lwkopt; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dormlq.f b/lib/linalg/dormlq.f deleted file mode 100644 index ef039285ab..0000000000 --- a/lib/linalg/dormlq.f +++ /dev/null @@ -1,344 +0,0 @@ -*> \brief \b DORMLQ -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORMLQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, -* WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER SIDE, TRANS -* INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DORMLQ overwrites the general real M-by-N matrix C with -*> -*> SIDE = 'L' SIDE = 'R' -*> TRANS = 'N': Q * C C * Q -*> TRANS = 'T': Q**T * C C * Q**T -*> -*> where Q is a real orthogonal matrix defined as the product of k -*> elementary reflectors -*> -*> Q = H(k) . . . H(2) H(1) -*> -*> as returned by DGELQF. Q is of order M if SIDE = 'L' and of order N -*> if SIDE = 'R'. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': apply Q or Q**T from the Left; -*> = 'R': apply Q or Q**T from the Right. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> = 'N': No transpose, apply Q; -*> = 'T': Transpose, apply Q**T. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines -*> the matrix Q. -*> If SIDE = 'L', M >= K >= 0; -*> if SIDE = 'R', N >= K >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension -*> (LDA,M) if SIDE = 'L', -*> (LDA,N) if SIDE = 'R' -*> The i-th row must contain the vector which defines the -*> elementary reflector H(i), for i = 1,2,...,k, as returned by -*> DGELQF in the first k rows of its array argument A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,K). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by DGELQF. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension (LDC,N) -*> On entry, the M-by-N matrix C. -*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. -*> If SIDE = 'L', LWORK >= max(1,N); -*> if SIDE = 'R', LWORK >= max(1,M). -*> For good performance, LWORK should generally be larger. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal size of the WORK array, returns -*> this value as the first entry of the WORK array, and no error -*> message related to LWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - INTEGER NBMAX, LDT, TSIZE - PARAMETER ( NBMAX = 64, LDT = NBMAX+1, - $ TSIZE = LDT*NBMAX ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, LQUERY, NOTRAN - CHARACTER TRANST - INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK, - $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DLARFB, DLARFT, DORML2, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) - LQUERY = ( LWORK.EQ.-1 ) -* -* NQ is the order of Q and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = MAX( 1, N ) - ELSE - NQ = N - NW = MAX( 1, M ) - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, K ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF -* - IF( INFO.EQ.0 ) THEN -* -* Compute the workspace requirements -* - NB = MIN( NBMAX, ILAENV( 1, 'DORMLQ', SIDE // TRANS, M, N, K, - $ -1 ) ) - LWKOPT = NW*NB + TSIZE - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORMLQ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - LDWORK = NW - IF( NB.GT.1 .AND. NB.LT.K ) THEN - IF( LWORK.LT.LWKOPT ) THEN - NB = (LWORK-TSIZE) / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORMLQ', SIDE // TRANS, M, N, K, - $ -1 ) ) - END IF - END IF -* - IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN -* -* Use unblocked code -* - CALL DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, - $ IINFO ) - ELSE -* -* Use blocked code -* - IWT = 1 + NW*NB - IF( ( LEFT .AND. NOTRAN ) .OR. - $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN - I1 = 1 - I2 = K - I3 = NB - ELSE - I1 = ( ( K-1 ) / NB )*NB + 1 - I2 = 1 - I3 = -NB - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - IF( NOTRAN ) THEN - TRANST = 'T' - ELSE - TRANST = 'N' - END IF -* - DO 10 I = I1, I2, I3 - IB = MIN( NB, K-I+1 ) -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Rowwise', NQ-I+1, IB, A( I, I ), - $ LDA, TAU( I ), WORK( IWT ), LDT ) - IF( LEFT ) THEN -* -* H or H**T is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H or H**T is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H or H**T -* - CALL DLARFB( SIDE, TRANST, 'Forward', 'Rowwise', MI, NI, IB, - $ A( I, I ), LDA, WORK( IWT ), LDT, - $ C( IC, JC ), LDC, WORK, LDWORK ) - 10 CONTINUE - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of DORMLQ -* - END diff --git a/lib/linalg/dormql.cpp b/lib/linalg/dormql.cpp new file mode 100644 index 0000000000..45c0801c56 --- /dev/null +++ b/lib/linalg/dormql.cpp @@ -0,0 +1,148 @@ +#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 integer c__65 = 65; +int dormql_(char *side, char *trans, integer *m, integer *n, integer *k, 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, i__2, i__3[2], i__4, i__5; + char ch__1[2]; + int s_lmp_cat(char *, char **, integer *, integer *, ftnlen); + integer i__, i1, i2, i3, ib, nb, mi, ni, nq, nw, iwt; + logical left; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + integer nbmin, iinfo; + extern int dorm2l_(char *, char *, integer *, integer *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, ftnlen, + ftnlen), + dlarfb_(char *, char *, char *, char *, integer *, integer *, integer *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, ftnlen, ftnlen, ftnlen, ftnlen), + dlarft_(char *, char *, integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *, ftnlen, ftnlen), + xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, + ftnlen, ftnlen); + logical notran; + integer ldwork, 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; + left = lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1); + notran = lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1); + lquery = *lwork == -1; + if (left) { + nq = *m; + nw = max(1, *n); + } else { + nq = *n; + nw = max(1, *m); + } + if (!left && !lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { + *info = -1; + } else if (!notran && !lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0 || *k > nq) { + *info = -5; + } else if (*lda < max(1, nq)) { + *info = -7; + } else if (*ldc < max(1, *m)) { + *info = -10; + } else if (*lwork < nw && !lquery) { + *info = -12; + } + if (*info == 0) { + if (*m == 0 || *n == 0) { + lwkopt = 1; + } else { + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_lmp_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = 64, i__2 = ilaenv_(&c__1, (char *)"DORMQL", ch__1, m, n, k, &c_n1, (ftnlen)6, (ftnlen)2); + nb = min(i__1, i__2); + lwkopt = nw * nb + 4160; + } + work[1] = (doublereal)lwkopt; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DORMQL", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + if (*m == 0 || *n == 0) { + return 0; + } + nbmin = 2; + ldwork = nw; + if (nb > 1 && nb < *k) { + if (*lwork < lwkopt) { + nb = (*lwork - 4160) / ldwork; + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_lmp_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DORMQL", ch__1, m, n, k, &c_n1, (ftnlen)6, (ftnlen)2); + nbmin = max(i__1, i__2); + } + } + if (nb < nbmin || nb >= *k) { + dorm2l_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[c_offset], ldc, &work[1], + &iinfo, (ftnlen)1, (ftnlen)1); + } else { + iwt = nw * nb + 1; + if (left && notran || !left && !notran) { + i1 = 1; + i2 = *k; + i3 = nb; + } else { + i1 = (*k - 1) / nb * nb + 1; + i2 = 1; + i3 = -nb; + } + if (left) { + ni = *n; + } else { + mi = *m; + } + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + i__4 = nb, i__5 = *k - i__ + 1; + ib = min(i__4, i__5); + i__4 = nq - *k + i__ + ib - 1; + dlarft_((char *)"Backward", (char *)"Columnwise", &i__4, &ib, &a[i__ * a_dim1 + 1], lda, &tau[i__], + &work[iwt], &c__65, (ftnlen)8, (ftnlen)10); + if (left) { + mi = *m - *k + i__ + ib - 1; + } else { + ni = *n - *k + i__ + ib - 1; + } + dlarfb_(side, trans, (char *)"Backward", (char *)"Columnwise", &mi, &ni, &ib, &a[i__ * a_dim1 + 1], lda, + &work[iwt], &c__65, &c__[c_offset], ldc, &work[1], &ldwork, (ftnlen)1, + (ftnlen)1, (ftnlen)8, (ftnlen)10); + } + } + work[1] = (doublereal)lwkopt; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dormql.f b/lib/linalg/dormql.f deleted file mode 100644 index 7c9f189e0d..0000000000 --- a/lib/linalg/dormql.f +++ /dev/null @@ -1,336 +0,0 @@ -*> \brief \b DORMQL -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORMQL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, -* WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER SIDE, TRANS -* INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DORMQL overwrites the general real M-by-N matrix C with -*> -*> SIDE = 'L' SIDE = 'R' -*> TRANS = 'N': Q * C C * Q -*> TRANS = 'T': Q**T * C C * Q**T -*> -*> where Q is a real orthogonal matrix defined as the product of k -*> elementary reflectors -*> -*> Q = H(k) . . . H(2) H(1) -*> -*> as returned by DGEQLF. Q is of order M if SIDE = 'L' and of order N -*> if SIDE = 'R'. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': apply Q or Q**T from the Left; -*> = 'R': apply Q or Q**T from the Right. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> = 'N': No transpose, apply Q; -*> = 'T': Transpose, apply Q**T. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines -*> the matrix Q. -*> If SIDE = 'L', M >= K >= 0; -*> if SIDE = 'R', N >= K >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,K) -*> The i-th column must contain the vector which defines the -*> elementary reflector H(i), for i = 1,2,...,k, as returned by -*> DGEQLF in the last k columns of its array argument A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. -*> If SIDE = 'L', LDA >= max(1,M); -*> if SIDE = 'R', LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by DGEQLF. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension (LDC,N) -*> On entry, the M-by-N matrix C. -*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. -*> If SIDE = 'L', LWORK >= max(1,N); -*> if SIDE = 'R', LWORK >= max(1,M). -*> For good performance, LWORK should generally be larger. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal size of the WORK array, returns -*> this value as the first entry of the WORK array, and no error -*> message related to LWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - INTEGER NBMAX, LDT, TSIZE - PARAMETER ( NBMAX = 64, LDT = NBMAX+1, - $ TSIZE = LDT*NBMAX ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, LQUERY, NOTRAN - INTEGER I, I1, I2, I3, IB, IINFO, IWT, LDWORK, LWKOPT, - $ MI, NB, NBMIN, NI, NQ, NW -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DLARFB, DLARFT, DORM2L, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) - LQUERY = ( LWORK.EQ.-1 ) -* -* NQ is the order of Q and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = MAX( 1, N ) - ELSE - NQ = N - NW = MAX( 1, M ) - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF -* - IF( INFO.EQ.0 ) THEN -* -* Compute the workspace requirements -* - IF( M.EQ.0 .OR. N.EQ.0 ) THEN - LWKOPT = 1 - ELSE - NB = MIN( NBMAX, ILAENV( 1, 'DORMQL', SIDE // TRANS, M, N, - $ K, -1 ) ) - LWKOPT = NW*NB + TSIZE - END IF - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORMQL', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) THEN - RETURN - END IF -* - NBMIN = 2 - LDWORK = NW - IF( NB.GT.1 .AND. NB.LT.K ) THEN - IF( LWORK.LT.LWKOPT ) THEN - NB = (LWORK-TSIZE) / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORMQL', SIDE // TRANS, M, N, K, - $ -1 ) ) - END IF - END IF -* - IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN -* -* Use unblocked code -* - CALL DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, - $ IINFO ) - ELSE -* -* Use blocked code -* - IWT = 1 + NW*NB - IF( ( LEFT .AND. NOTRAN ) .OR. - $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN - I1 = 1 - I2 = K - I3 = NB - ELSE - I1 = ( ( K-1 ) / NB )*NB + 1 - I2 = 1 - I3 = -NB - END IF -* - IF( LEFT ) THEN - NI = N - ELSE - MI = M - END IF -* - DO 10 I = I1, I2, I3 - IB = MIN( NB, K-I+1 ) -* -* Form the triangular factor of the block reflector -* H = H(i+ib-1) . . . H(i+1) H(i) -* - CALL DLARFT( 'Backward', 'Columnwise', NQ-K+I+IB-1, IB, - $ A( 1, I ), LDA, TAU( I ), WORK( IWT ), LDT ) - IF( LEFT ) THEN -* -* H or H**T is applied to C(1:m-k+i+ib-1,1:n) -* - MI = M - K + I + IB - 1 - ELSE -* -* H or H**T is applied to C(1:m,1:n-k+i+ib-1) -* - NI = N - K + I + IB - 1 - END IF -* -* Apply H or H**T -* - CALL DLARFB( SIDE, TRANS, 'Backward', 'Columnwise', MI, NI, - $ IB, A( 1, I ), LDA, WORK( IWT ), LDT, C, LDC, - $ WORK, LDWORK ) - 10 CONTINUE - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of DORMQL -* - END diff --git a/lib/linalg/dormqr.cpp b/lib/linalg/dormqr.cpp new file mode 100644 index 0000000000..25d0c11f60 --- /dev/null +++ b/lib/linalg/dormqr.cpp @@ -0,0 +1,149 @@ +#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 integer c__65 = 65; +int dormqr_(char *side, char *trans, integer *m, integer *n, integer *k, 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, i__2, i__3[2], i__4, i__5; + char ch__1[2]; + int s_lmp_cat(char *, char **, integer *, integer *, ftnlen); + integer i__, i1, i2, i3, ib, ic, jc, nb, mi, ni, nq, nw, iwt; + logical left; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + integer nbmin, iinfo; + extern int dorm2r_(char *, char *, integer *, integer *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, ftnlen, + ftnlen), + dlarfb_(char *, char *, char *, char *, integer *, integer *, integer *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, ftnlen, ftnlen, ftnlen, ftnlen), + dlarft_(char *, char *, integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *, ftnlen, ftnlen), + xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, + ftnlen, ftnlen); + logical notran; + integer ldwork, 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; + left = lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1); + notran = lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1); + lquery = *lwork == -1; + if (left) { + nq = *m; + nw = max(1, *n); + } else { + nq = *n; + nw = max(1, *m); + } + if (!left && !lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { + *info = -1; + } else if (!notran && !lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0 || *k > nq) { + *info = -5; + } else if (*lda < max(1, nq)) { + *info = -7; + } else if (*ldc < max(1, *m)) { + *info = -10; + } else if (*lwork < nw && !lquery) { + *info = -12; + } + if (*info == 0) { + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_lmp_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = 64, i__2 = ilaenv_(&c__1, (char *)"DORMQR", ch__1, m, n, k, &c_n1, (ftnlen)6, (ftnlen)2); + nb = min(i__1, i__2); + lwkopt = nw * nb + 4160; + work[1] = (doublereal)lwkopt; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DORMQR", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + if (*m == 0 || *n == 0 || *k == 0) { + work[1] = 1.; + return 0; + } + nbmin = 2; + ldwork = nw; + if (nb > 1 && nb < *k) { + if (*lwork < lwkopt) { + nb = (*lwork - 4160) / ldwork; + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_lmp_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"DORMQR", ch__1, m, n, k, &c_n1, (ftnlen)6, (ftnlen)2); + nbmin = max(i__1, i__2); + } + } + if (nb < nbmin || nb >= *k) { + dorm2r_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[c_offset], ldc, &work[1], + &iinfo, (ftnlen)1, (ftnlen)1); + } else { + iwt = nw * nb + 1; + if (left && !notran || !left && notran) { + i1 = 1; + i2 = *k; + i3 = nb; + } else { + i1 = (*k - 1) / nb * nb + 1; + i2 = 1; + i3 = -nb; + } + if (left) { + ni = *n; + jc = 1; + } else { + mi = *m; + ic = 1; + } + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + i__4 = nb, i__5 = *k - i__ + 1; + ib = min(i__4, i__5); + i__4 = nq - i__ + 1; + dlarft_((char *)"Forward", (char *)"Columnwise", &i__4, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], + &work[iwt], &c__65, (ftnlen)7, (ftnlen)10); + if (left) { + mi = *m - i__ + 1; + ic = i__; + } else { + ni = *n - i__ + 1; + jc = i__; + } + dlarfb_(side, trans, (char *)"Forward", (char *)"Columnwise", &mi, &ni, &ib, &a[i__ + i__ * a_dim1], + lda, &work[iwt], &c__65, &c__[ic + jc * c_dim1], ldc, &work[1], &ldwork, + (ftnlen)1, (ftnlen)1, (ftnlen)7, (ftnlen)10); + } + } + work[1] = (doublereal)lwkopt; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dormqr.f b/lib/linalg/dormqr.f deleted file mode 100644 index 4d0bae3a5f..0000000000 --- a/lib/linalg/dormqr.f +++ /dev/null @@ -1,337 +0,0 @@ -*> \brief \b DORMQR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORMQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, -* WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER SIDE, TRANS -* INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DORMQR overwrites the general real M-by-N matrix C with -*> -*> SIDE = 'L' SIDE = 'R' -*> TRANS = 'N': Q * C C * Q -*> TRANS = 'T': Q**T * C C * Q**T -*> -*> where Q is a real orthogonal matrix defined as the product of k -*> elementary reflectors -*> -*> Q = H(1) H(2) . . . H(k) -*> -*> as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N -*> if SIDE = 'R'. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': apply Q or Q**T from the Left; -*> = 'R': apply Q or Q**T from the Right. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> = 'N': No transpose, apply Q; -*> = 'T': Transpose, apply Q**T. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines -*> the matrix Q. -*> If SIDE = 'L', M >= K >= 0; -*> if SIDE = 'R', N >= K >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,K) -*> The i-th column must contain the vector which defines the -*> elementary reflector H(i), for i = 1,2,...,k, as returned by -*> DGEQRF in the first k columns of its array argument A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. -*> If SIDE = 'L', LDA >= max(1,M); -*> if SIDE = 'R', LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by DGEQRF. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension (LDC,N) -*> On entry, the M-by-N matrix C. -*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. -*> If SIDE = 'L', LWORK >= max(1,N); -*> if SIDE = 'R', LWORK >= max(1,M). -*> For good performance, LWORK should generally be larger. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal size of the WORK array, returns -*> this value as the first entry of the WORK array, and no error -*> message related to LWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - INTEGER NBMAX, LDT, TSIZE - PARAMETER ( NBMAX = 64, LDT = NBMAX+1, - $ TSIZE = LDT*NBMAX ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, LQUERY, NOTRAN - INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK, - $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DLARFB, DLARFT, DORM2R, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) - LQUERY = ( LWORK.EQ.-1 ) -* -* NQ is the order of Q and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = MAX( 1, N ) - ELSE - NQ = N - NW = MAX( 1, M ) - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF -* - IF( INFO.EQ.0 ) THEN -* -* Compute the workspace requirements -* - NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K, - $ -1 ) ) - LWKOPT = NW*NB + TSIZE - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORMQR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - LDWORK = NW - IF( NB.GT.1 .AND. NB.LT.K ) THEN - IF( LWORK.LT.LWKOPT ) THEN - NB = (LWORK-TSIZE) / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', SIDE // TRANS, M, N, K, - $ -1 ) ) - END IF - END IF -* - IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN -* -* Use unblocked code -* - CALL DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, - $ IINFO ) - ELSE -* -* Use blocked code -* - IWT = 1 + NW*NB - IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. - $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN - I1 = 1 - I2 = K - I3 = NB - ELSE - I1 = ( ( K-1 ) / NB )*NB + 1 - I2 = 1 - I3 = -NB - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - DO 10 I = I1, I2, I3 - IB = MIN( NB, K-I+1 ) -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), - $ LDA, TAU( I ), WORK( IWT ), LDT ) - IF( LEFT ) THEN -* -* H or H**T is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H or H**T is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H or H**T -* - CALL DLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, - $ IB, A( I, I ), LDA, WORK( IWT ), LDT, - $ C( IC, JC ), LDC, WORK, LDWORK ) - 10 CONTINUE - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of DORMQR -* - END diff --git a/lib/linalg/dormtr.cpp b/lib/linalg/dormtr.cpp new file mode 100644 index 0000000000..9fc489ef42 --- /dev/null +++ b/lib/linalg/dormtr.cpp @@ -0,0 +1,145 @@ +#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 dormtr_(char *side, char *uplo, char *trans, integer *m, integer *n, doublereal *a, + integer *lda, doublereal *tau, doublereal *c__, integer *ldc, doublereal *work, + integer *lwork, integer *info, ftnlen side_len, ftnlen uplo_len, ftnlen trans_len) +{ + address a__1[2]; + integer a_dim1, a_offset, c_dim1, c_offset, i__1[2], i__2, i__3; + char ch__1[2]; + int s_lmp_cat(char *, char **, integer *, integer *, ftnlen); + integer i1, i2, nb, mi, ni, nq, nw; + logical left; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + integer iinfo; + logical upper; + extern int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, + ftnlen, ftnlen); + extern int dormql_(char *, char *, integer *, integer *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, integer *, + ftnlen, ftnlen), + 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; + left = lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1); + upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); + lquery = *lwork == -1; + if (left) { + nq = *m; + nw = max(1, *n); + } else { + nq = *n; + nw = max(1, *m); + } + if (!left && !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 (!lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1) && + !lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1)) { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*lda < max(1, nq)) { + *info = -7; + } else if (*ldc < max(1, *m)) { + *info = -10; + } else if (*lwork < nw && !lquery) { + *info = -12; + } + if (*info == 0) { + if (upper) { + 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); + i__2 = *m - 1; + i__3 = *m - 1; + nb = ilaenv_(&c__1, (char *)"DORMQL", ch__1, &i__2, n, &i__3, &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); + i__2 = *n - 1; + i__3 = *n - 1; + nb = ilaenv_(&c__1, (char *)"DORMQL", ch__1, m, &i__2, &i__3, &c_n1, (ftnlen)6, (ftnlen)2); + } + } else { + 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); + i__2 = *m - 1; + i__3 = *m - 1; + nb = ilaenv_(&c__1, (char *)"DORMQR", ch__1, &i__2, n, &i__3, &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); + i__2 = *n - 1; + i__3 = *n - 1; + nb = ilaenv_(&c__1, (char *)"DORMQR", ch__1, m, &i__2, &i__3, &c_n1, (ftnlen)6, (ftnlen)2); + } + } + lwkopt = nw * nb; + work[1] = (doublereal)lwkopt; + } + if (*info != 0) { + i__2 = -(*info); + xerbla_((char *)"DORMTR", &i__2, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + if (*m == 0 || *n == 0 || nq == 1) { + work[1] = 1.; + return 0; + } + if (left) { + mi = *m - 1; + ni = *n; + } else { + mi = *m; + ni = *n - 1; + } + if (upper) { + i__2 = nq - 1; + dormql_(side, trans, &mi, &ni, &i__2, &a[(a_dim1 << 1) + 1], lda, &tau[1], &c__[c_offset], + ldc, &work[1], lwork, &iinfo, (ftnlen)1, (ftnlen)1); + } else { + if (left) { + i1 = 2; + i2 = 1; + } else { + i1 = 1; + i2 = 2; + } + i__2 = nq - 1; + dormqr_(side, trans, &mi, &ni, &i__2, &a[a_dim1 + 2], lda, &tau[1], &c__[i1 + i2 * c_dim1], + ldc, &work[1], lwork, &iinfo, (ftnlen)1, (ftnlen)1); + } + work[1] = (doublereal)lwkopt; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dormtr.f b/lib/linalg/dormtr.f deleted file mode 100644 index 1f664d63cc..0000000000 --- a/lib/linalg/dormtr.f +++ /dev/null @@ -1,307 +0,0 @@ -*> \brief \b DORMTR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DORMTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, -* WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER SIDE, TRANS, UPLO -* INTEGER INFO, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DORMTR overwrites the general real M-by-N matrix C with -*> -*> SIDE = 'L' SIDE = 'R' -*> TRANS = 'N': Q * C C * Q -*> TRANS = 'T': Q**T * C C * Q**T -*> -*> where Q is a real orthogonal matrix of order nq, with nq = m if -*> SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of -*> nq-1 elementary reflectors, as returned by DSYTRD: -*> -*> if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); -*> -*> if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': apply Q or Q**T from the Left; -*> = 'R': apply Q or Q**T from the Right. -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A contains elementary reflectors -*> from DSYTRD; -*> = 'L': Lower triangle of A contains elementary reflectors -*> from DSYTRD. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> = 'N': No transpose, apply Q; -*> = 'T': Transpose, apply Q**T. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. N >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension -*> (LDA,M) if SIDE = 'L' -*> (LDA,N) if SIDE = 'R' -*> The vectors which define the elementary reflectors, as -*> returned by DSYTRD. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. -*> LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension -*> (M-1) if SIDE = 'L' -*> (N-1) if SIDE = 'R' -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by DSYTRD. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension (LDC,N) -*> On entry, the M-by-N matrix C. -*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. -*> If SIDE = 'L', LWORK >= max(1,N); -*> if SIDE = 'R', LWORK >= max(1,M). -*> For optimum performance LWORK >= N*NB if SIDE = 'L', and -*> LWORK >= M*NB if SIDE = 'R', where NB is the optimal -*> blocksize. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal size of the WORK array, returns -*> this value as the first entry of the WORK array, and no error -*> message related to LWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, - $ WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS, UPLO - INTEGER INFO, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL LEFT, LQUERY, UPPER - INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DORMQL, DORMQR, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - UPPER = LSAME( UPLO, 'U' ) - LQUERY = ( LWORK.EQ.-1 ) -* -* NQ is the order of Q and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = MAX( 1, N ) - ELSE - NQ = N - NW = MAX( 1, M ) - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -2 - ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) ) - $ THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF -* - IF( INFO.EQ.0 ) THEN - IF( UPPER ) THEN - IF( LEFT ) THEN - NB = ILAENV( 1, 'DORMQL', SIDE // TRANS, M-1, N, M-1, - $ -1 ) - ELSE - NB = ILAENV( 1, 'DORMQL', SIDE // TRANS, M, N-1, N-1, - $ -1 ) - END IF - ELSE - IF( LEFT ) THEN - NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M-1, N, M-1, - $ -1 ) - ELSE - NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N-1, N-1, - $ -1 ) - END IF - END IF - LWKOPT = NW*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORMTR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. NQ.EQ.1 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - IF( LEFT ) THEN - MI = M - 1 - NI = N - ELSE - MI = M - NI = N - 1 - END IF -* - IF( UPPER ) THEN -* -* Q was determined by a call to DSYTRD with UPLO = 'U' -* - CALL DORMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU, C, - $ LDC, WORK, LWORK, IINFO ) - ELSE -* -* Q was determined by a call to DSYTRD with UPLO = 'L' -* - IF( LEFT ) THEN - I1 = 2 - I2 = 1 - ELSE - I1 = 1 - I2 = 2 - END IF - CALL DORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, - $ C( I1, I2 ), LDC, WORK, LWORK, IINFO ) - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of DORMTR -* - END diff --git a/lib/linalg/dposv.cpp b/lib/linalg/dposv.cpp new file mode 100644 index 0000000000..c61c591e0a --- /dev/null +++ b/lib/linalg/dposv.cpp @@ -0,0 +1,45 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dposv_(char *uplo, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *b, + integer *ldb, 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), + dpotrf_(char *, integer *, doublereal *, integer *, integer *, ftnlen), + dpotrs_(char *, integer *, integer *, doublereal *, integer *, doublereal *, 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; + *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 (*nrhs < 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 *)"DPOSV ", &i__1, (ftnlen)6); + return 0; + } + dpotrf_(uplo, n, &a[a_offset], lda, info, (ftnlen)1); + if (*info == 0) { + dpotrs_(uplo, n, nrhs, &a[a_offset], lda, &b[b_offset], ldb, info, (ftnlen)1); + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dposv.f b/lib/linalg/dposv.f deleted file mode 100644 index ee2988e6fd..0000000000 --- a/lib/linalg/dposv.f +++ /dev/null @@ -1,190 +0,0 @@ -*> \brief DPOSV computes the solution to system of linear equations A * X = B for PO matrices -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DPOSV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DPOSV computes the solution to a real system of linear equations -*> A * X = B, -*> where A is an N-by-N symmetric positive definite matrix and X and B -*> are N-by-NRHS matrices. -*> -*> The Cholesky decomposition is used to factor A as -*> A = U**T* U, if UPLO = 'U', or -*> A = L * L**T, if UPLO = 'L', -*> where U is an upper triangular matrix and L is a lower triangular -*> matrix. The factored form of A is then used to solve the system of -*> equations A * X = B. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A is stored; -*> = 'L': Lower triangle of A is stored. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of linear equations, i.e., the order of the -*> matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in] NRHS -*> \verbatim -*> NRHS is INTEGER -*> The number of right hand sides, i.e., the number of columns -*> of the matrix B. NRHS >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the symmetric matrix A. If UPLO = 'U', the leading -*> N-by-N upper triangular part of A contains the upper -*> triangular part of the matrix A, and the strictly lower -*> triangular part of A is not referenced. If UPLO = 'L', the -*> leading N-by-N lower triangular part of A contains the lower -*> triangular part of the matrix A, and the strictly upper -*> triangular part of A is not referenced. -*> -*> On exit, if INFO = 0, the factor U or L from the Cholesky -*> factorization A = U**T*U or A = L*L**T. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) -*> On entry, the N-by-NRHS right hand side matrix B. -*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >= max(1,N). -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> > 0: if INFO = i, the leading minor of order i of A is not -*> positive definite, so the factorization could not be -*> completed, and the solution has not been computed. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doublePOsolve -* -* ===================================================================== - SUBROUTINE DPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) -* -* -- LAPACK driver routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DPOTRF, DPOTRS, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DPOSV ', -INFO ) - RETURN - END IF -* -* Compute the Cholesky factorization A = U**T*U or A = L*L**T. -* - CALL DPOTRF( UPLO, N, A, LDA, INFO ) - IF( INFO.EQ.0 ) THEN -* -* Solve the system A*X = B, overwriting B with X. -* - CALL DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) -* - END IF - RETURN -* -* End of DPOSV -* - END diff --git a/lib/linalg/dpotf2.cpp b/lib/linalg/dpotf2.cpp new file mode 100644 index 0000000000..4a2e84af28 --- /dev/null +++ b/lib/linalg/dpotf2.cpp @@ -0,0 +1,95 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +static doublereal c_b10 = -1.; +static doublereal c_b12 = 1.; +int dpotf2_(char *uplo, integer *n, doublereal *a, integer *lda, integer *info, ftnlen uplo_len) +{ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublereal d__1; + double sqrt(doublereal); + integer j; + doublereal ajj; + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *); + extern int dscal_(integer *, doublereal *, doublereal *, integer *); + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern int dgemv_(char *, integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, ftnlen); + logical upper; + 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 *)"DPOTF2", &i__1, (ftnlen)6); + return 0; + } + if (*n == 0) { + return 0; + } + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + ajj = a[j + j * a_dim1] - + ddot_(&i__2, &a[j * a_dim1 + 1], &c__1, &a[j * a_dim1 + 1], &c__1); + if (ajj <= 0. || disnan_(&ajj)) { + a[j + j * a_dim1] = ajj; + goto L30; + } + ajj = sqrt(ajj); + a[j + j * a_dim1] = ajj; + if (j < *n) { + i__2 = j - 1; + i__3 = *n - j; + dgemv_((char *)"Transpose", &i__2, &i__3, &c_b10, &a[(j + 1) * a_dim1 + 1], lda, + &a[j * a_dim1 + 1], &c__1, &c_b12, &a[j + (j + 1) * a_dim1], lda, (ftnlen)9); + i__2 = *n - j; + d__1 = 1. / ajj; + dscal_(&i__2, &d__1, &a[j + (j + 1) * a_dim1], lda); + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + ajj = a[j + j * a_dim1] - ddot_(&i__2, &a[j + a_dim1], lda, &a[j + a_dim1], lda); + if (ajj <= 0. || disnan_(&ajj)) { + a[j + j * a_dim1] = ajj; + goto L30; + } + ajj = sqrt(ajj); + a[j + j * a_dim1] = ajj; + if (j < *n) { + i__2 = *n - j; + i__3 = j - 1; + dgemv_((char *)"No transpose", &i__2, &i__3, &c_b10, &a[j + 1 + a_dim1], lda, + &a[j + a_dim1], lda, &c_b12, &a[j + 1 + j * a_dim1], &c__1, (ftnlen)12); + i__2 = *n - j; + d__1 = 1. / ajj; + dscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1); + } + } + } + goto L40; +L30: + *info = j; +L40: + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dpotf2.f b/lib/linalg/dpotf2.f deleted file mode 100644 index 08fa4957fd..0000000000 --- a/lib/linalg/dpotf2.f +++ /dev/null @@ -1,227 +0,0 @@ -*> \brief \b DPOTF2 computes the Cholesky factorization of a symmetric/Hermitian positive definite matrix (unblocked algorithm). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DPOTF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DPOTF2 computes the Cholesky factorization of a real symmetric -*> positive definite matrix A. -*> -*> The factorization has the form -*> A = U**T * U , if UPLO = 'U', or -*> A = L * L**T, if UPLO = 'L', -*> where U is an upper triangular matrix and L is lower triangular. -*> -*> This is the unblocked version of the algorithm, calling Level 2 BLAS. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> Specifies whether the upper or lower triangular part of the -*> symmetric matrix A is stored. -*> = 'U': Upper triangular -*> = 'L': Lower triangular -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the symmetric matrix A. If UPLO = 'U', the leading -*> n by n upper triangular part of A contains the upper -*> triangular part of the matrix A, and the strictly lower -*> triangular part of A is not referenced. If UPLO = 'L', the -*> leading n by n lower triangular part of A contains the lower -*> triangular part of the matrix A, and the strictly upper -*> triangular part of A is not referenced. -*> -*> On exit, if INFO = 0, the factor U or L from the Cholesky -*> factorization A = U**T *U or A = L*L**T. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -k, the k-th argument had an illegal value -*> > 0: if INFO = k, the leading minor of order k is not -*> positive definite, and the factorization could not be -*> completed. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doublePOcomputational -* -* ===================================================================== - SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER J - DOUBLE PRECISION AJJ -* .. -* .. External Functions .. - LOGICAL LSAME, DISNAN - DOUBLE PRECISION DDOT - EXTERNAL LSAME, DDOT, DISNAN -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DPOTF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Compute the Cholesky factorization A = U**T *U. -* - DO 10 J = 1, N -* -* Compute U(J,J) and test for non-positive-definiteness. -* - AJJ = A( J, J ) - DDOT( J-1, A( 1, J ), 1, A( 1, J ), 1 ) - IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) THEN - A( J, J ) = AJJ - GO TO 30 - END IF - AJJ = SQRT( AJJ ) - A( J, J ) = AJJ -* -* Compute elements J+1:N of row J. -* - IF( J.LT.N ) THEN - CALL DGEMV( 'Transpose', J-1, N-J, -ONE, A( 1, J+1 ), - $ LDA, A( 1, J ), 1, ONE, A( J, J+1 ), LDA ) - CALL DSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA ) - END IF - 10 CONTINUE - ELSE -* -* Compute the Cholesky factorization A = L*L**T. -* - DO 20 J = 1, N -* -* Compute L(J,J) and test for non-positive-definiteness. -* - AJJ = A( J, J ) - DDOT( J-1, A( J, 1 ), LDA, A( J, 1 ), - $ LDA ) - IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) THEN - A( J, J ) = AJJ - GO TO 30 - END IF - AJJ = SQRT( AJJ ) - A( J, J ) = AJJ -* -* Compute elements J+1:N of column J. -* - IF( J.LT.N ) THEN - CALL DGEMV( 'No transpose', N-J, J-1, -ONE, A( J+1, 1 ), - $ LDA, A( J, 1 ), LDA, ONE, A( J+1, J ), 1 ) - CALL DSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 ) - END IF - 20 CONTINUE - END IF - GO TO 40 -* - 30 CONTINUE - INFO = J -* - 40 CONTINUE - RETURN -* -* End of DPOTF2 -* - END diff --git a/lib/linalg/dpotrf.cpp b/lib/linalg/dpotrf.cpp new file mode 100644 index 0000000000..63caf94920 --- /dev/null +++ b/lib/linalg/dpotrf.cpp @@ -0,0 +1,111 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +static integer c_n1 = -1; +static doublereal c_b13 = -1.; +static doublereal c_b14 = 1.; +int dpotrf_(char *uplo, integer *n, doublereal *a, integer *lda, integer *info, ftnlen uplo_len) +{ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + integer j, jb, nb; + 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 dtrsm_(char *, char *, char *, char *, integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, + ftnlen); + logical upper; + extern int dsyrk_(char *, char *, integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, doublereal *, integer *, ftnlen, ftnlen), + xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, + ftnlen, ftnlen); + extern int dpotrf2_(char *, integer *, doublereal *, 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 *)"DPOTRF", &i__1, (ftnlen)6); + return 0; + } + if (*n == 0) { + return 0; + } + nb = ilaenv_(&c__1, (char *)"DPOTRF", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); + if (nb <= 1 || nb >= *n) { + dpotrf2_(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; + dsyrk_((char *)"Upper", (char *)"Transpose", &jb, &i__3, &c_b13, &a[j * a_dim1 + 1], lda, &c_b14, + &a[j + j * a_dim1], lda, (ftnlen)5, (ftnlen)9); + dpotrf2_((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; + dgemm_((char *)"Transpose", (char *)"No transpose", &jb, &i__3, &i__4, &c_b13, + &a[j * a_dim1 + 1], lda, &a[(j + jb) * a_dim1 + 1], lda, &c_b14, + &a[j + (j + jb) * a_dim1], lda, (ftnlen)9, (ftnlen)12); + i__3 = *n - j - jb + 1; + dtrsm_((char *)"Left", (char *)"Upper", (char *)"Transpose", (char *)"Non-unit", &jb, &i__3, &c_b14, + &a[j + j * a_dim1], lda, &a[j + (j + jb) * a_dim1], lda, (ftnlen)4, + (ftnlen)5, (ftnlen)9, (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; + dsyrk_((char *)"Lower", (char *)"No transpose", &jb, &i__3, &c_b13, &a[j + a_dim1], lda, &c_b14, + &a[j + j * a_dim1], lda, (ftnlen)5, (ftnlen)12); + dpotrf2_((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; + dgemm_((char *)"No transpose", (char *)"Transpose", &i__3, &jb, &i__4, &c_b13, + &a[j + jb + a_dim1], lda, &a[j + a_dim1], lda, &c_b14, + &a[j + jb + j * a_dim1], lda, (ftnlen)12, (ftnlen)9); + i__3 = *n - j - jb + 1; + dtrsm_((char *)"Right", (char *)"Lower", (char *)"Transpose", (char *)"Non-unit", &i__3, &jb, &c_b14, + &a[j + j * a_dim1], lda, &a[j + jb + j * a_dim1], lda, (ftnlen)5, + (ftnlen)5, (ftnlen)9, (ftnlen)8); + } + } + } + } + goto L40; +L30: + *info = *info + j - 1; +L40: + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dpotrf.f b/lib/linalg/dpotrf.f deleted file mode 100644 index 1679fc3cd8..0000000000 --- a/lib/linalg/dpotrf.f +++ /dev/null @@ -1,243 +0,0 @@ -*> \brief \b DPOTRF -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DPOTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DPOTRF computes the Cholesky factorization of a real symmetric -*> positive definite matrix A. -*> -*> The factorization has the form -*> A = U**T * U, if UPLO = 'U', or -*> A = L * L**T, if UPLO = 'L', -*> where U is an upper triangular matrix and L is lower triangular. -*> -*> This is the block version of the algorithm, calling Level 3 BLAS. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A is stored; -*> = 'L': Lower triangle of A is stored. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the symmetric matrix A. If UPLO = 'U', the leading -*> N-by-N upper triangular part of A contains the upper -*> triangular part of the matrix A, and the strictly lower -*> triangular part of A is not referenced. If UPLO = 'L', the -*> leading N-by-N lower triangular part of A contains the lower -*> triangular part of the matrix A, and the strictly upper -*> triangular part of A is not referenced. -*> -*> On exit, if INFO = 0, the factor U or L from the Cholesky -*> factorization A = U**T*U or A = L*L**T. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> > 0: if INFO = i, the leading minor of order i is not -*> positive definite, and the factorization could not be -*> completed. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doublePOcomputational -* -* ===================================================================== - SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER J, JB, NB -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DPOTRF2, DSYRK, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DPOTRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'DPOTRF', UPLO, N, -1, -1, -1 ) - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code. -* - CALL DPOTRF2( UPLO, N, A, LDA, INFO ) - ELSE -* -* Use blocked code. -* - IF( UPPER ) THEN -* -* Compute the Cholesky factorization A = U**T*U. -* - DO 10 J = 1, N, NB -* -* Update and factorize the current diagonal block and test -* for non-positive-definiteness. -* - JB = MIN( NB, N-J+1 ) - CALL DSYRK( 'Upper', 'Transpose', JB, J-1, -ONE, - $ A( 1, J ), LDA, ONE, A( J, J ), LDA ) - CALL DPOTRF2( 'Upper', JB, A( J, J ), LDA, INFO ) - IF( INFO.NE.0 ) - $ GO TO 30 - IF( J+JB.LE.N ) THEN -* -* Compute the current block row. -* - CALL DGEMM( 'Transpose', 'No transpose', JB, N-J-JB+1, - $ J-1, -ONE, A( 1, J ), LDA, A( 1, J+JB ), - $ LDA, ONE, A( J, J+JB ), LDA ) - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', - $ JB, N-J-JB+1, ONE, A( J, J ), LDA, - $ A( J, J+JB ), LDA ) - END IF - 10 CONTINUE -* - ELSE -* -* Compute the Cholesky factorization A = L*L**T. -* - DO 20 J = 1, N, NB -* -* Update and factorize the current diagonal block and test -* for non-positive-definiteness. -* - JB = MIN( NB, N-J+1 ) - CALL DSYRK( 'Lower', 'No transpose', JB, J-1, -ONE, - $ A( J, 1 ), LDA, ONE, A( J, J ), LDA ) - CALL DPOTRF2( 'Lower', JB, A( J, J ), LDA, INFO ) - IF( INFO.NE.0 ) - $ GO TO 30 - IF( J+JB.LE.N ) THEN -* -* Compute the current block column. -* - CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, - $ J-1, -ONE, A( J+JB, 1 ), LDA, A( J, 1 ), - $ LDA, ONE, A( J+JB, J ), LDA ) - CALL DTRSM( 'Right', 'Lower', 'Transpose', 'Non-unit', - $ N-J-JB+1, JB, ONE, A( J, J ), LDA, - $ A( J+JB, J ), LDA ) - END IF - 20 CONTINUE - END IF - END IF - GO TO 40 -* - 30 CONTINUE - INFO = INFO + J - 1 -* - 40 CONTINUE - RETURN -* -* End of DPOTRF -* - END diff --git a/lib/linalg/dpotrf2.cpp b/lib/linalg/dpotrf2.cpp new file mode 100644 index 0000000000..af2e45eb36 --- /dev/null +++ b/lib/linalg/dpotrf2.cpp @@ -0,0 +1,82 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static doublereal c_b9 = 1.; +static doublereal c_b11 = -1.; +int dpotrf2_(char *uplo, integer *n, doublereal *a, integer *lda, integer *info, ftnlen uplo_len) +{ + integer a_dim1, a_offset, i__1; + double sqrt(doublereal); + integer n1, n2; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + integer iinfo; + extern int dtrsm_(char *, char *, char *, char *, integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, + ftnlen); + logical upper; + extern int dsyrk_(char *, char *, integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, doublereal *, integer *, 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 *)"DPOTRF2", &i__1, (ftnlen)7); + return 0; + } + if (*n == 0) { + return 0; + } + if (*n == 1) { + if (a[a_dim1 + 1] <= 0. || disnan_(&a[a_dim1 + 1])) { + *info = 1; + return 0; + } + a[a_dim1 + 1] = sqrt(a[a_dim1 + 1]); + } else { + n1 = *n / 2; + n2 = *n - n1; + dpotrf2_(uplo, &n1, &a[a_dim1 + 1], lda, &iinfo, (ftnlen)1); + if (iinfo != 0) { + *info = iinfo; + return 0; + } + if (upper) { + dtrsm_((char *)"L", (char *)"U", (char *)"T", (char *)"N", &n1, &n2, &c_b9, &a[a_dim1 + 1], lda, + &a[(n1 + 1) * a_dim1 + 1], lda, (ftnlen)1, (ftnlen)1, (ftnlen)1, (ftnlen)1); + dsyrk_(uplo, (char *)"T", &n2, &n1, &c_b11, &a[(n1 + 1) * a_dim1 + 1], lda, &c_b9, + &a[n1 + 1 + (n1 + 1) * a_dim1], lda, (ftnlen)1, (ftnlen)1); + dpotrf2_(uplo, &n2, &a[n1 + 1 + (n1 + 1) * a_dim1], lda, &iinfo, (ftnlen)1); + if (iinfo != 0) { + *info = iinfo + n1; + return 0; + } + } else { + dtrsm_((char *)"R", (char *)"L", (char *)"T", (char *)"N", &n2, &n1, &c_b9, &a[a_dim1 + 1], lda, &a[n1 + 1 + a_dim1], + lda, (ftnlen)1, (ftnlen)1, (ftnlen)1, (ftnlen)1); + dsyrk_(uplo, (char *)"N", &n2, &n1, &c_b11, &a[n1 + 1 + a_dim1], lda, &c_b9, + &a[n1 + 1 + (n1 + 1) * a_dim1], lda, (ftnlen)1, (ftnlen)1); + dpotrf2_(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 diff --git a/lib/linalg/dpotrf2.f b/lib/linalg/dpotrf2.f deleted file mode 100644 index 6c28ce6d67..0000000000 --- a/lib/linalg/dpotrf2.f +++ /dev/null @@ -1,234 +0,0 @@ -*> \brief \b DPOTRF2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* RECURSIVE SUBROUTINE DPOTRF2( UPLO, N, A, LDA, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. -* REAL A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DPOTRF2 computes the Cholesky factorization of a real symmetric -*> positive definite matrix A using the recursive algorithm. -*> -*> The factorization has the form -*> A = U**T * U, if UPLO = 'U', or -*> A = L * L**T, if UPLO = 'L', -*> where U is an upper triangular matrix and L is lower triangular. -*> -*> This is the recursive version of the algorithm. It divides -*> the matrix into four submatrices: -*> -*> [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2 -*> A = [ -----|----- ] with n1 = n/2 -*> [ A21 | A22 ] n2 = n-n1 -*> -*> The subroutine calls itself to factor A11. Update and scale A21 -*> or A12, update A22 then calls itself to factor A22. -*> -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A is stored; -*> = 'L': Lower triangle of A is stored. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the symmetric matrix A. If UPLO = 'U', the leading -*> N-by-N upper triangular part of A contains the upper -*> triangular part of the matrix A, and the strictly lower -*> triangular part of A is not referenced. If UPLO = 'L', the -*> leading N-by-N lower triangular part of A contains the lower -*> triangular part of the matrix A, and the strictly upper -*> triangular part of A is not referenced. -*> -*> On exit, if INFO = 0, the factor U or L from the Cholesky -*> factorization A = U**T*U or A = L*L**T. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> > 0: if INFO = i, the leading minor of order i is not -*> positive definite, and the factorization could not be -*> completed. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doublePOcomputational -* -* ===================================================================== - RECURSIVE SUBROUTINE DPOTRF2( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER N1, N2, IINFO -* .. -* .. External Functions .. - LOGICAL LSAME, DISNAN - EXTERNAL LSAME, DISNAN -* .. -* .. External Subroutines .. - EXTERNAL DSYRK, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DPOTRF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* N=1 case -* - IF( N.EQ.1 ) THEN -* -* Test for non-positive-definiteness -* - IF( A( 1, 1 ).LE.ZERO.OR.DISNAN( A( 1, 1 ) ) ) THEN - INFO = 1 - RETURN - END IF -* -* Factor -* - A( 1, 1 ) = SQRT( A( 1, 1 ) ) -* -* Use recursive code -* - ELSE - N1 = N/2 - N2 = N-N1 -* -* Factor A11 -* - CALL DPOTRF2( UPLO, N1, A( 1, 1 ), LDA, IINFO ) - IF ( IINFO.NE.0 ) THEN - INFO = IINFO - RETURN - END IF -* -* Compute the Cholesky factorization A = U**T*U -* - IF( UPPER ) THEN -* -* Update and scale A12 -* - CALL DTRSM( 'L', 'U', 'T', 'N', N1, N2, ONE, - $ A( 1, 1 ), LDA, A( 1, N1+1 ), LDA ) -* -* Update and factor A22 -* - CALL DSYRK( UPLO, 'T', N2, N1, -ONE, A( 1, N1+1 ), LDA, - $ ONE, A( N1+1, N1+1 ), LDA ) - CALL DPOTRF2( UPLO, N2, A( N1+1, N1+1 ), LDA, IINFO ) - IF ( IINFO.NE.0 ) THEN - INFO = IINFO + N1 - RETURN - END IF -* -* Compute the Cholesky factorization A = L*L**T -* - ELSE -* -* Update and scale A21 -* - CALL DTRSM( 'R', 'L', 'T', 'N', N2, N1, ONE, - $ A( 1, 1 ), LDA, A( N1+1, 1 ), LDA ) -* -* Update and factor A22 -* - CALL DSYRK( UPLO, 'N', N2, N1, -ONE, A( N1+1, 1 ), LDA, - $ ONE, A( N1+1, N1+1 ), LDA ) - CALL DPOTRF2( UPLO, N2, A( N1+1, N1+1 ), LDA, IINFO ) - IF ( IINFO.NE.0 ) THEN - INFO = IINFO + N1 - RETURN - END IF - END IF - END IF - RETURN -* -* End of DPOTRF2 -* - END diff --git a/lib/linalg/dpotrs.cpp b/lib/linalg/dpotrs.cpp new file mode 100644 index 0000000000..c9ccf42f6d --- /dev/null +++ b/lib/linalg/dpotrs.cpp @@ -0,0 +1,58 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static doublereal c_b9 = 1.; +int dpotrs_(char *uplo, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *b, + integer *ldb, 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 dtrsm_(char *, char *, char *, char *, integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, + ftnlen); + 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; + *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 = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DPOTRS", &i__1, (ftnlen)6); + return 0; + } + if (*n == 0 || *nrhs == 0) { + return 0; + } + if (upper) { + dtrsm_((char *)"Left", (char *)"Upper", (char *)"Transpose", (char *)"Non-unit", n, nrhs, &c_b9, &a[a_offset], lda, + &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, (ftnlen)9, (ftnlen)8); + dtrsm_((char *)"Left", (char *)"Upper", (char *)"No transpose", (char *)"Non-unit", n, nrhs, &c_b9, &a[a_offset], lda, + &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, (ftnlen)12, (ftnlen)8); + } else { + dtrsm_((char *)"Left", (char *)"Lower", (char *)"No transpose", (char *)"Non-unit", n, nrhs, &c_b9, &a[a_offset], lda, + &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, (ftnlen)12, (ftnlen)8); + dtrsm_((char *)"Left", (char *)"Lower", (char *)"Transpose", (char *)"Non-unit", n, nrhs, &c_b9, &a[a_offset], lda, + &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, (ftnlen)9, (ftnlen)8); + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dpotrs.f b/lib/linalg/dpotrs.f deleted file mode 100644 index 862ee078fd..0000000000 --- a/lib/linalg/dpotrs.f +++ /dev/null @@ -1,201 +0,0 @@ -*> \brief \b DPOTRS -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DPOTRS + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DPOTRS solves a system of linear equations A*X = B with a symmetric -*> positive definite matrix A using the Cholesky factorization -*> A = U**T*U or A = L*L**T computed by DPOTRF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A is stored; -*> = 'L': Lower triangle of A is stored. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in] NRHS -*> \verbatim -*> NRHS is INTEGER -*> The number of right hand sides, i.e., the number of columns -*> of the matrix B. NRHS >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> The triangular factor U or L from the Cholesky factorization -*> A = U**T*U or A = L*L**T, as computed by DPOTRF. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) -*> On entry, the right hand side matrix B. -*> On exit, the solution matrix X. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >= max(1,N). -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doublePOcomputational -* -* ===================================================================== - SUBROUTINE DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DPOTRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Solve A*X = B where A = U**T *U. -* -* Solve U**T *X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve U*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, - $ NRHS, ONE, A, LDA, B, LDB ) - ELSE -* -* Solve A*X = B where A = L*L**T. -* -* Solve L*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', N, - $ NRHS, ONE, A, LDA, B, LDB ) -* -* Solve L**T *X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Non-unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) - END IF -* - RETURN -* -* End of DPOTRS -* - END diff --git a/lib/linalg/drot.cpp b/lib/linalg/drot.cpp new file mode 100644 index 0000000000..aabbf00356 --- /dev/null +++ b/lib/linalg/drot.cpp @@ -0,0 +1,45 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int drot_(integer *n, doublereal *dx, integer *incx, doublereal *dy, integer *incy, doublereal *c__, + doublereal *s) +{ + integer i__1; + integer i__, ix, iy; + doublereal dtemp; + --dy; + --dx; + if (*n <= 0) { + return 0; + } + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dtemp = *c__ * dx[i__] + *s * dy[i__]; + dy[i__] = *c__ * dy[i__] - *s * dx[i__]; + dx[i__] = dtemp; + } + } 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__) { + dtemp = *c__ * dx[ix] + *s * dy[iy]; + dy[iy] = *c__ * dy[iy] - *s * dx[ix]; + dx[ix] = dtemp; + ix += *incx; + iy += *incy; + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/drot.f b/lib/linalg/drot.f deleted file mode 100644 index 0386626c8f..0000000000 --- a/lib/linalg/drot.f +++ /dev/null @@ -1,142 +0,0 @@ -*> \brief \b DROT -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DROT(N,DX,INCX,DY,INCY,C,S) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION C,S -* INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION DX(*),DY(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DROT applies a plane rotation. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> number of elements in input vector(s) -*> \endverbatim -*> -*> \param[in,out] DX -*> \verbatim -*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> storage spacing between elements of DX -*> \endverbatim -*> -*> \param[in,out] DY -*> \verbatim -*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> storage spacing between elements of DY -*> \endverbatim -*> -*> \param[in] C -*> \verbatim -*> C is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in] S -*> \verbatim -*> S is DOUBLE PRECISION -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level1 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> jack dongarra, linpack, 3/11/78. -*> modified 12/3/93, array(1) declarations changed to array(*) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DROT(N,DX,INCX,DY,INCY,C,S) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION C,S - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*),DY(*) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - DOUBLE PRECISION DTEMP - INTEGER I,IX,IY -* .. - IF (N.LE.0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 -* - DO I = 1,N - DTEMP = C*DX(I) + S*DY(I) - DY(I) = C*DY(I) - S*DX(I) - DX(I) = DTEMP - END DO - ELSE -* -* code for unequal increments or equal increments not equal -* to 1 -* - IX = 1 - IY = 1 - IF (INCX.LT.0) IX = (-N+1)*INCX + 1 - IF (INCY.LT.0) IY = (-N+1)*INCY + 1 - DO I = 1,N - DTEMP = C*DX(IX) + S*DY(IY) - DY(IY) = C*DY(IY) - S*DX(IX) - DX(IX) = DTEMP - IX = IX + INCX - IY = IY + INCY - END DO - END IF - RETURN -* -* End of DROT -* - END diff --git a/lib/linalg/drscl.cpp b/lib/linalg/drscl.cpp new file mode 100644 index 0000000000..90e278a709 --- /dev/null +++ b/lib/linalg/drscl.cpp @@ -0,0 +1,46 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int drscl_(integer *n, doublereal *sa, doublereal *sx, integer *incx) +{ + doublereal mul, cden; + logical done; + doublereal cnum, cden1, cnum1; + extern int dscal_(integer *, doublereal *, doublereal *, integer *), + dlabad_(doublereal *, doublereal *); + extern doublereal dlamch_(char *, ftnlen); + doublereal bignum, smlnum; + --sx; + if (*n <= 0) { + return 0; + } + smlnum = dlamch_((char *)"S", (ftnlen)1); + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + cden = *sa; + cnum = 1.; +L10: + cden1 = cden * smlnum; + cnum1 = cnum / bignum; + if (abs(cden1) > abs(cnum) && cnum != 0.) { + mul = smlnum; + done = FALSE_; + cden = cden1; + } else if (abs(cnum1) > abs(cden)) { + mul = bignum; + done = FALSE_; + cnum = cnum1; + } else { + mul = cnum / cden; + done = TRUE_; + } + dscal_(n, &mul, &sx[1], incx); + if (!done) { + goto L10; + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/drscl.f b/lib/linalg/drscl.f deleted file mode 100644 index fcd8569650..0000000000 --- a/lib/linalg/drscl.f +++ /dev/null @@ -1,171 +0,0 @@ -*> \brief \b DRSCL multiplies a vector by the reciprocal of a real scalar. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DRSCL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DRSCL( N, SA, SX, INCX ) -* -* .. Scalar Arguments .. -* INTEGER INCX, N -* DOUBLE PRECISION SA -* .. -* .. Array Arguments .. -* DOUBLE PRECISION SX( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DRSCL multiplies an n-element real vector x by the real scalar 1/a. -*> This is done without overflow or underflow as long as -*> the final result x/a does not overflow or underflow. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of components of the vector x. -*> \endverbatim -*> -*> \param[in] SA -*> \verbatim -*> SA is DOUBLE PRECISION -*> The scalar a which is used to divide each component of x. -*> SA must be >= 0, or the subroutine will divide by zero. -*> \endverbatim -*> -*> \param[in,out] SX -*> \verbatim -*> SX is DOUBLE PRECISION array, dimension -*> (1+(N-1)*abs(INCX)) -*> The n-element vector x. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> The increment between successive values of the vector SX. -*> > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERauxiliary -* -* ===================================================================== - SUBROUTINE DRSCL( N, SA, SX, INCX ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX, N - DOUBLE PRECISION SA -* .. -* .. Array Arguments .. - DOUBLE PRECISION SX( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL DONE - DOUBLE PRECISION BIGNUM, CDEN, CDEN1, CNUM, CNUM1, MUL, SMLNUM -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DSCAL, DLABAD -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* -* Get machine parameters -* - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) -* -* Initialize the denominator to SA and the numerator to 1. -* - CDEN = SA - CNUM = ONE -* - 10 CONTINUE - CDEN1 = CDEN*SMLNUM - CNUM1 = CNUM / BIGNUM - IF( ABS( CDEN1 ).GT.ABS( CNUM ) .AND. CNUM.NE.ZERO ) THEN -* -* Pre-multiply X by SMLNUM if CDEN is large compared to CNUM. -* - MUL = SMLNUM - DONE = .FALSE. - CDEN = CDEN1 - ELSE IF( ABS( CNUM1 ).GT.ABS( CDEN ) ) THEN -* -* Pre-multiply X by BIGNUM if CDEN is small compared to CNUM. -* - MUL = BIGNUM - DONE = .FALSE. - CNUM = CNUM1 - ELSE -* -* Multiply X by CNUM / CDEN and return. -* - MUL = CNUM / CDEN - DONE = .TRUE. - END IF -* -* Scale the vector X by MUL -* - CALL DSCAL( N, MUL, SX, INCX ) -* - IF( .NOT.DONE ) - $ GO TO 10 -* - RETURN -* -* End of DRSCL -* - END diff --git a/lib/linalg/dscal.cpp b/lib/linalg/dscal.cpp new file mode 100644 index 0000000000..321aedfd73 --- /dev/null +++ b/lib/linalg/dscal.cpp @@ -0,0 +1,45 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dscal_(integer *n, doublereal *da, doublereal *dx, integer *incx) +{ + integer i__1, i__2; + integer i__, m, mp1, nincx; + --dx; + if (*n <= 0 || *incx <= 0 || *da == 1.) { + return 0; + } + if (*incx == 1) { + m = *n % 5; + if (m != 0) { + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + dx[i__] = *da * dx[i__]; + } + if (*n < 5) { + return 0; + } + } + mp1 = m + 1; + i__1 = *n; + for (i__ = mp1; i__ <= i__1; i__ += 5) { + dx[i__] = *da * dx[i__]; + dx[i__ + 1] = *da * dx[i__ + 1]; + dx[i__ + 2] = *da * dx[i__ + 2]; + dx[i__ + 3] = *da * dx[i__ + 3]; + dx[i__ + 4] = *da * dx[i__ + 4]; + } + } else { + nincx = *n * *incx; + i__1 = nincx; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + dx[i__] = *da * dx[i__]; + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dscal.f b/lib/linalg/dscal.f deleted file mode 100644 index e055d198af..0000000000 --- a/lib/linalg/dscal.f +++ /dev/null @@ -1,139 +0,0 @@ -*> \brief \b DSCAL -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DSCAL(N,DA,DX,INCX) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION DA -* INTEGER INCX,N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION DX(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSCAL scales a vector by a constant. -*> uses unrolled loops for increment equal to 1. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> number of elements in input vector(s) -*> \endverbatim -*> -*> \param[in] DA -*> \verbatim -*> DA is DOUBLE PRECISION -*> On entry, DA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in,out] DX -*> \verbatim -*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> storage spacing between elements of DX -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level1 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> jack dongarra, linpack, 3/11/78. -*> modified 3/93 to return if incx .le. 0. -*> modified 12/3/93, array(1) declarations changed to array(*) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DSCAL(N,DA,DX,INCX) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION DA - INTEGER INCX,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I,M,MP1,NINCX -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER (ONE=1.0D+0) -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - IF (N.LE.0 .OR. INCX.LE.0 .OR. DA.EQ.ONE) RETURN - IF (INCX.EQ.1) THEN -* -* code for increment equal to 1 -* -* -* clean-up loop -* - M = MOD(N,5) - IF (M.NE.0) THEN - DO I = 1,M - DX(I) = DA*DX(I) - END DO - IF (N.LT.5) RETURN - END IF - MP1 = M + 1 - DO I = MP1,N,5 - DX(I) = DA*DX(I) - DX(I+1) = DA*DX(I+1) - DX(I+2) = DA*DX(I+2) - DX(I+3) = DA*DX(I+3) - DX(I+4) = DA*DX(I+4) - END DO - ELSE -* -* code for increment not equal to 1 -* - NINCX = N*INCX - DO I = 1,NINCX,INCX - DX(I) = DA*DX(I) - END DO - END IF - RETURN -* -* End of DSCAL -* - END diff --git a/lib/linalg/dstedc.cpp b/lib/linalg/dstedc.cpp new file mode 100644 index 0000000000..136723dde7 --- /dev/null +++ b/lib/linalg/dstedc.cpp @@ -0,0 +1,238 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__9 = 9; +static integer c__0 = 0; +static integer c__2 = 2; +static doublereal c_b17 = 0.; +static doublereal c_b18 = 1.; +static integer c__1 = 1; +int dstedc_(char *compz, integer *n, doublereal *d__, doublereal *e, doublereal *z__, integer *ldz, + doublereal *work, integer *lwork, integer *iwork, integer *liwork, integer *info, + ftnlen compz_len) +{ + integer z_dim1, z_offset, i__1, i__2; + doublereal d__1, d__2; + double log(doublereal); + integer pow_lmp_ii(integer *, integer *); + double sqrt(doublereal); + integer i__, j, k, m; + doublereal p; + integer ii, lgn; + doublereal eps, tiny; + 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 dswap_(integer *, doublereal *, integer *, doublereal *, integer *); + integer lwmin; + extern int dlaed0_(integer *, integer *, integer *, doublereal *, doublereal *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, integer *); + integer start; + extern doublereal dlamch_(char *, ftnlen); + extern int dlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, + integer *, doublereal *, integer *, integer *, ftnlen), + 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); + integer finish; + extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *, ftnlen); + extern int dsterf_(integer *, doublereal *, doublereal *, integer *), + dlasrt_(char *, integer *, doublereal *, integer *, ftnlen); + integer liwmin, icompz; + extern int dsteqr_(char *, integer *, doublereal *, doublereal *, doublereal *, integer *, + doublereal *, integer *, ftnlen); + doublereal orgnrm; + logical lquery; + integer smlsiz, storez, strtrw; + --d__; + --e; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + --iwork; + *info = 0; + lquery = *lwork == -1 || *liwork == -1; + if (lsame_(compz, (char *)"N", (ftnlen)1, (ftnlen)1)) { + icompz = 0; + } else if (lsame_(compz, (char *)"V", (ftnlen)1, (ftnlen)1)) { + icompz = 1; + } else if (lsame_(compz, (char *)"I", (ftnlen)1, (ftnlen)1)) { + icompz = 2; + } else { + icompz = -1; + } + if (icompz < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*ldz < 1 || icompz > 0 && *ldz < max(1, *n)) { + *info = -6; + } + if (*info == 0) { + smlsiz = ilaenv_(&c__9, (char *)"DSTEDC", (char *)" ", &c__0, &c__0, &c__0, &c__0, (ftnlen)6, (ftnlen)1); + if (*n <= 1 || icompz == 0) { + liwmin = 1; + lwmin = 1; + } else if (*n <= smlsiz) { + liwmin = 1; + lwmin = *n - 1 << 1; + } else { + lgn = (integer)(log((doublereal)(*n)) / log(2.)); + if (pow_lmp_ii(&c__2, &lgn) < *n) { + ++lgn; + } + if (pow_lmp_ii(&c__2, &lgn) < *n) { + ++lgn; + } + if (icompz == 1) { + i__1 = *n; + lwmin = *n * 3 + 1 + (*n << 1) * lgn + (i__1 * i__1 << 2); + liwmin = *n * 6 + 6 + *n * 5 * lgn; + } else if (icompz == 2) { + i__1 = *n; + lwmin = (*n << 2) + 1 + i__1 * i__1; + liwmin = *n * 5 + 3; + } + } + work[1] = (doublereal)lwmin; + iwork[1] = liwmin; + if (*lwork < lwmin && !lquery) { + *info = -8; + } else if (*liwork < liwmin && !lquery) { + *info = -10; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DSTEDC", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + if (*n == 0) { + return 0; + } + if (*n == 1) { + if (icompz != 0) { + z__[z_dim1 + 1] = 1.; + } + return 0; + } + if (icompz == 0) { + dsterf_(n, &d__[1], &e[1], info); + goto L50; + } + if (*n <= smlsiz) { + dsteqr_(compz, n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1], info, (ftnlen)1); + } else { + if (icompz == 1) { + storez = *n * *n + 1; + } else { + storez = 1; + } + if (icompz == 2) { + dlaset_((char *)"Full", n, n, &c_b17, &c_b18, &z__[z_offset], ldz, (ftnlen)4); + } + orgnrm = dlanst_((char *)"M", n, &d__[1], &e[1], (ftnlen)1); + if (orgnrm == 0.) { + goto L50; + } + eps = dlamch_((char *)"Epsilon", (ftnlen)7); + start = 1; + L10: + if (start <= *n) { + finish = start; + L20: + if (finish < *n) { + tiny = eps * sqrt((d__1 = d__[finish], abs(d__1))) * + sqrt((d__2 = d__[finish + 1], abs(d__2))); + if ((d__1 = e[finish], abs(d__1)) > tiny) { + ++finish; + goto L20; + } + } + m = finish - start + 1; + if (m == 1) { + start = finish + 1; + goto L10; + } + if (m > smlsiz) { + orgnrm = dlanst_((char *)"M", &m, &d__[start], &e[start], (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b18, &m, &c__1, &d__[start], &m, info, + (ftnlen)1); + i__1 = m - 1; + i__2 = m - 1; + dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b18, &i__1, &c__1, &e[start], &i__2, info, + (ftnlen)1); + if (icompz == 1) { + strtrw = 1; + } else { + strtrw = start; + } + dlaed0_(&icompz, n, &m, &d__[start], &e[start], &z__[strtrw + start * z_dim1], ldz, + &work[1], n, &work[storez], &iwork[1], info); + if (*info != 0) { + *info = (*info / (m + 1) + start - 1) * (*n + 1) + *info % (m + 1) + start - 1; + goto L50; + } + dlascl_((char *)"G", &c__0, &c__0, &c_b18, &orgnrm, &m, &c__1, &d__[start], &m, info, + (ftnlen)1); + } else { + if (icompz == 1) { + dsteqr_((char *)"I", &m, &d__[start], &e[start], &work[1], &m, &work[m * m + 1], info, + (ftnlen)1); + dlacpy_((char *)"A", n, &m, &z__[start * z_dim1 + 1], ldz, &work[storez], n, (ftnlen)1); + dgemm_((char *)"N", (char *)"N", n, &m, &m, &c_b18, &work[storez], n, &work[1], &m, &c_b17, + &z__[start * z_dim1 + 1], ldz, (ftnlen)1, (ftnlen)1); + } else if (icompz == 2) { + dsteqr_((char *)"I", &m, &d__[start], &e[start], &z__[start + start * z_dim1], ldz, + &work[1], info, (ftnlen)1); + } else { + dsterf_(&m, &d__[start], &e[start], info); + } + if (*info != 0) { + *info = start * (*n + 1) + finish; + goto L50; + } + } + start = finish + 1; + goto L10; + } + if (icompz == 0) { + dlasrt_((char *)"I", n, &d__[1], info, (ftnlen)1); + } else { + i__1 = *n; + for (ii = 2; ii <= i__1; ++ii) { + i__ = ii - 1; + k = i__; + p = d__[i__]; + i__2 = *n; + for (j = ii; j <= i__2; ++j) { + if (d__[j] < p) { + k = j; + p = d__[j]; + } + } + if (k != i__) { + d__[k] = d__[i__]; + d__[i__] = p; + dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1], &c__1); + } + } + } + } +L50: + work[1] = (doublereal)lwmin; + iwork[1] = liwmin; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dstedc.f b/lib/linalg/dstedc.f deleted file mode 100644 index 2ed84afaac..0000000000 --- a/lib/linalg/dstedc.f +++ /dev/null @@ -1,479 +0,0 @@ -*> \brief \b DSTEDC -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DSTEDC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, -* LIWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER COMPZ -* INTEGER INFO, LDZ, LIWORK, LWORK, N -* .. -* .. Array Arguments .. -* INTEGER IWORK( * ) -* DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSTEDC computes all eigenvalues and, optionally, eigenvectors of a -*> symmetric tridiagonal matrix using the divide and conquer method. -*> The eigenvectors of a full or band real symmetric matrix can also be -*> found if DSYTRD or DSPTRD or DSBTRD has been used to reduce this -*> matrix to tridiagonal form. -*> -*> This code makes very mild assumptions about floating point -*> arithmetic. It will work on machines with a guard digit in -*> add/subtract, or on those binary machines without guard digits -*> which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. -*> It could conceivably fail on hexadecimal or decimal machines -*> without guard digits, but we know of none. See DLAED3 for details. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] COMPZ -*> \verbatim -*> COMPZ is CHARACTER*1 -*> = 'N': Compute eigenvalues only. -*> = 'I': Compute eigenvectors of tridiagonal matrix also. -*> = 'V': Compute eigenvectors of original dense symmetric -*> matrix also. On entry, Z contains the orthogonal -*> matrix used to reduce the original matrix to -*> tridiagonal form. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The dimension of the symmetric tridiagonal matrix. N >= 0. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, the diagonal elements of the tridiagonal matrix. -*> On exit, if INFO = 0, the eigenvalues in ascending order. -*> \endverbatim -*> -*> \param[in,out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N-1) -*> On entry, the subdiagonal elements of the tridiagonal matrix. -*> On exit, E has been destroyed. -*> \endverbatim -*> -*> \param[in,out] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension (LDZ,N) -*> On entry, if COMPZ = 'V', then Z contains the orthogonal -*> matrix used in the reduction to tridiagonal form. -*> On exit, if INFO = 0, then if COMPZ = 'V', Z contains the -*> orthonormal eigenvectors of the original symmetric matrix, -*> and if COMPZ = 'I', Z contains the orthonormal eigenvectors -*> of the symmetric tridiagonal matrix. -*> If COMPZ = 'N', then Z is not referenced. -*> \endverbatim -*> -*> \param[in] LDZ -*> \verbatim -*> LDZ is INTEGER -*> The leading dimension of the array Z. LDZ >= 1. -*> If eigenvectors are desired, then LDZ >= max(1,N). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. -*> If COMPZ = 'N' or N <= 1 then LWORK must be at least 1. -*> If COMPZ = 'V' and N > 1 then LWORK must be at least -*> ( 1 + 3*N + 2*N*lg N + 4*N**2 ), -*> where lg( N ) = smallest integer k such -*> that 2**k >= N. -*> If COMPZ = 'I' and N > 1 then LWORK must be at least -*> ( 1 + 4*N + N**2 ). -*> Note that for COMPZ = 'I' or 'V', then if N is less than or -*> equal to the minimum divide size, usually 25, then LWORK need -*> only be max(1,2*(N-1)). -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal size of the WORK array, returns -*> this value as the first entry of the WORK array, and no error -*> message related to LWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) -*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. -*> \endverbatim -*> -*> \param[in] LIWORK -*> \verbatim -*> LIWORK is INTEGER -*> The dimension of the array IWORK. -*> If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1. -*> If COMPZ = 'V' and N > 1 then LIWORK must be at least -*> ( 6 + 6*N + 5*N*lg N ). -*> If COMPZ = 'I' and N > 1 then LIWORK must be at least -*> ( 3 + 5*N ). -*> Note that for COMPZ = 'I' or 'V', then if N is less than or -*> equal to the minimum divide size, usually 25, then LIWORK -*> need only be 1. -*> -*> If LIWORK = -1, then a workspace query is assumed; the -*> routine only calculates the optimal size of the IWORK array, -*> returns this value as the first entry of the IWORK array, and -*> no error message related to LIWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit. -*> < 0: if INFO = -i, the i-th argument had an illegal value. -*> > 0: The algorithm failed to compute an eigenvalue while -*> working on the submatrix lying in rows and columns -*> INFO/(N+1) through mod(INFO,N+1). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -*> \par Contributors: -* ================== -*> -*> Jeff Rutter, Computer Science Division, University of California -*> at Berkeley, USA \n -*> Modified by Francoise Tisseur, University of Tennessee -*> -* ===================================================================== - SUBROUTINE DSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, - $ LIWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER COMPZ - INTEGER INFO, LDZ, LIWORK, LWORK, N -* .. -* .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER FINISH, I, ICOMPZ, II, J, K, LGN, LIWMIN, - $ LWMIN, M, SMLSIZ, START, STOREZ, STRTRW - DOUBLE PRECISION EPS, ORGNRM, P, TINY -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANST - EXTERNAL LSAME, ILAENV, DLAMCH, DLANST -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DLACPY, DLAED0, DLASCL, DLASET, DLASRT, - $ DSTEQR, DSTERF, DSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, LOG, MAX, MOD, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) -* - IF( LSAME( COMPZ, 'N' ) ) THEN - ICOMPZ = 0 - ELSE IF( LSAME( COMPZ, 'V' ) ) THEN - ICOMPZ = 1 - ELSE IF( LSAME( COMPZ, 'I' ) ) THEN - ICOMPZ = 2 - ELSE - ICOMPZ = -1 - END IF - IF( ICOMPZ.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( ( LDZ.LT.1 ) .OR. - $ ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, N ) ) ) THEN - INFO = -6 - END IF -* - IF( INFO.EQ.0 ) THEN -* -* Compute the workspace requirements -* - SMLSIZ = ILAENV( 9, 'DSTEDC', ' ', 0, 0, 0, 0 ) - IF( N.LE.1 .OR. ICOMPZ.EQ.0 ) THEN - LIWMIN = 1 - LWMIN = 1 - ELSE IF( N.LE.SMLSIZ ) THEN - LIWMIN = 1 - LWMIN = 2*( N - 1 ) - ELSE - LGN = INT( LOG( DBLE( N ) )/LOG( TWO ) ) - IF( 2**LGN.LT.N ) - $ LGN = LGN + 1 - IF( 2**LGN.LT.N ) - $ LGN = LGN + 1 - IF( ICOMPZ.EQ.1 ) THEN - LWMIN = 1 + 3*N + 2*N*LGN + 4*N**2 - LIWMIN = 6 + 6*N + 5*N*LGN - ELSE IF( ICOMPZ.EQ.2 ) THEN - LWMIN = 1 + 4*N + N**2 - LIWMIN = 3 + 5*N - END IF - END IF - WORK( 1 ) = LWMIN - IWORK( 1 ) = LIWMIN -* - IF( LWORK.LT.LWMIN .AND. .NOT. LQUERY ) THEN - INFO = -8 - ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT. LQUERY ) THEN - INFO = -10 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSTEDC', -INFO ) - RETURN - ELSE IF (LQUERY) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN - IF( N.EQ.1 ) THEN - IF( ICOMPZ.NE.0 ) - $ Z( 1, 1 ) = ONE - RETURN - END IF -* -* If the following conditional clause is removed, then the routine -* will use the Divide and Conquer routine to compute only the -* eigenvalues, which requires (3N + 3N**2) real workspace and -* (2 + 5N + 2N lg(N)) integer workspace. -* Since on many architectures DSTERF is much faster than any other -* algorithm for finding eigenvalues only, it is used here -* as the default. If the conditional clause is removed, then -* information on the size of workspace needs to be changed. -* -* If COMPZ = 'N', use DSTERF to compute the eigenvalues. -* - IF( ICOMPZ.EQ.0 ) THEN - CALL DSTERF( N, D, E, INFO ) - GO TO 50 - END IF -* -* If N is smaller than the minimum divide size (SMLSIZ+1), then -* solve the problem with another solver. -* - IF( N.LE.SMLSIZ ) THEN -* - CALL DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) -* - ELSE -* -* If COMPZ = 'V', the Z matrix must be stored elsewhere for later -* use. -* - IF( ICOMPZ.EQ.1 ) THEN - STOREZ = 1 + N*N - ELSE - STOREZ = 1 - END IF -* - IF( ICOMPZ.EQ.2 ) THEN - CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) - END IF -* -* Scale. -* - ORGNRM = DLANST( 'M', N, D, E ) - IF( ORGNRM.EQ.ZERO ) - $ GO TO 50 -* - EPS = DLAMCH( 'Epsilon' ) -* - START = 1 -* -* while ( START <= N ) -* - 10 CONTINUE - IF( START.LE.N ) THEN -* -* Let FINISH be the position of the next subdiagonal entry -* such that E( FINISH ) <= TINY or FINISH = N if no such -* subdiagonal exists. The matrix identified by the elements -* between START and FINISH constitutes an independent -* sub-problem. -* - FINISH = START - 20 CONTINUE - IF( FINISH.LT.N ) THEN - TINY = EPS*SQRT( ABS( D( FINISH ) ) )* - $ SQRT( ABS( D( FINISH+1 ) ) ) - IF( ABS( E( FINISH ) ).GT.TINY ) THEN - FINISH = FINISH + 1 - GO TO 20 - END IF - END IF -* -* (Sub) Problem determined. Compute its size and solve it. -* - M = FINISH - START + 1 - IF( M.EQ.1 ) THEN - START = FINISH + 1 - GO TO 10 - END IF - IF( M.GT.SMLSIZ ) THEN -* -* Scale. -* - ORGNRM = DLANST( 'M', M, D( START ), E( START ) ) - CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M, 1, D( START ), M, - $ INFO ) - CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M-1, 1, E( START ), - $ M-1, INFO ) -* - IF( ICOMPZ.EQ.1 ) THEN - STRTRW = 1 - ELSE - STRTRW = START - END IF - CALL DLAED0( ICOMPZ, N, M, D( START ), E( START ), - $ Z( STRTRW, START ), LDZ, WORK( 1 ), N, - $ WORK( STOREZ ), IWORK, INFO ) - IF( INFO.NE.0 ) THEN - INFO = ( INFO / ( M+1 )+START-1 )*( N+1 ) + - $ MOD( INFO, ( M+1 ) ) + START - 1 - GO TO 50 - END IF -* -* Scale back. -* - CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, M, 1, D( START ), M, - $ INFO ) -* - ELSE - IF( ICOMPZ.EQ.1 ) THEN -* -* Since QR won't update a Z matrix which is larger than -* the length of D, we must solve the sub-problem in a -* workspace and then multiply back into Z. -* - CALL DSTEQR( 'I', M, D( START ), E( START ), WORK, M, - $ WORK( M*M+1 ), INFO ) - CALL DLACPY( 'A', N, M, Z( 1, START ), LDZ, - $ WORK( STOREZ ), N ) - CALL DGEMM( 'N', 'N', N, M, M, ONE, - $ WORK( STOREZ ), N, WORK, M, ZERO, - $ Z( 1, START ), LDZ ) - ELSE IF( ICOMPZ.EQ.2 ) THEN - CALL DSTEQR( 'I', M, D( START ), E( START ), - $ Z( START, START ), LDZ, WORK, INFO ) - ELSE - CALL DSTERF( M, D( START ), E( START ), INFO ) - END IF - IF( INFO.NE.0 ) THEN - INFO = START*( N+1 ) + FINISH - GO TO 50 - END IF - END IF -* - START = FINISH + 1 - GO TO 10 - END IF -* -* endwhile -* - IF( ICOMPZ.EQ.0 ) THEN -* -* Use Quick Sort -* - CALL DLASRT( 'I', N, D, INFO ) -* - ELSE -* -* Use Selection Sort to minimize swaps of eigenvectors -* - DO 40 II = 2, N - I = II - 1 - K = I - P = D( I ) - DO 30 J = II, N - IF( D( J ).LT.P ) THEN - K = J - P = D( J ) - END IF - 30 CONTINUE - IF( K.NE.I ) THEN - D( K ) = D( I ) - D( I ) = P - CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) - END IF - 40 CONTINUE - END IF - END IF -* - 50 CONTINUE - WORK( 1 ) = LWMIN - IWORK( 1 ) = LIWMIN -* - RETURN -* -* End of DSTEDC -* - END diff --git a/lib/linalg/dsteqr.cpp b/lib/linalg/dsteqr.cpp new file mode 100644 index 0000000000..4a611d4102 --- /dev/null +++ b/lib/linalg/dsteqr.cpp @@ -0,0 +1,377 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static doublereal c_b9 = 0.; +static doublereal c_b10 = 1.; +static integer c__0 = 0; +static integer c__1 = 1; +static integer c__2 = 2; +int dsteqr_(char *compz, integer *n, doublereal *d__, doublereal *e, doublereal *z__, integer *ldz, + doublereal *work, integer *info, ftnlen compz_len) +{ + integer z_dim1, z_offset, i__1, i__2; + doublereal d__1, d__2; + double sqrt(doublereal), d_lmp_sign(doublereal *, doublereal *); + doublereal b, c__, f, g; + integer i__, j, k, l, m; + doublereal p, r__, s; + integer l1, ii, mm, lm1, mm1, nm1; + doublereal rt1, rt2, eps; + integer lsv; + doublereal tst, eps2; + integer lend, jtot; + extern int dlae2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *); + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern int dlasr_(char *, char *, char *, integer *, integer *, doublereal *, doublereal *, + doublereal *, integer *, ftnlen, ftnlen, ftnlen); + doublereal anorm; + extern int dswap_(integer *, doublereal *, integer *, doublereal *, integer *), + dlaev2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *); + integer lendm1, lendp1; + extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, ftnlen); + integer iscale; + extern int dlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, + integer *, doublereal *, integer *, integer *, ftnlen), + dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, + ftnlen); + doublereal safmin; + extern int dlartg_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *); + doublereal safmax; + extern int xerbla_(char *, integer *, ftnlen); + extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *, ftnlen); + extern int dlasrt_(char *, integer *, doublereal *, integer *, ftnlen); + integer lendsv; + doublereal ssfmin; + integer nmaxit, icompz; + doublereal ssfmax; + --d__; + --e; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + *info = 0; + if (lsame_(compz, (char *)"N", (ftnlen)1, (ftnlen)1)) { + icompz = 0; + } else if (lsame_(compz, (char *)"V", (ftnlen)1, (ftnlen)1)) { + icompz = 1; + } else if (lsame_(compz, (char *)"I", (ftnlen)1, (ftnlen)1)) { + icompz = 2; + } else { + icompz = -1; + } + if (icompz < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*ldz < 1 || icompz > 0 && *ldz < max(1, *n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DSTEQR", &i__1, (ftnlen)6); + return 0; + } + if (*n == 0) { + return 0; + } + if (*n == 1) { + if (icompz == 2) { + z__[z_dim1 + 1] = 1.; + } + return 0; + } + eps = dlamch_((char *)"E", (ftnlen)1); + d__1 = eps; + eps2 = d__1 * d__1; + safmin = dlamch_((char *)"S", (ftnlen)1); + safmax = 1. / safmin; + ssfmax = sqrt(safmax) / 3.; + ssfmin = sqrt(safmin) / eps2; + if (icompz == 2) { + dlaset_((char *)"Full", n, n, &c_b9, &c_b10, &z__[z_offset], ldz, (ftnlen)4); + } + nmaxit = *n * 30; + jtot = 0; + l1 = 1; + nm1 = *n - 1; +L10: + if (l1 > *n) { + goto L160; + } + if (l1 > 1) { + e[l1 - 1] = 0.; + } + if (l1 <= nm1) { + i__1 = nm1; + for (m = l1; m <= i__1; ++m) { + tst = (d__1 = e[m], abs(d__1)); + if (tst == 0.) { + goto L30; + } + if (tst <= + sqrt((d__1 = d__[m], abs(d__1))) * sqrt((d__2 = d__[m + 1], abs(d__2))) * eps) { + e[m] = 0.; + goto L30; + } + } + } + m = *n; +L30: + l = l1; + lsv = l; + lend = m; + lendsv = lend; + l1 = m + 1; + if (lend == l) { + goto L10; + } + i__1 = lend - l + 1; + anorm = dlanst_((char *)"M", &i__1, &d__[l], &e[l], (ftnlen)1); + iscale = 0; + if (anorm == 0.) { + goto L10; + } + if (anorm > ssfmax) { + iscale = 1; + i__1 = lend - l + 1; + dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n, info, (ftnlen)1); + i__1 = lend - l; + dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n, info, (ftnlen)1); + } else if (anorm < ssfmin) { + iscale = 2; + i__1 = lend - l + 1; + dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n, info, (ftnlen)1); + i__1 = lend - l; + dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n, info, (ftnlen)1); + } + if ((d__1 = d__[lend], abs(d__1)) < (d__2 = d__[l], abs(d__2))) { + lend = lsv; + l = lendsv; + } + if (lend > l) { + L40: + if (l != lend) { + lendm1 = lend - 1; + i__1 = lendm1; + for (m = l; m <= i__1; ++m) { + d__2 = (d__1 = e[m], abs(d__1)); + tst = d__2 * d__2; + if (tst <= + eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m + 1], abs(d__2)) + safmin) { + goto L60; + } + } + } + m = lend; + L60: + if (m < lend) { + e[m] = 0.; + } + p = d__[l]; + if (m == l) { + goto L80; + } + if (m == l + 1) { + if (icompz > 0) { + dlaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s); + work[l] = c__; + work[*n - 1 + l] = s; + dlasr_((char *)"R", (char *)"V", (char *)"B", n, &c__2, &work[l], &work[*n - 1 + l], &z__[l * z_dim1 + 1], + ldz, (ftnlen)1, (ftnlen)1, (ftnlen)1); + } else { + dlae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2); + } + d__[l] = rt1; + d__[l + 1] = rt2; + e[l] = 0.; + l += 2; + if (l <= lend) { + goto L40; + } + goto L140; + } + if (jtot == nmaxit) { + goto L140; + } + ++jtot; + g = (d__[l + 1] - p) / (e[l] * 2.); + r__ = dlapy2_(&g, &c_b10); + g = d__[m] - p + e[l] / (g + d_lmp_sign(&r__, &g)); + s = 1.; + c__ = 1.; + p = 0.; + mm1 = m - 1; + i__1 = l; + for (i__ = mm1; i__ >= i__1; --i__) { + f = s * e[i__]; + b = c__ * e[i__]; + dlartg_(&g, &f, &c__, &s, &r__); + if (i__ != m - 1) { + e[i__ + 1] = r__; + } + g = d__[i__ + 1] - p; + r__ = (d__[i__] - g) * s + c__ * 2. * b; + p = s * r__; + d__[i__ + 1] = g + p; + g = c__ * r__ - b; + if (icompz > 0) { + work[i__] = c__; + work[*n - 1 + i__] = -s; + } + } + if (icompz > 0) { + mm = m - l + 1; + dlasr_((char *)"R", (char *)"V", (char *)"B", n, &mm, &work[l], &work[*n - 1 + l], &z__[l * z_dim1 + 1], ldz, + (ftnlen)1, (ftnlen)1, (ftnlen)1); + } + d__[l] -= p; + e[l] = g; + goto L40; + L80: + d__[l] = p; + ++l; + if (l <= lend) { + goto L40; + } + goto L140; + } else { + L90: + if (l != lend) { + lendp1 = lend + 1; + i__1 = lendp1; + for (m = l; m >= i__1; --m) { + d__2 = (d__1 = e[m - 1], abs(d__1)); + tst = d__2 * d__2; + if (tst <= + eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m - 1], abs(d__2)) + safmin) { + goto L110; + } + } + } + m = lend; + L110: + if (m > lend) { + e[m - 1] = 0.; + } + p = d__[l]; + if (m == l) { + goto L130; + } + if (m == l - 1) { + if (icompz > 0) { + dlaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s); + work[m] = c__; + work[*n - 1 + m] = s; + dlasr_((char *)"R", (char *)"V", (char *)"F", n, &c__2, &work[m], &work[*n - 1 + m], + &z__[(l - 1) * z_dim1 + 1], ldz, (ftnlen)1, (ftnlen)1, (ftnlen)1); + } else { + dlae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2); + } + d__[l - 1] = rt1; + d__[l] = rt2; + e[l - 1] = 0.; + l += -2; + if (l >= lend) { + goto L90; + } + goto L140; + } + if (jtot == nmaxit) { + goto L140; + } + ++jtot; + g = (d__[l - 1] - p) / (e[l - 1] * 2.); + r__ = dlapy2_(&g, &c_b10); + g = d__[m] - p + e[l - 1] / (g + d_lmp_sign(&r__, &g)); + s = 1.; + c__ = 1.; + p = 0.; + lm1 = l - 1; + i__1 = lm1; + for (i__ = m; i__ <= i__1; ++i__) { + f = s * e[i__]; + b = c__ * e[i__]; + dlartg_(&g, &f, &c__, &s, &r__); + if (i__ != m) { + e[i__ - 1] = r__; + } + g = d__[i__] - p; + r__ = (d__[i__ + 1] - g) * s + c__ * 2. * b; + p = s * r__; + d__[i__] = g + p; + g = c__ * r__ - b; + if (icompz > 0) { + work[i__] = c__; + work[*n - 1 + i__] = s; + } + } + if (icompz > 0) { + mm = l - m + 1; + dlasr_((char *)"R", (char *)"V", (char *)"F", n, &mm, &work[m], &work[*n - 1 + m], &z__[m * z_dim1 + 1], ldz, + (ftnlen)1, (ftnlen)1, (ftnlen)1); + } + d__[l] -= p; + e[lm1] = g; + goto L90; + L130: + d__[l] = p; + --l; + if (l >= lend) { + goto L90; + } + goto L140; + } +L140: + if (iscale == 1) { + i__1 = lendsv - lsv + 1; + dlascl_((char *)"G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv], n, info, (ftnlen)1); + i__1 = lendsv - lsv; + dlascl_((char *)"G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n, info, (ftnlen)1); + } else if (iscale == 2) { + i__1 = lendsv - lsv + 1; + dlascl_((char *)"G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv], n, info, (ftnlen)1); + i__1 = lendsv - lsv; + dlascl_((char *)"G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n, info, (ftnlen)1); + } + if (jtot < nmaxit) { + goto L10; + } + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + if (e[i__] != 0.) { + ++(*info); + } + } + goto L190; +L160: + if (icompz == 0) { + dlasrt_((char *)"I", n, &d__[1], info, (ftnlen)1); + } else { + i__1 = *n; + for (ii = 2; ii <= i__1; ++ii) { + i__ = ii - 1; + k = i__; + p = d__[i__]; + i__2 = *n; + for (j = ii; j <= i__2; ++j) { + if (d__[j] < p) { + k = j; + p = d__[j]; + } + } + if (k != i__) { + d__[k] = d__[i__]; + d__[i__] = p; + dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1], &c__1); + } + } + } +L190: + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dsteqr.f b/lib/linalg/dsteqr.f deleted file mode 100644 index 50a9188c7c..0000000000 --- a/lib/linalg/dsteqr.f +++ /dev/null @@ -1,569 +0,0 @@ -*> \brief \b DSTEQR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DSTEQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER COMPZ -* INTEGER INFO, LDZ, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSTEQR computes all eigenvalues and, optionally, eigenvectors of a -*> symmetric tridiagonal matrix using the implicit QL or QR method. -*> The eigenvectors of a full or band symmetric matrix can also be found -*> if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to -*> tridiagonal form. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] COMPZ -*> \verbatim -*> COMPZ is CHARACTER*1 -*> = 'N': Compute eigenvalues only. -*> = 'V': Compute eigenvalues and eigenvectors of the original -*> symmetric matrix. On entry, Z must contain the -*> orthogonal matrix used to reduce the original matrix -*> to tridiagonal form. -*> = 'I': Compute eigenvalues and eigenvectors of the -*> tridiagonal matrix. Z is initialized to the identity -*> matrix. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix. N >= 0. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, the diagonal elements of the tridiagonal matrix. -*> On exit, if INFO = 0, the eigenvalues in ascending order. -*> \endverbatim -*> -*> \param[in,out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N-1) -*> On entry, the (n-1) subdiagonal elements of the tridiagonal -*> matrix. -*> On exit, E has been destroyed. -*> \endverbatim -*> -*> \param[in,out] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension (LDZ, N) -*> On entry, if COMPZ = 'V', then Z contains the orthogonal -*> matrix used in the reduction to tridiagonal form. -*> On exit, if INFO = 0, then if COMPZ = 'V', Z contains the -*> orthonormal eigenvectors of the original symmetric matrix, -*> and if COMPZ = 'I', Z contains the orthonormal eigenvectors -*> of the symmetric tridiagonal matrix. -*> If COMPZ = 'N', then Z is not referenced. -*> \endverbatim -*> -*> \param[in] LDZ -*> \verbatim -*> LDZ is INTEGER -*> The leading dimension of the array Z. LDZ >= 1, and if -*> eigenvectors are desired, then LDZ >= max(1,N). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (max(1,2*N-2)) -*> If COMPZ = 'N', then WORK is not referenced. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> > 0: the algorithm has failed to find all the eigenvalues in -*> a total of 30*N iterations; if INFO = i, then i -*> elements of E have not converged to zero; on exit, D -*> and E contain the elements of a symmetric tridiagonal -*> matrix which is orthogonally similar to the original -*> matrix. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -* ===================================================================== - SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER COMPZ - INTEGER INFO, LDZ, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ THREE = 3.0D0 ) - INTEGER MAXIT - PARAMETER ( MAXIT = 30 ) -* .. -* .. Local Scalars .. - INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND, - $ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1, - $ NM1, NMAXIT - DOUBLE PRECISION ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2, - $ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANST, DLAPY2 - EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2 -* .. -* .. External Subroutines .. - EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASET, DLASR, - $ DLASRT, DSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SIGN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( LSAME( COMPZ, 'N' ) ) THEN - ICOMPZ = 0 - ELSE IF( LSAME( COMPZ, 'V' ) ) THEN - ICOMPZ = 1 - ELSE IF( LSAME( COMPZ, 'I' ) ) THEN - ICOMPZ = 2 - ELSE - ICOMPZ = -1 - END IF - IF( ICOMPZ.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, - $ N ) ) ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSTEQR', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( N.EQ.1 ) THEN - IF( ICOMPZ.EQ.2 ) - $ Z( 1, 1 ) = ONE - RETURN - END IF -* -* Determine the unit roundoff and over/underflow thresholds. -* - EPS = DLAMCH( 'E' ) - EPS2 = EPS**2 - SAFMIN = DLAMCH( 'S' ) - SAFMAX = ONE / SAFMIN - SSFMAX = SQRT( SAFMAX ) / THREE - SSFMIN = SQRT( SAFMIN ) / EPS2 -* -* Compute the eigenvalues and eigenvectors of the tridiagonal -* matrix. -* - IF( ICOMPZ.EQ.2 ) - $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) -* - NMAXIT = N*MAXIT - JTOT = 0 -* -* Determine where the matrix splits and choose QL or QR iteration -* for each block, according to whether top or bottom diagonal -* element is smaller. -* - L1 = 1 - NM1 = N - 1 -* - 10 CONTINUE - IF( L1.GT.N ) - $ GO TO 160 - IF( L1.GT.1 ) - $ E( L1-1 ) = ZERO - IF( L1.LE.NM1 ) THEN - DO 20 M = L1, NM1 - TST = ABS( E( M ) ) - IF( TST.EQ.ZERO ) - $ GO TO 30 - IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ - $ 1 ) ) ) )*EPS ) THEN - E( M ) = ZERO - GO TO 30 - END IF - 20 CONTINUE - END IF - M = N -* - 30 CONTINUE - L = L1 - LSV = L - LEND = M - LENDSV = LEND - L1 = M + 1 - IF( LEND.EQ.L ) - $ GO TO 10 -* -* Scale submatrix in rows and columns L to LEND -* - ANORM = DLANST( 'M', LEND-L+1, D( L ), E( L ) ) - ISCALE = 0 - IF( ANORM.EQ.ZERO ) - $ GO TO 10 - IF( ANORM.GT.SSFMAX ) THEN - ISCALE = 1 - CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, - $ INFO ) - CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, - $ INFO ) - ELSE IF( ANORM.LT.SSFMIN ) THEN - ISCALE = 2 - CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, - $ INFO ) - CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, - $ INFO ) - END IF -* -* Choose between QL and QR iteration -* - IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN - LEND = LSV - L = LENDSV - END IF -* - IF( LEND.GT.L ) THEN -* -* QL Iteration -* -* Look for small subdiagonal element. -* - 40 CONTINUE - IF( L.NE.LEND ) THEN - LENDM1 = LEND - 1 - DO 50 M = L, LENDM1 - TST = ABS( E( M ) )**2 - IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+ - $ SAFMIN )GO TO 60 - 50 CONTINUE - END IF -* - M = LEND -* - 60 CONTINUE - IF( M.LT.LEND ) - $ E( M ) = ZERO - P = D( L ) - IF( M.EQ.L ) - $ GO TO 80 -* -* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 -* to compute its eigensystem. -* - IF( M.EQ.L+1 ) THEN - IF( ICOMPZ.GT.0 ) THEN - CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S ) - WORK( L ) = C - WORK( N-1+L ) = S - CALL DLASR( 'R', 'V', 'B', N, 2, WORK( L ), - $ WORK( N-1+L ), Z( 1, L ), LDZ ) - ELSE - CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 ) - END IF - D( L ) = RT1 - D( L+1 ) = RT2 - E( L ) = ZERO - L = L + 2 - IF( L.LE.LEND ) - $ GO TO 40 - GO TO 140 - END IF -* - IF( JTOT.EQ.NMAXIT ) - $ GO TO 140 - JTOT = JTOT + 1 -* -* Form shift. -* - G = ( D( L+1 )-P ) / ( TWO*E( L ) ) - R = DLAPY2( G, ONE ) - G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) ) -* - S = ONE - C = ONE - P = ZERO -* -* Inner loop -* - MM1 = M - 1 - DO 70 I = MM1, L, -1 - F = S*E( I ) - B = C*E( I ) - CALL DLARTG( G, F, C, S, R ) - IF( I.NE.M-1 ) - $ E( I+1 ) = R - G = D( I+1 ) - P - R = ( D( I )-G )*S + TWO*C*B - P = S*R - D( I+1 ) = G + P - G = C*R - B -* -* If eigenvectors are desired, then save rotations. -* - IF( ICOMPZ.GT.0 ) THEN - WORK( I ) = C - WORK( N-1+I ) = -S - END IF -* - 70 CONTINUE -* -* If eigenvectors are desired, then apply saved rotations. -* - IF( ICOMPZ.GT.0 ) THEN - MM = M - L + 1 - CALL DLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ), - $ Z( 1, L ), LDZ ) - END IF -* - D( L ) = D( L ) - P - E( L ) = G - GO TO 40 -* -* Eigenvalue found. -* - 80 CONTINUE - D( L ) = P -* - L = L + 1 - IF( L.LE.LEND ) - $ GO TO 40 - GO TO 140 -* - ELSE -* -* QR Iteration -* -* Look for small superdiagonal element. -* - 90 CONTINUE - IF( L.NE.LEND ) THEN - LENDP1 = LEND + 1 - DO 100 M = L, LENDP1, -1 - TST = ABS( E( M-1 ) )**2 - IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+ - $ SAFMIN )GO TO 110 - 100 CONTINUE - END IF -* - M = LEND -* - 110 CONTINUE - IF( M.GT.LEND ) - $ E( M-1 ) = ZERO - P = D( L ) - IF( M.EQ.L ) - $ GO TO 130 -* -* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 -* to compute its eigensystem. -* - IF( M.EQ.L-1 ) THEN - IF( ICOMPZ.GT.0 ) THEN - CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S ) - WORK( M ) = C - WORK( N-1+M ) = S - CALL DLASR( 'R', 'V', 'F', N, 2, WORK( M ), - $ WORK( N-1+M ), Z( 1, L-1 ), LDZ ) - ELSE - CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 ) - END IF - D( L-1 ) = RT1 - D( L ) = RT2 - E( L-1 ) = ZERO - L = L - 2 - IF( L.GE.LEND ) - $ GO TO 90 - GO TO 140 - END IF -* - IF( JTOT.EQ.NMAXIT ) - $ GO TO 140 - JTOT = JTOT + 1 -* -* Form shift. -* - G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) ) - R = DLAPY2( G, ONE ) - G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) ) -* - S = ONE - C = ONE - P = ZERO -* -* Inner loop -* - LM1 = L - 1 - DO 120 I = M, LM1 - F = S*E( I ) - B = C*E( I ) - CALL DLARTG( G, F, C, S, R ) - IF( I.NE.M ) - $ E( I-1 ) = R - G = D( I ) - P - R = ( D( I+1 )-G )*S + TWO*C*B - P = S*R - D( I ) = G + P - G = C*R - B -* -* If eigenvectors are desired, then save rotations. -* - IF( ICOMPZ.GT.0 ) THEN - WORK( I ) = C - WORK( N-1+I ) = S - END IF -* - 120 CONTINUE -* -* If eigenvectors are desired, then apply saved rotations. -* - IF( ICOMPZ.GT.0 ) THEN - MM = L - M + 1 - CALL DLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ), - $ Z( 1, M ), LDZ ) - END IF -* - D( L ) = D( L ) - P - E( LM1 ) = G - GO TO 90 -* -* Eigenvalue found. -* - 130 CONTINUE - D( L ) = P -* - L = L - 1 - IF( L.GE.LEND ) - $ GO TO 90 - GO TO 140 -* - END IF -* -* Undo scaling if necessary -* - 140 CONTINUE - IF( ISCALE.EQ.1 ) THEN - CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, - $ D( LSV ), N, INFO ) - CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ), - $ N, INFO ) - ELSE IF( ISCALE.EQ.2 ) THEN - CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, - $ D( LSV ), N, INFO ) - CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ), - $ N, INFO ) - END IF -* -* Check for no convergence to an eigenvalue after a total -* of N*MAXIT iterations. -* - IF( JTOT.LT.NMAXIT ) - $ GO TO 10 - DO 150 I = 1, N - 1 - IF( E( I ).NE.ZERO ) - $ INFO = INFO + 1 - 150 CONTINUE - GO TO 190 -* -* Order eigenvalues and eigenvectors. -* - 160 CONTINUE - IF( ICOMPZ.EQ.0 ) THEN -* -* Use Quick Sort -* - CALL DLASRT( 'I', N, D, INFO ) -* - ELSE -* -* Use Selection Sort to minimize swaps of eigenvectors -* - DO 180 II = 2, N - I = II - 1 - K = I - P = D( I ) - DO 170 J = II, N - IF( D( J ).LT.P ) THEN - K = J - P = D( J ) - END IF - 170 CONTINUE - IF( K.NE.I ) THEN - D( K ) = D( I ) - D( I ) = P - CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) - END IF - 180 CONTINUE - END IF -* - 190 CONTINUE - RETURN -* -* End of DSTEQR -* - END diff --git a/lib/linalg/dsterf.cpp b/lib/linalg/dsterf.cpp new file mode 100644 index 0000000000..438cc47dc3 --- /dev/null +++ b/lib/linalg/dsterf.cpp @@ -0,0 +1,286 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__0 = 0; +static integer c__1 = 1; +static doublereal c_b33 = 1.; +int dsterf_(integer *n, doublereal *d__, doublereal *e, integer *info) +{ + integer i__1; + doublereal d__1, d__2, d__3; + double sqrt(doublereal), d_lmp_sign(doublereal *, doublereal *); + doublereal c__; + integer i__, l, m; + doublereal p, r__, s; + integer l1; + doublereal bb, rt1, rt2, eps, rte; + integer lsv; + doublereal eps2, oldc; + integer lend; + doublereal rmax; + integer jtot; + extern int dlae2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *); + doublereal gamma, alpha, sigma, anorm; + extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, ftnlen); + integer iscale; + extern int dlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, + integer *, doublereal *, integer *, integer *, ftnlen); + doublereal oldgam, safmin; + extern int xerbla_(char *, integer *, ftnlen); + doublereal safmax; + extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *, ftnlen); + extern int dlasrt_(char *, integer *, doublereal *, integer *, ftnlen); + integer lendsv; + doublereal ssfmin; + integer nmaxit; + doublereal ssfmax; + --e; + --d__; + *info = 0; + if (*n < 0) { + *info = -1; + i__1 = -(*info); + xerbla_((char *)"DSTERF", &i__1, (ftnlen)6); + return 0; + } + if (*n <= 1) { + return 0; + } + eps = dlamch_((char *)"E", (ftnlen)1); + d__1 = eps; + eps2 = d__1 * d__1; + safmin = dlamch_((char *)"S", (ftnlen)1); + safmax = 1. / safmin; + ssfmax = sqrt(safmax) / 3.; + ssfmin = sqrt(safmin) / eps2; + rmax = dlamch_((char *)"O", (ftnlen)1); + nmaxit = *n * 30; + sigma = 0.; + jtot = 0; + l1 = 1; +L10: + if (l1 > *n) { + goto L170; + } + if (l1 > 1) { + e[l1 - 1] = 0.; + } + i__1 = *n - 1; + for (m = l1; m <= i__1; ++m) { + if ((d__3 = e[m], abs(d__3)) <= + sqrt((d__1 = d__[m], abs(d__1))) * sqrt((d__2 = d__[m + 1], abs(d__2))) * eps) { + e[m] = 0.; + goto L30; + } + } + m = *n; +L30: + l = l1; + lsv = l; + lend = m; + lendsv = lend; + l1 = m + 1; + if (lend == l) { + goto L10; + } + i__1 = lend - l + 1; + anorm = dlanst_((char *)"M", &i__1, &d__[l], &e[l], (ftnlen)1); + iscale = 0; + if (anorm == 0.) { + goto L10; + } + if (anorm > ssfmax) { + iscale = 1; + i__1 = lend - l + 1; + dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n, info, (ftnlen)1); + i__1 = lend - l; + dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n, info, (ftnlen)1); + } else if (anorm < ssfmin) { + iscale = 2; + i__1 = lend - l + 1; + dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n, info, (ftnlen)1); + i__1 = lend - l; + dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n, info, (ftnlen)1); + } + i__1 = lend - 1; + for (i__ = l; i__ <= i__1; ++i__) { + d__1 = e[i__]; + e[i__] = d__1 * d__1; + } + if ((d__1 = d__[lend], abs(d__1)) < (d__2 = d__[l], abs(d__2))) { + lend = lsv; + l = lendsv; + } + if (lend >= l) { + L50: + if (l != lend) { + i__1 = lend - 1; + for (m = l; m <= i__1; ++m) { + if ((d__2 = e[m], abs(d__2)) <= eps2 * (d__1 = d__[m] * d__[m + 1], abs(d__1))) { + goto L70; + } + } + } + m = lend; + L70: + if (m < lend) { + e[m] = 0.; + } + p = d__[l]; + if (m == l) { + goto L90; + } + if (m == l + 1) { + rte = sqrt(e[l]); + dlae2_(&d__[l], &rte, &d__[l + 1], &rt1, &rt2); + d__[l] = rt1; + d__[l + 1] = rt2; + e[l] = 0.; + l += 2; + if (l <= lend) { + goto L50; + } + goto L150; + } + if (jtot == nmaxit) { + goto L150; + } + ++jtot; + rte = sqrt(e[l]); + sigma = (d__[l + 1] - p) / (rte * 2.); + r__ = dlapy2_(&sigma, &c_b33); + sigma = p - rte / (sigma + d_lmp_sign(&r__, &sigma)); + c__ = 1.; + s = 0.; + gamma = d__[m] - sigma; + p = gamma * gamma; + i__1 = l; + for (i__ = m - 1; i__ >= i__1; --i__) { + bb = e[i__]; + r__ = p + bb; + if (i__ != m - 1) { + e[i__ + 1] = s * r__; + } + oldc = c__; + c__ = p / r__; + s = bb / r__; + oldgam = gamma; + alpha = d__[i__]; + gamma = c__ * (alpha - sigma) - s * oldgam; + d__[i__ + 1] = oldgam + (alpha - gamma); + if (c__ != 0.) { + p = gamma * gamma / c__; + } else { + p = oldc * bb; + } + } + e[l] = s * p; + d__[l] = sigma + gamma; + goto L50; + L90: + d__[l] = p; + ++l; + if (l <= lend) { + goto L50; + } + goto L150; + } else { + L100: + i__1 = lend + 1; + for (m = l; m >= i__1; --m) { + if ((d__2 = e[m - 1], abs(d__2)) <= eps2 * (d__1 = d__[m] * d__[m - 1], abs(d__1))) { + goto L120; + } + } + m = lend; + L120: + if (m > lend) { + e[m - 1] = 0.; + } + p = d__[l]; + if (m == l) { + goto L140; + } + if (m == l - 1) { + rte = sqrt(e[l - 1]); + dlae2_(&d__[l], &rte, &d__[l - 1], &rt1, &rt2); + d__[l] = rt1; + d__[l - 1] = rt2; + e[l - 1] = 0.; + l += -2; + if (l >= lend) { + goto L100; + } + goto L150; + } + if (jtot == nmaxit) { + goto L150; + } + ++jtot; + rte = sqrt(e[l - 1]); + sigma = (d__[l - 1] - p) / (rte * 2.); + r__ = dlapy2_(&sigma, &c_b33); + sigma = p - rte / (sigma + d_lmp_sign(&r__, &sigma)); + c__ = 1.; + s = 0.; + gamma = d__[m] - sigma; + p = gamma * gamma; + i__1 = l - 1; + for (i__ = m; i__ <= i__1; ++i__) { + bb = e[i__]; + r__ = p + bb; + if (i__ != m) { + e[i__ - 1] = s * r__; + } + oldc = c__; + c__ = p / r__; + s = bb / r__; + oldgam = gamma; + alpha = d__[i__ + 1]; + gamma = c__ * (alpha - sigma) - s * oldgam; + d__[i__] = oldgam + (alpha - gamma); + if (c__ != 0.) { + p = gamma * gamma / c__; + } else { + p = oldc * bb; + } + } + e[l - 1] = s * p; + d__[l] = sigma + gamma; + goto L100; + L140: + d__[l] = p; + --l; + if (l >= lend) { + goto L100; + } + goto L150; + } +L150: + if (iscale == 1) { + i__1 = lendsv - lsv + 1; + dlascl_((char *)"G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv], n, info, (ftnlen)1); + } + if (iscale == 2) { + i__1 = lendsv - lsv + 1; + dlascl_((char *)"G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv], n, info, (ftnlen)1); + } + if (jtot < nmaxit) { + goto L10; + } + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + if (e[i__] != 0.) { + ++(*info); + } + } + goto L180; +L170: + dlasrt_((char *)"I", n, &d__[1], info, (ftnlen)1); +L180: + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dsterf.f b/lib/linalg/dsterf.f deleted file mode 100644 index b0f8d36084..0000000000 --- a/lib/linalg/dsterf.f +++ /dev/null @@ -1,423 +0,0 @@ -*> \brief \b DSTERF -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DSTERF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DSTERF( N, D, E, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION D( * ), E( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSTERF computes all eigenvalues of a symmetric tridiagonal matrix -*> using the Pal-Walker-Kahan variant of the QL or QR algorithm. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix. N >= 0. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, the n diagonal elements of the tridiagonal matrix. -*> On exit, if INFO = 0, the eigenvalues in ascending order. -*> \endverbatim -*> -*> \param[in,out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N-1) -*> On entry, the (n-1) subdiagonal elements of the tridiagonal -*> matrix. -*> On exit, E has been destroyed. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> > 0: the algorithm failed to find all of the eigenvalues in -*> a total of 30*N iterations; if INFO = i, then i -*> elements of E have not converged to zero. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup auxOTHERcomputational -* -* ===================================================================== - SUBROUTINE DSTERF( N, D, E, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), E( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ THREE = 3.0D0 ) - INTEGER MAXIT - PARAMETER ( MAXIT = 30 ) -* .. -* .. Local Scalars .. - INTEGER I, ISCALE, JTOT, L, L1, LEND, LENDSV, LSV, M, - $ NMAXIT - DOUBLE PRECISION ALPHA, ANORM, BB, C, EPS, EPS2, GAMMA, OLDC, - $ OLDGAM, P, R, RT1, RT2, RTE, S, SAFMAX, SAFMIN, - $ SIGMA, SSFMAX, SSFMIN, RMAX -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANST, DLAPY2 - EXTERNAL DLAMCH, DLANST, DLAPY2 -* .. -* .. External Subroutines .. - EXTERNAL DLAE2, DLASCL, DLASRT, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SIGN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* -* Quick return if possible -* - IF( N.LT.0 ) THEN - INFO = -1 - CALL XERBLA( 'DSTERF', -INFO ) - RETURN - END IF - IF( N.LE.1 ) - $ RETURN -* -* Determine the unit roundoff for this environment. -* - EPS = DLAMCH( 'E' ) - EPS2 = EPS**2 - SAFMIN = DLAMCH( 'S' ) - SAFMAX = ONE / SAFMIN - SSFMAX = SQRT( SAFMAX ) / THREE - SSFMIN = SQRT( SAFMIN ) / EPS2 - RMAX = DLAMCH( 'O' ) -* -* Compute the eigenvalues of the tridiagonal matrix. -* - NMAXIT = N*MAXIT - SIGMA = ZERO - JTOT = 0 -* -* Determine where the matrix splits and choose QL or QR iteration -* for each block, according to whether top or bottom diagonal -* element is smaller. -* - L1 = 1 -* - 10 CONTINUE - IF( L1.GT.N ) - $ GO TO 170 - IF( L1.GT.1 ) - $ E( L1-1 ) = ZERO - DO 20 M = L1, N - 1 - IF( ABS( E( M ) ).LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ - $ 1 ) ) ) )*EPS ) THEN - E( M ) = ZERO - GO TO 30 - END IF - 20 CONTINUE - M = N -* - 30 CONTINUE - L = L1 - LSV = L - LEND = M - LENDSV = LEND - L1 = M + 1 - IF( LEND.EQ.L ) - $ GO TO 10 -* -* Scale submatrix in rows and columns L to LEND -* - ANORM = DLANST( 'M', LEND-L+1, D( L ), E( L ) ) - ISCALE = 0 - IF( ANORM.EQ.ZERO ) - $ GO TO 10 - IF( (ANORM.GT.SSFMAX) ) THEN - ISCALE = 1 - CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, - $ INFO ) - CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, - $ INFO ) - ELSE IF( ANORM.LT.SSFMIN ) THEN - ISCALE = 2 - CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, - $ INFO ) - CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, - $ INFO ) - END IF -* - DO 40 I = L, LEND - 1 - E( I ) = E( I )**2 - 40 CONTINUE -* -* Choose between QL and QR iteration -* - IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN - LEND = LSV - L = LENDSV - END IF -* - IF( LEND.GE.L ) THEN -* -* QL Iteration -* -* Look for small subdiagonal element. -* - 50 CONTINUE - IF( L.NE.LEND ) THEN - DO 60 M = L, LEND - 1 - IF( ABS( E( M ) ).LE.EPS2*ABS( D( M )*D( M+1 ) ) ) - $ GO TO 70 - 60 CONTINUE - END IF - M = LEND -* - 70 CONTINUE - IF( M.LT.LEND ) - $ E( M ) = ZERO - P = D( L ) - IF( M.EQ.L ) - $ GO TO 90 -* -* If remaining matrix is 2 by 2, use DLAE2 to compute its -* eigenvalues. -* - IF( M.EQ.L+1 ) THEN - RTE = SQRT( E( L ) ) - CALL DLAE2( D( L ), RTE, D( L+1 ), RT1, RT2 ) - D( L ) = RT1 - D( L+1 ) = RT2 - E( L ) = ZERO - L = L + 2 - IF( L.LE.LEND ) - $ GO TO 50 - GO TO 150 - END IF -* - IF( JTOT.EQ.NMAXIT ) - $ GO TO 150 - JTOT = JTOT + 1 -* -* Form shift. -* - RTE = SQRT( E( L ) ) - SIGMA = ( D( L+1 )-P ) / ( TWO*RTE ) - R = DLAPY2( SIGMA, ONE ) - SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) ) -* - C = ONE - S = ZERO - GAMMA = D( M ) - SIGMA - P = GAMMA*GAMMA -* -* Inner loop -* - DO 80 I = M - 1, L, -1 - BB = E( I ) - R = P + BB - IF( I.NE.M-1 ) - $ E( I+1 ) = S*R - OLDC = C - C = P / R - S = BB / R - OLDGAM = GAMMA - ALPHA = D( I ) - GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM - D( I+1 ) = OLDGAM + ( ALPHA-GAMMA ) - IF( C.NE.ZERO ) THEN - P = ( GAMMA*GAMMA ) / C - ELSE - P = OLDC*BB - END IF - 80 CONTINUE -* - E( L ) = S*P - D( L ) = SIGMA + GAMMA - GO TO 50 -* -* Eigenvalue found. -* - 90 CONTINUE - D( L ) = P -* - L = L + 1 - IF( L.LE.LEND ) - $ GO TO 50 - GO TO 150 -* - ELSE -* -* QR Iteration -* -* Look for small superdiagonal element. -* - 100 CONTINUE - DO 110 M = L, LEND + 1, -1 - IF( ABS( E( M-1 ) ).LE.EPS2*ABS( D( M )*D( M-1 ) ) ) - $ GO TO 120 - 110 CONTINUE - M = LEND -* - 120 CONTINUE - IF( M.GT.LEND ) - $ E( M-1 ) = ZERO - P = D( L ) - IF( M.EQ.L ) - $ GO TO 140 -* -* If remaining matrix is 2 by 2, use DLAE2 to compute its -* eigenvalues. -* - IF( M.EQ.L-1 ) THEN - RTE = SQRT( E( L-1 ) ) - CALL DLAE2( D( L ), RTE, D( L-1 ), RT1, RT2 ) - D( L ) = RT1 - D( L-1 ) = RT2 - E( L-1 ) = ZERO - L = L - 2 - IF( L.GE.LEND ) - $ GO TO 100 - GO TO 150 - END IF -* - IF( JTOT.EQ.NMAXIT ) - $ GO TO 150 - JTOT = JTOT + 1 -* -* Form shift. -* - RTE = SQRT( E( L-1 ) ) - SIGMA = ( D( L-1 )-P ) / ( TWO*RTE ) - R = DLAPY2( SIGMA, ONE ) - SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) ) -* - C = ONE - S = ZERO - GAMMA = D( M ) - SIGMA - P = GAMMA*GAMMA -* -* Inner loop -* - DO 130 I = M, L - 1 - BB = E( I ) - R = P + BB - IF( I.NE.M ) - $ E( I-1 ) = S*R - OLDC = C - C = P / R - S = BB / R - OLDGAM = GAMMA - ALPHA = D( I+1 ) - GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM - D( I ) = OLDGAM + ( ALPHA-GAMMA ) - IF( C.NE.ZERO ) THEN - P = ( GAMMA*GAMMA ) / C - ELSE - P = OLDC*BB - END IF - 130 CONTINUE -* - E( L-1 ) = S*P - D( L ) = SIGMA + GAMMA - GO TO 100 -* -* Eigenvalue found. -* - 140 CONTINUE - D( L ) = P -* - L = L - 1 - IF( L.GE.LEND ) - $ GO TO 100 - GO TO 150 -* - END IF -* -* Undo scaling if necessary -* - 150 CONTINUE - IF( ISCALE.EQ.1 ) - $ CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, - $ D( LSV ), N, INFO ) - IF( ISCALE.EQ.2 ) - $ CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, - $ D( LSV ), N, INFO ) -* -* Check for no convergence to an eigenvalue after a total -* of N*MAXIT iterations. -* - IF( JTOT.LT.NMAXIT ) - $ GO TO 10 - DO 160 I = 1, N - 1 - IF( E( I ).NE.ZERO ) - $ INFO = INFO + 1 - 160 CONTINUE - GO TO 180 -* -* Sort eigenvalues in increasing order. -* - 170 CONTINUE - CALL DLASRT( 'I', N, D, INFO ) -* - 180 CONTINUE - RETURN -* -* End of DSTERF -* - END diff --git a/lib/linalg/dswap.cpp b/lib/linalg/dswap.cpp new file mode 100644 index 0000000000..e3b98c9151 --- /dev/null +++ b/lib/linalg/dswap.cpp @@ -0,0 +1,63 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dswap_(integer *n, doublereal *dx, integer *incx, doublereal *dy, integer *incy) +{ + integer i__1; + integer i__, m, ix, iy, mp1; + doublereal dtemp; + --dy; + --dx; + if (*n <= 0) { + return 0; + } + if (*incx == 1 && *incy == 1) { + m = *n % 3; + if (m != 0) { + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + dtemp = dx[i__]; + dx[i__] = dy[i__]; + dy[i__] = dtemp; + } + if (*n < 3) { + return 0; + } + } + mp1 = m + 1; + i__1 = *n; + for (i__ = mp1; i__ <= i__1; i__ += 3) { + dtemp = dx[i__]; + dx[i__] = dy[i__]; + dy[i__] = dtemp; + dtemp = dx[i__ + 1]; + dx[i__ + 1] = dy[i__ + 1]; + dy[i__ + 1] = dtemp; + dtemp = dx[i__ + 2]; + dx[i__ + 2] = dy[i__ + 2]; + dy[i__ + 2] = dtemp; + } + } 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__) { + dtemp = dx[ix]; + dx[ix] = dy[iy]; + dy[iy] = dtemp; + ix += *incx; + iy += *incy; + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dswap.f b/lib/linalg/dswap.f deleted file mode 100644 index b7600aa2d4..0000000000 --- a/lib/linalg/dswap.f +++ /dev/null @@ -1,153 +0,0 @@ -*> \brief \b DSWAP -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) -* -* .. Scalar Arguments .. -* INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION DX(*),DY(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSWAP interchanges two vectors. -*> uses unrolled loops for increments equal to 1. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> number of elements in input vector(s) -*> \endverbatim -*> -*> \param[in,out] DX -*> \verbatim -*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> storage spacing between elements of DX -*> \endverbatim -*> -*> \param[in,out] DY -*> \verbatim -*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> storage spacing between elements of DY -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level1 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> jack dongarra, linpack, 3/11/78. -*> modified 12/3/93, array(1) declarations changed to array(*) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*),DY(*) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - DOUBLE PRECISION DTEMP - INTEGER I,IX,IY,M,MP1 -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. - IF (N.LE.0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 -* -* -* clean-up loop -* - M = MOD(N,3) - IF (M.NE.0) THEN - DO I = 1,M - DTEMP = DX(I) - DX(I) = DY(I) - DY(I) = DTEMP - END DO - IF (N.LT.3) RETURN - END IF - MP1 = M + 1 - DO I = MP1,N,3 - DTEMP = DX(I) - DX(I) = DY(I) - DY(I) = DTEMP - DTEMP = DX(I+1) - DX(I+1) = DY(I+1) - DY(I+1) = DTEMP - DTEMP = DX(I+2) - DX(I+2) = DY(I+2) - DY(I+2) = DTEMP - END DO - ELSE -* -* code for unequal increments or equal increments not equal -* to 1 -* - IX = 1 - IY = 1 - IF (INCX.LT.0) IX = (-N+1)*INCX + 1 - IF (INCY.LT.0) IY = (-N+1)*INCY + 1 - DO I = 1,N - DTEMP = DX(IX) - DX(IX) = DY(IY) - DY(IY) = DTEMP - IX = IX + INCX - IY = IY + INCY - END DO - END IF - RETURN -* -* End of DSWAP -* - END diff --git a/lib/linalg/dsyev.cpp b/lib/linalg/dsyev.cpp new file mode 100644 index 0000000000..ccbdd9e998 --- /dev/null +++ b/lib/linalg/dsyev.cpp @@ -0,0 +1,141 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +static integer c_n1 = -1; +static integer c__0 = 0; +static doublereal c_b17 = 1.; +int dsyev_(char *jobz, char *uplo, integer *n, doublereal *a, integer *lda, doublereal *w, + doublereal *work, integer *lwork, integer *info, ftnlen jobz_len, ftnlen uplo_len) +{ + integer a_dim1, a_offset, i__1, i__2; + doublereal d__1; + double sqrt(doublereal); + integer nb; + doublereal eps; + integer inde; + doublereal anrm; + integer imax; + doublereal rmin, rmax; + extern int dscal_(integer *, doublereal *, doublereal *, integer *); + doublereal sigma; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + integer iinfo; + logical lower, wantz; + extern doublereal dlamch_(char *, ftnlen); + integer iscale; + extern int dlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, + integer *, doublereal *, integer *, integer *, ftnlen); + doublereal safmin; + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, + ftnlen, ftnlen); + extern int xerbla_(char *, integer *, ftnlen); + doublereal bignum; + integer indtau; + extern int dsterf_(integer *, doublereal *, doublereal *, integer *); + extern doublereal dlansy_(char *, char *, integer *, doublereal *, integer *, doublereal *, + ftnlen, ftnlen); + integer indwrk; + extern int dorgtr_(char *, integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *, integer *, ftnlen), + dsteqr_(char *, integer *, doublereal *, doublereal *, doublereal *, integer *, + doublereal *, integer *, ftnlen), + dsytrd_(char *, integer *, doublereal *, integer *, doublereal *, doublereal *, + doublereal *, doublereal *, integer *, integer *, ftnlen); + integer llwork; + doublereal smlnum; + integer lwkopt; + logical lquery; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --w; + --work; + wantz = lsame_(jobz, (char *)"V", (ftnlen)1, (ftnlen)1); + lower = lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1); + lquery = *lwork == -1; + *info = 0; + if (!(wantz || lsame_(jobz, (char *)"N", (ftnlen)1, (ftnlen)1))) { + *info = -1; + } else if (!(lower || lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1))) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < max(1, *n)) { + *info = -5; + } + if (*info == 0) { + nb = ilaenv_(&c__1, (char *)"DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); + i__1 = 1, i__2 = (nb + 2) * *n; + lwkopt = max(i__1, i__2); + work[1] = (doublereal)lwkopt; + i__1 = 1, i__2 = *n * 3 - 1; + if (*lwork < max(i__1, i__2) && !lquery) { + *info = -8; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DSYEV ", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + if (*n == 0) { + return 0; + } + if (*n == 1) { + w[1] = a[a_dim1 + 1]; + work[1] = 2.; + if (wantz) { + a[a_dim1 + 1] = 1.; + } + return 0; + } + safmin = dlamch_((char *)"Safe minimum", (ftnlen)12); + eps = dlamch_((char *)"Precision", (ftnlen)9); + smlnum = safmin / eps; + bignum = 1. / smlnum; + rmin = sqrt(smlnum); + rmax = sqrt(bignum); + anrm = dlansy_((char *)"M", uplo, n, &a[a_offset], lda, &work[1], (ftnlen)1, (ftnlen)1); + iscale = 0; + if (anrm > 0. && anrm < rmin) { + iscale = 1; + sigma = rmin / anrm; + } else if (anrm > rmax) { + iscale = 1; + sigma = rmax / anrm; + } + if (iscale == 1) { + dlascl_(uplo, &c__0, &c__0, &c_b17, &sigma, n, n, &a[a_offset], lda, info, (ftnlen)1); + } + inde = 1; + indtau = inde + *n; + indwrk = indtau + *n; + llwork = *lwork - indwrk + 1; + dsytrd_(uplo, n, &a[a_offset], lda, &w[1], &work[inde], &work[indtau], &work[indwrk], &llwork, + &iinfo, (ftnlen)1); + if (!wantz) { + dsterf_(n, &w[1], &work[inde], info); + } else { + dorgtr_(uplo, n, &a[a_offset], lda, &work[indtau], &work[indwrk], &llwork, &iinfo, + (ftnlen)1); + dsteqr_(jobz, n, &w[1], &work[inde], &a[a_offset], lda, &work[indtau], info, (ftnlen)1); + } + if (iscale == 1) { + if (*info == 0) { + imax = *n; + } else { + imax = *info - 1; + } + d__1 = 1. / sigma; + dscal_(&imax, &d__1, &w[1], &c__1); + } + work[1] = (doublereal)lwkopt; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dsyev.f b/lib/linalg/dsyev.f deleted file mode 100644 index da7557ee02..0000000000 --- a/lib/linalg/dsyev.f +++ /dev/null @@ -1,283 +0,0 @@ -*> \brief DSYEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DSYEV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER JOBZ, UPLO -* INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSYEV computes all eigenvalues and, optionally, eigenvectors of a -*> real symmetric matrix A. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] JOBZ -*> \verbatim -*> JOBZ is CHARACTER*1 -*> = 'N': Compute eigenvalues only; -*> = 'V': Compute eigenvalues and eigenvectors. -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A is stored; -*> = 'L': Lower triangle of A is stored. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA, N) -*> On entry, the symmetric matrix A. If UPLO = 'U', the -*> leading N-by-N upper triangular part of A contains the -*> upper triangular part of the matrix A. If UPLO = 'L', -*> the leading N-by-N lower triangular part of A contains -*> the lower triangular part of the matrix A. -*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the -*> orthonormal eigenvectors of the matrix A. -*> If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') -*> or the upper triangle (if UPLO='U') of A, including the -*> diagonal, is destroyed. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[out] W -*> \verbatim -*> W is DOUBLE PRECISION array, dimension (N) -*> If INFO = 0, the eigenvalues in ascending order. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The length of the array WORK. LWORK >= max(1,3*N-1). -*> For optimal efficiency, LWORK >= (NB+2)*N, -*> where NB is the blocksize for DSYTRD returned by ILAENV. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal size of the WORK array, returns -*> this value as the first entry of the WORK array, and no error -*> message related to LWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> > 0: if INFO = i, the algorithm failed to converge; i -*> off-diagonal elements of an intermediate tridiagonal -*> form did not converge to zero. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleSYeigen -* -* ===================================================================== - SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) -* -* -- LAPACK driver routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER JOBZ, UPLO - INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL LOWER, LQUERY, WANTZ - INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, - $ LLWORK, LWKOPT, NB - DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, - $ SMLNUM -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANSY - EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY -* .. -* .. External Subroutines .. - EXTERNAL DLASCL, DORGTR, DSCAL, DSTEQR, DSTERF, DSYTRD, - $ XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - WANTZ = LSAME( JOBZ, 'V' ) - LOWER = LSAME( UPLO, 'L' ) - LQUERY = ( LWORK.EQ.-1 ) -* - INFO = 0 - IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF -* - IF( INFO.EQ.0 ) THEN - NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) - LWKOPT = MAX( 1, ( NB+2 )*N ) - WORK( 1 ) = LWKOPT -* - IF( LWORK.LT.MAX( 1, 3*N-1 ) .AND. .NOT.LQUERY ) - $ INFO = -8 - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSYEV ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) THEN - RETURN - END IF -* - IF( N.EQ.1 ) THEN - W( 1 ) = A( 1, 1 ) - WORK( 1 ) = 2 - IF( WANTZ ) - $ A( 1, 1 ) = ONE - RETURN - END IF -* -* Get machine constants. -* - SAFMIN = DLAMCH( 'Safe minimum' ) - EPS = DLAMCH( 'Precision' ) - SMLNUM = SAFMIN / EPS - BIGNUM = ONE / SMLNUM - RMIN = SQRT( SMLNUM ) - RMAX = SQRT( BIGNUM ) -* -* Scale matrix to allowable range, if necessary. -* - ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) - ISCALE = 0 - IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN - ISCALE = 1 - SIGMA = RMIN / ANRM - ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 - SIGMA = RMAX / ANRM - END IF - IF( ISCALE.EQ.1 ) - $ CALL DLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) -* -* Call DSYTRD to reduce symmetric matrix to tridiagonal form. -* - INDE = 1 - INDTAU = INDE + N - INDWRK = INDTAU + N - LLWORK = LWORK - INDWRK + 1 - CALL DSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ), - $ WORK( INDWRK ), LLWORK, IINFO ) -* -* For eigenvalues only, call DSTERF. For eigenvectors, first call -* DORGTR to generate the orthogonal matrix, then call DSTEQR. -* - IF( .NOT.WANTZ ) THEN - CALL DSTERF( N, W, WORK( INDE ), INFO ) - ELSE - CALL DORGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ), - $ LLWORK, IINFO ) - CALL DSTEQR( JOBZ, N, W, WORK( INDE ), A, LDA, WORK( INDTAU ), - $ INFO ) - END IF -* -* If matrix was scaled, then rescale eigenvalues appropriately. -* - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = N - ELSE - IMAX = INFO - 1 - END IF - CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF -* -* Set WORK(1) to optimal workspace size. -* - WORK( 1 ) = LWKOPT -* - RETURN -* -* End of DSYEV -* - END diff --git a/lib/linalg/dsyevd.cpp b/lib/linalg/dsyevd.cpp new file mode 100644 index 0000000000..5c02bc14da --- /dev/null +++ b/lib/linalg/dsyevd.cpp @@ -0,0 +1,161 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +static integer c_n1 = -1; +static integer c__0 = 0; +static doublereal c_b17 = 1.; +int dsyevd_(char *jobz, char *uplo, integer *n, doublereal *a, integer *lda, doublereal *w, + doublereal *work, integer *lwork, integer *iwork, integer *liwork, integer *info, + ftnlen jobz_len, ftnlen uplo_len) +{ + integer a_dim1, a_offset, i__1, i__2; + doublereal d__1; + double sqrt(doublereal); + doublereal eps; + integer inde; + doublereal anrm, rmin, rmax; + integer lopt; + extern int dscal_(integer *, doublereal *, doublereal *, integer *); + doublereal sigma; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + integer iinfo, lwmin, liopt; + logical lower, wantz; + integer indwk2, llwrk2; + extern doublereal dlamch_(char *, ftnlen); + integer iscale; + extern int dlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, + integer *, doublereal *, integer *, integer *, ftnlen), + dstedc_(char *, integer *, doublereal *, doublereal *, doublereal *, integer *, + doublereal *, integer *, integer *, integer *, integer *, ftnlen), + dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *, + ftnlen); + doublereal safmin; + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, + ftnlen, ftnlen); + extern int xerbla_(char *, integer *, ftnlen); + doublereal bignum; + integer indtau; + extern int dsterf_(integer *, doublereal *, doublereal *, integer *); + extern doublereal dlansy_(char *, char *, integer *, doublereal *, integer *, doublereal *, + ftnlen, ftnlen); + integer indwrk, liwmin; + extern int dormtr_(char *, char *, char *, integer *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, integer *, + ftnlen, ftnlen, ftnlen), + dsytrd_(char *, integer *, doublereal *, integer *, doublereal *, doublereal *, + doublereal *, doublereal *, integer *, integer *, ftnlen); + integer llwork; + doublereal smlnum; + logical lquery; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --w; + --work; + --iwork; + wantz = lsame_(jobz, (char *)"V", (ftnlen)1, (ftnlen)1); + lower = lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1); + lquery = *lwork == -1 || *liwork == -1; + *info = 0; + if (!(wantz || lsame_(jobz, (char *)"N", (ftnlen)1, (ftnlen)1))) { + *info = -1; + } else if (!(lower || lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1))) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < max(1, *n)) { + *info = -5; + } + if (*info == 0) { + if (*n <= 1) { + liwmin = 1; + lwmin = 1; + lopt = lwmin; + liopt = liwmin; + } else { + if (wantz) { + liwmin = *n * 5 + 3; + i__1 = *n; + lwmin = *n * 6 + 1 + (i__1 * i__1 << 1); + } else { + liwmin = 1; + lwmin = (*n << 1) + 1; + } + i__1 = lwmin, i__2 = (*n << 1) + *n * ilaenv_(&c__1, (char *)"DSYTRD", uplo, n, &c_n1, &c_n1, + &c_n1, (ftnlen)6, (ftnlen)1); + lopt = max(i__1, i__2); + liopt = liwmin; + } + work[1] = (doublereal)lopt; + iwork[1] = liopt; + if (*lwork < lwmin && !lquery) { + *info = -8; + } else if (*liwork < liwmin && !lquery) { + *info = -10; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DSYEVD", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + if (*n == 0) { + return 0; + } + if (*n == 1) { + w[1] = a[a_dim1 + 1]; + if (wantz) { + a[a_dim1 + 1] = 1.; + } + return 0; + } + safmin = dlamch_((char *)"Safe minimum", (ftnlen)12); + eps = dlamch_((char *)"Precision", (ftnlen)9); + smlnum = safmin / eps; + bignum = 1. / smlnum; + rmin = sqrt(smlnum); + rmax = sqrt(bignum); + anrm = dlansy_((char *)"M", uplo, n, &a[a_offset], lda, &work[1], (ftnlen)1, (ftnlen)1); + iscale = 0; + if (anrm > 0. && anrm < rmin) { + iscale = 1; + sigma = rmin / anrm; + } else if (anrm > rmax) { + iscale = 1; + sigma = rmax / anrm; + } + if (iscale == 1) { + dlascl_(uplo, &c__0, &c__0, &c_b17, &sigma, n, n, &a[a_offset], lda, info, (ftnlen)1); + } + inde = 1; + indtau = inde + *n; + indwrk = indtau + *n; + llwork = *lwork - indwrk + 1; + indwk2 = indwrk + *n * *n; + llwrk2 = *lwork - indwk2 + 1; + dsytrd_(uplo, n, &a[a_offset], lda, &w[1], &work[inde], &work[indtau], &work[indwrk], &llwork, + &iinfo, (ftnlen)1); + if (!wantz) { + dsterf_(n, &w[1], &work[inde], info); + } else { + dstedc_((char *)"I", n, &w[1], &work[inde], &work[indwrk], n, &work[indwk2], &llwrk2, &iwork[1], + liwork, info, (ftnlen)1); + dormtr_((char *)"L", uplo, (char *)"N", n, n, &a[a_offset], lda, &work[indtau], &work[indwrk], n, + &work[indwk2], &llwrk2, &iinfo, (ftnlen)1, (ftnlen)1, (ftnlen)1); + dlacpy_((char *)"A", n, n, &work[indwrk], n, &a[a_offset], lda, (ftnlen)1); + } + if (iscale == 1) { + d__1 = 1. / sigma; + dscal_(n, &d__1, &w[1], &c__1); + } + work[1] = (doublereal)lopt; + iwork[1] = liopt; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dsyevd.f b/lib/linalg/dsyevd.f deleted file mode 100644 index eaaecd8d98..0000000000 --- a/lib/linalg/dsyevd.f +++ /dev/null @@ -1,354 +0,0 @@ -*> \brief DSYEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DSYEVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, -* LIWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER JOBZ, UPLO -* INTEGER INFO, LDA, LIWORK, LWORK, N -* .. -* .. Array Arguments .. -* INTEGER IWORK( * ) -* DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSYEVD computes all eigenvalues and, optionally, eigenvectors of a -*> real symmetric matrix A. If eigenvectors are desired, it uses a -*> divide and conquer algorithm. -*> -*> The divide and conquer algorithm makes very mild assumptions about -*> floating point arithmetic. It will work on machines with a guard -*> digit in add/subtract, or on those binary machines without guard -*> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or -*> Cray-2. It could conceivably fail on hexadecimal or decimal machines -*> without guard digits, but we know of none. -*> -*> Because of large use of BLAS of level 3, DSYEVD needs N**2 more -*> workspace than DSYEVX. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] JOBZ -*> \verbatim -*> JOBZ is CHARACTER*1 -*> = 'N': Compute eigenvalues only; -*> = 'V': Compute eigenvalues and eigenvectors. -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A is stored; -*> = 'L': Lower triangle of A is stored. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA, N) -*> On entry, the symmetric matrix A. If UPLO = 'U', the -*> leading N-by-N upper triangular part of A contains the -*> upper triangular part of the matrix A. If UPLO = 'L', -*> the leading N-by-N lower triangular part of A contains -*> the lower triangular part of the matrix A. -*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the -*> orthonormal eigenvectors of the matrix A. -*> If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') -*> or the upper triangle (if UPLO='U') of A, including the -*> diagonal, is destroyed. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[out] W -*> \verbatim -*> W is DOUBLE PRECISION array, dimension (N) -*> If INFO = 0, the eigenvalues in ascending order. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, -*> dimension (LWORK) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. -*> If N <= 1, LWORK must be at least 1. -*> If JOBZ = 'N' and N > 1, LWORK must be at least 2*N+1. -*> If JOBZ = 'V' and N > 1, LWORK must be at least -*> 1 + 6*N + 2*N**2. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal sizes of the WORK and IWORK -*> arrays, returns these values as the first entries of the WORK -*> and IWORK arrays, and no error message related to LWORK or -*> LIWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) -*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. -*> \endverbatim -*> -*> \param[in] LIWORK -*> \verbatim -*> LIWORK is INTEGER -*> The dimension of the array IWORK. -*> If N <= 1, LIWORK must be at least 1. -*> If JOBZ = 'N' and N > 1, LIWORK must be at least 1. -*> If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. -*> -*> If LIWORK = -1, then a workspace query is assumed; the -*> routine only calculates the optimal sizes of the WORK and -*> IWORK arrays, returns these values as the first entries of -*> the WORK and IWORK arrays, and no error message related to -*> LWORK or LIWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> > 0: if INFO = i and JOBZ = 'N', then the algorithm failed -*> to converge; i off-diagonal elements of an intermediate -*> tridiagonal form did not converge to zero; -*> if INFO = i and JOBZ = 'V', then the algorithm failed -*> to compute an eigenvalue while working on the submatrix -*> lying in rows and columns INFO/(N+1) through -*> mod(INFO,N+1). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleSYeigen -* -*> \par Contributors: -* ================== -*> -*> Jeff Rutter, Computer Science Division, University of California -*> at Berkeley, USA \n -*> Modified by Francoise Tisseur, University of Tennessee \n -*> Modified description of INFO. Sven, 16 Feb 05. \n - - -*> -* ===================================================================== - SUBROUTINE DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, - $ LIWORK, INFO ) -* -* -- LAPACK driver routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER JOBZ, UPLO - INTEGER INFO, LDA, LIWORK, LWORK, N -* .. -* .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. -* - LOGICAL LOWER, LQUERY, WANTZ - INTEGER IINFO, INDE, INDTAU, INDWK2, INDWRK, ISCALE, - $ LIOPT, LIWMIN, LLWORK, LLWRK2, LOPT, LWMIN - DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, - $ SMLNUM -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANSY - EXTERNAL LSAME, DLAMCH, DLANSY, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DLACPY, DLASCL, DORMTR, DSCAL, DSTEDC, DSTERF, - $ DSYTRD, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - WANTZ = LSAME( JOBZ, 'V' ) - LOWER = LSAME( UPLO, 'L' ) - LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) -* - INFO = 0 - IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF -* - IF( INFO.EQ.0 ) THEN - IF( N.LE.1 ) THEN - LIWMIN = 1 - LWMIN = 1 - LOPT = LWMIN - LIOPT = LIWMIN - ELSE - IF( WANTZ ) THEN - LIWMIN = 3 + 5*N - LWMIN = 1 + 6*N + 2*N**2 - ELSE - LIWMIN = 1 - LWMIN = 2*N + 1 - END IF - LOPT = MAX( LWMIN, 2*N + - $ N*ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) ) - LIOPT = LIWMIN - END IF - WORK( 1 ) = LOPT - IWORK( 1 ) = LIOPT -* - IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN - INFO = -8 - ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN - INFO = -10 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSYEVD', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( N.EQ.1 ) THEN - W( 1 ) = A( 1, 1 ) - IF( WANTZ ) - $ A( 1, 1 ) = ONE - RETURN - END IF -* -* Get machine constants. -* - SAFMIN = DLAMCH( 'Safe minimum' ) - EPS = DLAMCH( 'Precision' ) - SMLNUM = SAFMIN / EPS - BIGNUM = ONE / SMLNUM - RMIN = SQRT( SMLNUM ) - RMAX = SQRT( BIGNUM ) -* -* Scale matrix to allowable range, if necessary. -* - ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) - ISCALE = 0 - IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN - ISCALE = 1 - SIGMA = RMIN / ANRM - ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 - SIGMA = RMAX / ANRM - END IF - IF( ISCALE.EQ.1 ) - $ CALL DLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) -* -* Call DSYTRD to reduce symmetric matrix to tridiagonal form. -* - INDE = 1 - INDTAU = INDE + N - INDWRK = INDTAU + N - LLWORK = LWORK - INDWRK + 1 - INDWK2 = INDWRK + N*N - LLWRK2 = LWORK - INDWK2 + 1 -* - CALL DSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ), - $ WORK( INDWRK ), LLWORK, IINFO ) -* -* For eigenvalues only, call DSTERF. For eigenvectors, first call -* DSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the -* tridiagonal matrix, then call DORMTR to multiply it by the -* Householder transformations stored in A. -* - IF( .NOT.WANTZ ) THEN - CALL DSTERF( N, W, WORK( INDE ), INFO ) - ELSE - CALL DSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N, - $ WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO ) - CALL DORMTR( 'L', UPLO, 'N', N, N, A, LDA, WORK( INDTAU ), - $ WORK( INDWRK ), N, WORK( INDWK2 ), LLWRK2, IINFO ) - CALL DLACPY( 'A', N, N, WORK( INDWRK ), N, A, LDA ) - END IF -* -* If matrix was scaled, then rescale eigenvalues appropriately. -* - IF( ISCALE.EQ.1 ) - $ CALL DSCAL( N, ONE / SIGMA, W, 1 ) -* - WORK( 1 ) = LOPT - IWORK( 1 ) = LIOPT -* - RETURN -* -* End of DSYEVD -* - END diff --git a/lib/linalg/dsygs2.cpp b/lib/linalg/dsygs2.cpp new file mode 100644 index 0000000000..c0b2972537 --- /dev/null +++ b/lib/linalg/dsygs2.cpp @@ -0,0 +1,157 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static doublereal c_b6 = -1.; +static integer c__1 = 1; +static doublereal c_b27 = 1.; +int dsygs2_(integer *itype, char *uplo, integer *n, doublereal *a, integer *lda, doublereal *b, + integer *ldb, integer *info, ftnlen uplo_len) +{ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; + doublereal d__1; + integer k; + doublereal ct, akk, bkk; + extern int dsyr2_(char *, integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, integer *, ftnlen), + dscal_(integer *, doublereal *, doublereal *, integer *); + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern int daxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *); + logical upper; + extern int dtrmv_(char *, char *, char *, integer *, doublereal *, integer *, doublereal *, + integer *, ftnlen, ftnlen, ftnlen), + dtrsv_(char *, char *, char *, integer *, doublereal *, integer *, doublereal *, integer *, + ftnlen, ftnlen, ftnlen), + 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; + *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 *)"DSYGS2", &i__1, (ftnlen)6); + return 0; + } + if (*itype == 1) { + if (upper) { + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + akk = a[k + k * a_dim1]; + bkk = b[k + k * b_dim1]; + d__1 = bkk; + akk /= d__1 * d__1; + a[k + k * a_dim1] = akk; + if (k < *n) { + i__2 = *n - k; + d__1 = 1. / bkk; + dscal_(&i__2, &d__1, &a[k + (k + 1) * a_dim1], lda); + ct = akk * -.5; + i__2 = *n - k; + daxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + (k + 1) * a_dim1], + lda); + i__2 = *n - k; + dsyr2_(uplo, &i__2, &c_b6, &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; + daxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + (k + 1) * a_dim1], + lda); + i__2 = *n - k; + dtrsv_(uplo, (char *)"Transpose", (char *)"Non-unit", &i__2, &b[k + 1 + (k + 1) * b_dim1], ldb, + &a[k + (k + 1) * a_dim1], lda, (ftnlen)1, (ftnlen)9, (ftnlen)8); + } + } + } else { + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + akk = a[k + k * a_dim1]; + bkk = b[k + k * b_dim1]; + d__1 = bkk; + akk /= d__1 * d__1; + a[k + k * a_dim1] = akk; + if (k < *n) { + i__2 = *n - k; + d__1 = 1. / bkk; + dscal_(&i__2, &d__1, &a[k + 1 + k * a_dim1], &c__1); + ct = akk * -.5; + i__2 = *n - k; + daxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k + 1 + k * a_dim1], + &c__1); + i__2 = *n - k; + dsyr2_(uplo, &i__2, &c_b6, &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; + daxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k + 1 + k * a_dim1], + &c__1); + i__2 = *n - k; + dtrsv_(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) { + akk = a[k + k * a_dim1]; + bkk = b[k + k * b_dim1]; + i__2 = k - 1; + dtrmv_(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); + ct = akk * .5; + i__2 = k - 1; + daxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); + i__2 = k - 1; + dsyr2_(uplo, &i__2, &c_b27, &a[k * a_dim1 + 1], &c__1, &b[k * b_dim1 + 1], &c__1, + &a[a_offset], lda, (ftnlen)1); + i__2 = k - 1; + daxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); + i__2 = k - 1; + dscal_(&i__2, &bkk, &a[k * a_dim1 + 1], &c__1); + d__1 = bkk; + a[k + k * a_dim1] = akk * (d__1 * d__1); + } + } else { + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + akk = a[k + k * a_dim1]; + bkk = b[k + k * b_dim1]; + i__2 = k - 1; + dtrmv_(uplo, (char *)"Transpose", (char *)"Non-unit", &i__2, &b[b_offset], ldb, &a[k + a_dim1], lda, + (ftnlen)1, (ftnlen)9, (ftnlen)8); + ct = akk * .5; + i__2 = k - 1; + daxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda); + i__2 = k - 1; + dsyr2_(uplo, &i__2, &c_b27, &a[k + a_dim1], lda, &b[k + b_dim1], ldb, &a[a_offset], + lda, (ftnlen)1); + i__2 = k - 1; + daxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda); + i__2 = k - 1; + dscal_(&i__2, &bkk, &a[k + a_dim1], lda); + d__1 = bkk; + a[k + k * a_dim1] = akk * (d__1 * d__1); + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dsygs2.f b/lib/linalg/dsygs2.f deleted file mode 100644 index 8a39bea77e..0000000000 --- a/lib/linalg/dsygs2.f +++ /dev/null @@ -1,280 +0,0 @@ -*> \brief \b DSYGS2 reduces a symmetric definite generalized eigenproblem to standard form, using the factorization results obtained from spotrf (unblocked algorithm). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DSYGS2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, ITYPE, LDA, LDB, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSYGS2 reduces a real symmetric-definite generalized eigenproblem -*> to standard form. -*> -*> If ITYPE = 1, the problem is A*x = lambda*B*x, -*> and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T) -*> -*> If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or -*> B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T *A*L. -*> -*> B must have been previously factorized as U**T *U or L*L**T by DPOTRF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] ITYPE -*> \verbatim -*> ITYPE is INTEGER -*> = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T); -*> = 2 or 3: compute U*A*U**T or L**T *A*L. -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> Specifies whether the upper or lower triangular part of the -*> symmetric matrix A is stored, and how B has been factorized. -*> = 'U': Upper triangular -*> = 'L': Lower triangular -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrices A and B. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the symmetric matrix A. If UPLO = 'U', the leading -*> n by n upper triangular part of A contains the upper -*> triangular part of the matrix A, and the strictly lower -*> triangular part of A is not referenced. If UPLO = 'L', the -*> leading n by n lower triangular part of A contains the lower -*> triangular part of the matrix A, and the strictly upper -*> triangular part of A is not referenced. -*> -*> On exit, if INFO = 0, the transformed matrix, stored in the -*> same format as A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB,N) -*> The triangular factor from the Cholesky factorization of B, -*> as returned by DPOTRF. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >= max(1,N). -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit. -*> < 0: if INFO = -i, the i-th argument had an illegal value. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleSYcomputational -* -* ===================================================================== - SUBROUTINE DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, ITYPE, LDA, LDB, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, HALF - PARAMETER ( ONE = 1.0D0, HALF = 0.5D0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER K - DOUBLE PRECISION AKK, BKK, CT -* .. -* .. External Subroutines .. - EXTERNAL DAXPY, DSCAL, DSYR2, DTRMV, DTRSV, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN - INFO = -1 - ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSYGS2', -INFO ) - RETURN - END IF -* - IF( ITYPE.EQ.1 ) THEN - IF( UPPER ) THEN -* -* Compute inv(U**T)*A*inv(U) -* - DO 10 K = 1, N -* -* Update the upper triangle of A(k:n,k:n) -* - AKK = A( K, K ) - BKK = B( K, K ) - AKK = AKK / BKK**2 - A( K, K ) = AKK - IF( K.LT.N ) THEN - CALL DSCAL( N-K, ONE / BKK, A( K, K+1 ), LDA ) - CT = -HALF*AKK - CALL DAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ), - $ LDA ) - CALL DSYR2( UPLO, N-K, -ONE, A( K, K+1 ), LDA, - $ B( K, K+1 ), LDB, A( K+1, K+1 ), LDA ) - CALL DAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ), - $ LDA ) - CALL DTRSV( UPLO, 'Transpose', 'Non-unit', N-K, - $ B( K+1, K+1 ), LDB, A( K, K+1 ), LDA ) - END IF - 10 CONTINUE - ELSE -* -* Compute inv(L)*A*inv(L**T) -* - DO 20 K = 1, N -* -* Update the lower triangle of A(k:n,k:n) -* - AKK = A( K, K ) - BKK = B( K, K ) - AKK = AKK / BKK**2 - A( K, K ) = AKK - IF( K.LT.N ) THEN - CALL DSCAL( N-K, ONE / BKK, A( K+1, K ), 1 ) - CT = -HALF*AKK - CALL DAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 ) - CALL DSYR2( UPLO, N-K, -ONE, A( K+1, K ), 1, - $ B( K+1, K ), 1, A( K+1, K+1 ), LDA ) - CALL DAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 ) - CALL DTRSV( UPLO, 'No transpose', 'Non-unit', N-K, - $ B( K+1, K+1 ), LDB, A( K+1, K ), 1 ) - END IF - 20 CONTINUE - END IF - ELSE - IF( UPPER ) THEN -* -* Compute U*A*U**T -* - DO 30 K = 1, N -* -* Update the upper triangle of A(1:k,1:k) -* - AKK = A( K, K ) - BKK = B( K, K ) - CALL DTRMV( UPLO, 'No transpose', 'Non-unit', K-1, B, - $ LDB, A( 1, K ), 1 ) - CT = HALF*AKK - CALL DAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 ) - CALL DSYR2( UPLO, K-1, ONE, A( 1, K ), 1, B( 1, K ), 1, - $ A, LDA ) - CALL DAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 ) - CALL DSCAL( K-1, BKK, A( 1, K ), 1 ) - A( K, K ) = AKK*BKK**2 - 30 CONTINUE - ELSE -* -* Compute L**T *A*L -* - DO 40 K = 1, N -* -* Update the lower triangle of A(1:k,1:k) -* - AKK = A( K, K ) - BKK = B( K, K ) - CALL DTRMV( UPLO, 'Transpose', 'Non-unit', K-1, B, LDB, - $ A( K, 1 ), LDA ) - CT = HALF*AKK - CALL DAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA ) - CALL DSYR2( UPLO, K-1, ONE, A( K, 1 ), LDA, B( K, 1 ), - $ LDB, A, LDA ) - CALL DAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA ) - CALL DSCAL( K-1, BKK, A( K, 1 ), LDA ) - A( K, K ) = AKK*BKK**2 - 40 CONTINUE - END IF - END IF - RETURN -* -* End of DSYGS2 -* - END diff --git a/lib/linalg/dsygst.cpp b/lib/linalg/dsygst.cpp new file mode 100644 index 0000000000..dcf546a181 --- /dev/null +++ b/lib/linalg/dsygst.cpp @@ -0,0 +1,191 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +static integer c_n1 = -1; +static doublereal c_b14 = 1.; +static doublereal c_b16 = -.5; +static doublereal c_b19 = -1.; +static doublereal c_b52 = .5; +int dsygst_(integer *itype, char *uplo, integer *n, doublereal *a, integer *lda, doublereal *b, + integer *ldb, integer *info, ftnlen uplo_len) +{ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; + integer k, kb, nb; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern int dtrmm_(char *, char *, char *, char *, integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, + ftnlen), + dsymm_(char *, char *, integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen); + logical upper; + extern int dtrsm_(char *, char *, char *, char *, integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, + ftnlen), + dsygs2_(integer *, char *, integer *, doublereal *, integer *, doublereal *, integer *, + integer *, ftnlen), + dsyr2k_(char *, char *, integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *, 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 *)"DSYGST", &i__1, (ftnlen)6); + return 0; + } + if (*n == 0) { + return 0; + } + nb = ilaenv_(&c__1, (char *)"DSYGST", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); + if (nb <= 1 || nb >= *n) { + dsygs2_(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); + dsygs2_(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; + dtrsm_((char *)"Left", uplo, (char *)"Transpose", (char *)"Non-unit", &kb, &i__3, &c_b14, + &b[k + k * b_dim1], ldb, &a[k + (k + kb) * a_dim1], lda, (ftnlen)4, + (ftnlen)1, (ftnlen)9, (ftnlen)8); + i__3 = *n - k - kb + 1; + dsymm_((char *)"Left", uplo, &kb, &i__3, &c_b16, &a[k + k * a_dim1], lda, + &b[k + (k + kb) * b_dim1], ldb, &c_b14, &a[k + (k + kb) * a_dim1], + lda, (ftnlen)4, (ftnlen)1); + i__3 = *n - k - kb + 1; + dsyr2k_(uplo, (char *)"Transpose", &i__3, &kb, &c_b19, &a[k + (k + kb) * a_dim1], + lda, &b[k + (k + kb) * b_dim1], ldb, &c_b14, + &a[k + kb + (k + kb) * a_dim1], lda, (ftnlen)1, (ftnlen)9); + i__3 = *n - k - kb + 1; + dsymm_((char *)"Left", uplo, &kb, &i__3, &c_b16, &a[k + k * a_dim1], lda, + &b[k + (k + kb) * b_dim1], ldb, &c_b14, &a[k + (k + kb) * a_dim1], + lda, (ftnlen)4, (ftnlen)1); + i__3 = *n - k - kb + 1; + dtrsm_((char *)"Right", uplo, (char *)"No transpose", (char *)"Non-unit", &kb, &i__3, &c_b14, + &b[k + kb + (k + kb) * b_dim1], ldb, &a[k + (k + kb) * a_dim1], lda, + (ftnlen)5, (ftnlen)1, (ftnlen)12, (ftnlen)8); + } + } + } 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); + dsygs2_(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; + dtrsm_((char *)"Right", uplo, (char *)"Transpose", (char *)"Non-unit", &i__3, &kb, &c_b14, + &b[k + k * b_dim1], ldb, &a[k + kb + k * a_dim1], lda, (ftnlen)5, + (ftnlen)1, (ftnlen)9, (ftnlen)8); + i__3 = *n - k - kb + 1; + dsymm_((char *)"Right", uplo, &i__3, &kb, &c_b16, &a[k + k * a_dim1], lda, + &b[k + kb + k * b_dim1], ldb, &c_b14, &a[k + kb + k * a_dim1], lda, + (ftnlen)5, (ftnlen)1); + i__3 = *n - k - kb + 1; + dsyr2k_(uplo, (char *)"No transpose", &i__3, &kb, &c_b19, &a[k + kb + k * a_dim1], + lda, &b[k + kb + k * b_dim1], ldb, &c_b14, + &a[k + kb + (k + kb) * a_dim1], lda, (ftnlen)1, (ftnlen)12); + i__3 = *n - k - kb + 1; + dsymm_((char *)"Right", uplo, &i__3, &kb, &c_b16, &a[k + k * a_dim1], lda, + &b[k + kb + k * b_dim1], ldb, &c_b14, &a[k + kb + k * a_dim1], lda, + (ftnlen)5, (ftnlen)1); + i__3 = *n - k - kb + 1; + dtrsm_((char *)"Left", uplo, (char *)"No transpose", (char *)"Non-unit", &i__3, &kb, &c_b14, + &b[k + kb + (k + kb) * b_dim1], ldb, &a[k + kb + k * a_dim1], lda, + (ftnlen)4, (ftnlen)1, (ftnlen)12, (ftnlen)8); + } + } + } + } 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; + dtrmm_((char *)"Left", uplo, (char *)"No transpose", (char *)"Non-unit", &i__3, &kb, &c_b14, + &b[b_offset], ldb, &a[k * a_dim1 + 1], lda, (ftnlen)4, (ftnlen)1, + (ftnlen)12, (ftnlen)8); + i__3 = k - 1; + dsymm_((char *)"Right", uplo, &i__3, &kb, &c_b52, &a[k + k * a_dim1], lda, + &b[k * b_dim1 + 1], ldb, &c_b14, &a[k * a_dim1 + 1], lda, (ftnlen)5, + (ftnlen)1); + i__3 = k - 1; + dsyr2k_(uplo, (char *)"No transpose", &i__3, &kb, &c_b14, &a[k * a_dim1 + 1], lda, + &b[k * b_dim1 + 1], ldb, &c_b14, &a[a_offset], lda, (ftnlen)1, + (ftnlen)12); + i__3 = k - 1; + dsymm_((char *)"Right", uplo, &i__3, &kb, &c_b52, &a[k + k * a_dim1], lda, + &b[k * b_dim1 + 1], ldb, &c_b14, &a[k * a_dim1 + 1], lda, (ftnlen)5, + (ftnlen)1); + i__3 = k - 1; + dtrmm_((char *)"Right", uplo, (char *)"Transpose", (char *)"Non-unit", &i__3, &kb, &c_b14, + &b[k + k * b_dim1], ldb, &a[k * a_dim1 + 1], lda, (ftnlen)5, (ftnlen)1, + (ftnlen)9, (ftnlen)8); + dsygs2_(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; + dtrmm_((char *)"Right", uplo, (char *)"No transpose", (char *)"Non-unit", &kb, &i__3, &c_b14, + &b[b_offset], ldb, &a[k + a_dim1], lda, (ftnlen)5, (ftnlen)1, (ftnlen)12, + (ftnlen)8); + i__3 = k - 1; + dsymm_((char *)"Left", uplo, &kb, &i__3, &c_b52, &a[k + k * a_dim1], lda, + &b[k + b_dim1], ldb, &c_b14, &a[k + a_dim1], lda, (ftnlen)4, (ftnlen)1); + i__3 = k - 1; + dsyr2k_(uplo, (char *)"Transpose", &i__3, &kb, &c_b14, &a[k + a_dim1], lda, + &b[k + b_dim1], ldb, &c_b14, &a[a_offset], lda, (ftnlen)1, (ftnlen)9); + i__3 = k - 1; + dsymm_((char *)"Left", uplo, &kb, &i__3, &c_b52, &a[k + k * a_dim1], lda, + &b[k + b_dim1], ldb, &c_b14, &a[k + a_dim1], lda, (ftnlen)4, (ftnlen)1); + i__3 = k - 1; + dtrmm_((char *)"Left", uplo, (char *)"Transpose", (char *)"Non-unit", &kb, &i__3, &c_b14, + &b[k + k * b_dim1], ldb, &a[k + a_dim1], lda, (ftnlen)4, (ftnlen)1, + (ftnlen)9, (ftnlen)8); + dsygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + k * b_dim1], ldb, + info, (ftnlen)1); + } + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dsygst.f b/lib/linalg/dsygst.f deleted file mode 100644 index 05b90372ab..0000000000 --- a/lib/linalg/dsygst.f +++ /dev/null @@ -1,318 +0,0 @@ -*> \brief \b DSYGST -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DSYGST + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, ITYPE, LDA, LDB, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSYGST reduces a real symmetric-definite generalized eigenproblem -*> to standard form. -*> -*> If ITYPE = 1, the problem is A*x = lambda*B*x, -*> and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T) -*> -*> If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or -*> B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L. -*> -*> B must have been previously factorized as U**T*U or L*L**T by DPOTRF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] ITYPE -*> \verbatim -*> ITYPE is INTEGER -*> = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T); -*> = 2 or 3: compute U*A*U**T or L**T*A*L. -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A is stored and B is factored as -*> U**T*U; -*> = 'L': Lower triangle of A is stored and B is factored as -*> L*L**T. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrices A and B. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the symmetric matrix A. If UPLO = 'U', the leading -*> N-by-N upper triangular part of A contains the upper -*> triangular part of the matrix A, and the strictly lower -*> triangular part of A is not referenced. If UPLO = 'L', the -*> leading N-by-N lower triangular part of A contains the lower -*> triangular part of the matrix A, and the strictly upper -*> triangular part of A is not referenced. -*> -*> On exit, if INFO = 0, the transformed matrix, stored in the -*> same format as A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB,N) -*> The triangular factor from the Cholesky factorization of B, -*> as returned by DPOTRF. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >= max(1,N). -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleSYcomputational -* -* ===================================================================== - SUBROUTINE DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, ITYPE, LDA, LDB, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, HALF - PARAMETER ( ONE = 1.0D0, HALF = 0.5D0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER K, KB, NB -* .. -* .. External Subroutines .. - EXTERNAL DSYGS2, DSYMM, DSYR2K, DTRMM, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN - INFO = -1 - ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSYGST', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'DSYGST', UPLO, N, -1, -1, -1 ) -* - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code -* - CALL DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) - ELSE -* -* Use blocked code -* - IF( ITYPE.EQ.1 ) THEN - IF( UPPER ) THEN -* -* Compute inv(U**T)*A*inv(U) -* - DO 10 K = 1, N, NB - KB = MIN( N-K+1, NB ) -* -* Update the upper triangle of A(k:n,k:n) -* - CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, - $ B( K, K ), LDB, INFO ) - IF( K+KB.LE.N ) THEN - CALL DTRSM( 'Left', UPLO, 'Transpose', 'Non-unit', - $ KB, N-K-KB+1, ONE, B( K, K ), LDB, - $ A( K, K+KB ), LDA ) - CALL DSYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF, - $ A( K, K ), LDA, B( K, K+KB ), LDB, ONE, - $ A( K, K+KB ), LDA ) - CALL DSYR2K( UPLO, 'Transpose', N-K-KB+1, KB, -ONE, - $ A( K, K+KB ), LDA, B( K, K+KB ), LDB, - $ ONE, A( K+KB, K+KB ), LDA ) - CALL DSYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF, - $ A( K, K ), LDA, B( K, K+KB ), LDB, ONE, - $ A( K, K+KB ), LDA ) - CALL DTRSM( 'Right', UPLO, 'No transpose', - $ 'Non-unit', KB, N-K-KB+1, ONE, - $ B( K+KB, K+KB ), LDB, A( K, K+KB ), - $ LDA ) - END IF - 10 CONTINUE - ELSE -* -* Compute inv(L)*A*inv(L**T) -* - DO 20 K = 1, N, NB - KB = MIN( N-K+1, NB ) -* -* Update the lower triangle of A(k:n,k:n) -* - CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, - $ B( K, K ), LDB, INFO ) - IF( K+KB.LE.N ) THEN - CALL DTRSM( 'Right', UPLO, 'Transpose', 'Non-unit', - $ N-K-KB+1, KB, ONE, B( K, K ), LDB, - $ A( K+KB, K ), LDA ) - CALL DSYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF, - $ A( K, K ), LDA, B( K+KB, K ), LDB, ONE, - $ A( K+KB, K ), LDA ) - CALL DSYR2K( UPLO, 'No transpose', N-K-KB+1, KB, - $ -ONE, A( K+KB, K ), LDA, B( K+KB, K ), - $ LDB, ONE, A( K+KB, K+KB ), LDA ) - CALL DSYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF, - $ A( K, K ), LDA, B( K+KB, K ), LDB, ONE, - $ A( K+KB, K ), LDA ) - CALL DTRSM( 'Left', UPLO, 'No transpose', - $ 'Non-unit', N-K-KB+1, KB, ONE, - $ B( K+KB, K+KB ), LDB, A( K+KB, K ), - $ LDA ) - END IF - 20 CONTINUE - END IF - ELSE - IF( UPPER ) THEN -* -* Compute U*A*U**T -* - DO 30 K = 1, N, NB - KB = MIN( N-K+1, NB ) -* -* Update the upper triangle of A(1:k+kb-1,1:k+kb-1) -* - CALL DTRMM( 'Left', UPLO, 'No transpose', 'Non-unit', - $ K-1, KB, ONE, B, LDB, A( 1, K ), LDA ) - CALL DSYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ), - $ LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA ) - CALL DSYR2K( UPLO, 'No transpose', K-1, KB, ONE, - $ A( 1, K ), LDA, B( 1, K ), LDB, ONE, A, - $ LDA ) - CALL DSYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ), - $ LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA ) - CALL DTRMM( 'Right', UPLO, 'Transpose', 'Non-unit', - $ K-1, KB, ONE, B( K, K ), LDB, A( 1, K ), - $ LDA ) - CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, - $ B( K, K ), LDB, INFO ) - 30 CONTINUE - ELSE -* -* Compute L**T*A*L -* - DO 40 K = 1, N, NB - KB = MIN( N-K+1, NB ) -* -* Update the lower triangle of A(1:k+kb-1,1:k+kb-1) -* - CALL DTRMM( 'Right', UPLO, 'No transpose', 'Non-unit', - $ KB, K-1, ONE, B, LDB, A( K, 1 ), LDA ) - CALL DSYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ), - $ LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA ) - CALL DSYR2K( UPLO, 'Transpose', K-1, KB, ONE, - $ A( K, 1 ), LDA, B( K, 1 ), LDB, ONE, A, - $ LDA ) - CALL DSYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ), - $ LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA ) - CALL DTRMM( 'Left', UPLO, 'Transpose', 'Non-unit', KB, - $ K-1, ONE, B( K, K ), LDB, A( K, 1 ), LDA ) - CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, - $ B( K, K ), LDB, INFO ) - 40 CONTINUE - END IF - END IF - END IF - RETURN -* -* End of DSYGST -* - END diff --git a/lib/linalg/dsygv.cpp b/lib/linalg/dsygv.cpp new file mode 100644 index 0000000000..62194ee354 --- /dev/null +++ b/lib/linalg/dsygv.cpp @@ -0,0 +1,116 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +static integer c_n1 = -1; +static doublereal c_b16 = 1.; +int dsygv_(integer *itype, char *jobz, char *uplo, integer *n, doublereal *a, integer *lda, + doublereal *b, integer *ldb, doublereal *w, doublereal *work, integer *lwork, + 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 dtrmm_(char *, char *, char *, char *, integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, + ftnlen); + char trans[1]; + extern int dtrsm_(char *, char *, char *, char *, integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, + ftnlen); + logical upper; + extern int dsyev_(char *, char *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *, integer *, ftnlen, ftnlen); + logical wantz; + extern int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, + ftnlen, ftnlen); + extern int dpotrf_(char *, integer *, doublereal *, integer *, integer *, ftnlen); + integer lwkmin; + extern int dsygst_(integer *, char *, integer *, doublereal *, integer *, doublereal *, + integer *, integer *, ftnlen); + integer lwkopt; + logical lquery; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + --w; + --work; + 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) { + i__1 = 1, i__2 = *n * 3 - 1; + lwkmin = max(i__1, i__2); + nb = ilaenv_(&c__1, (char *)"DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); + i__1 = lwkmin, i__2 = (nb + 2) * *n; + lwkopt = max(i__1, i__2); + work[1] = (doublereal)lwkopt; + if (*lwork < lwkmin && !lquery) { + *info = -11; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DSYGV ", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + if (*n == 0) { + return 0; + } + dpotrf_(uplo, n, &b[b_offset], ldb, info, (ftnlen)1); + if (*info != 0) { + *info = *n + *info; + return 0; + } + dsygst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info, (ftnlen)1); + dsyev_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, 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 = 'T'; + } + dtrsm_((char *)"Left", uplo, trans, (char *)"Non-unit", n, &neig, &c_b16, &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 = 'T'; + } else { + *(unsigned char *)trans = 'N'; + } + dtrmm_((char *)"Left", uplo, trans, (char *)"Non-unit", n, &neig, &c_b16, &b[b_offset], ldb, + &a[a_offset], lda, (ftnlen)4, (ftnlen)1, (ftnlen)1, (ftnlen)8); + } + } + work[1] = (doublereal)lwkopt; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dsygv.f b/lib/linalg/dsygv.f deleted file mode 100644 index 5208dbb1f1..0000000000 --- a/lib/linalg/dsygv.f +++ /dev/null @@ -1,311 +0,0 @@ -*> \brief \b DSYGV -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DSYGV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, -* LWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER JOBZ, UPLO -* INTEGER INFO, ITYPE, LDA, LDB, LWORK, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSYGV computes all the eigenvalues, and optionally, the eigenvectors -*> of a real generalized symmetric-definite eigenproblem, of the form -*> A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. -*> Here A and B are assumed to be symmetric and B is also -*> positive definite. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] ITYPE -*> \verbatim -*> ITYPE is INTEGER -*> Specifies the problem type to be solved: -*> = 1: A*x = (lambda)*B*x -*> = 2: A*B*x = (lambda)*x -*> = 3: B*A*x = (lambda)*x -*> \endverbatim -*> -*> \param[in] JOBZ -*> \verbatim -*> JOBZ is CHARACTER*1 -*> = 'N': Compute eigenvalues only; -*> = 'V': Compute eigenvalues and eigenvectors. -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangles of A and B are stored; -*> = 'L': Lower triangles of A and B are stored. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrices A and B. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA, N) -*> On entry, the symmetric matrix A. If UPLO = 'U', the -*> leading N-by-N upper triangular part of A contains the -*> upper triangular part of the matrix A. If UPLO = 'L', -*> the leading N-by-N lower triangular part of A contains -*> the lower triangular part of the matrix A. -*> -*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the -*> matrix Z of eigenvectors. The eigenvectors are normalized -*> as follows: -*> if ITYPE = 1 or 2, Z**T*B*Z = I; -*> if ITYPE = 3, Z**T*inv(B)*Z = I. -*> If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') -*> or the lower triangle (if UPLO='L') of A, including the -*> diagonal, is destroyed. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB, N) -*> On entry, the symmetric positive definite matrix B. -*> If UPLO = 'U', the leading N-by-N upper triangular part of B -*> contains the upper triangular part of the matrix B. -*> If UPLO = 'L', the leading N-by-N lower triangular part of B -*> contains the lower triangular part of the matrix B. -*> -*> On exit, if INFO <= N, the part of B containing the matrix is -*> overwritten by the triangular factor U or L from the Cholesky -*> factorization B = U**T*U or B = L*L**T. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >= max(1,N). -*> \endverbatim -*> -*> \param[out] W -*> \verbatim -*> W is DOUBLE PRECISION array, dimension (N) -*> If INFO = 0, the eigenvalues in ascending order. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The length of the array WORK. LWORK >= max(1,3*N-1). -*> For optimal efficiency, LWORK >= (NB+2)*N, -*> where NB is the blocksize for DSYTRD returned by ILAENV. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal size of the WORK array, returns -*> this value as the first entry of the WORK array, and no error -*> message related to LWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> > 0: DPOTRF or DSYEV returned an error code: -*> <= N: if INFO = i, DSYEV failed to converge; -*> i off-diagonal elements of an intermediate -*> tridiagonal form did not converge to zero; -*> > N: if INFO = N + i, for 1 <= i <= N, then the leading -*> minor of order i of B is not positive definite. -*> The factorization of B could not be completed and -*> no eigenvalues or eigenvectors were computed. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleSYeigen -* -* ===================================================================== - SUBROUTINE DSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, - $ LWORK, INFO ) -* -* -- LAPACK driver routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER JOBZ, UPLO - INTEGER INFO, ITYPE, LDA, LDB, LWORK, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY, UPPER, WANTZ - CHARACTER TRANS - INTEGER LWKMIN, LWKOPT, NB, NEIG -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DPOTRF, DSYEV, DSYGST, DTRMM, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - WANTZ = LSAME( JOBZ, 'V' ) - UPPER = LSAME( UPLO, 'U' ) - LQUERY = ( LWORK.EQ.-1 ) -* - INFO = 0 - IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN - INFO = -1 - ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - END IF -* - IF( INFO.EQ.0 ) THEN - LWKMIN = MAX( 1, 3*N - 1 ) - NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) - LWKOPT = MAX( LWKMIN, ( NB + 2 )*N ) - WORK( 1 ) = LWKOPT -* - IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN - INFO = -11 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSYGV ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Form a Cholesky factorization of B. -* - CALL DPOTRF( UPLO, N, B, LDB, INFO ) - IF( INFO.NE.0 ) THEN - INFO = N + INFO - RETURN - END IF -* -* Transform problem to standard eigenvalue problem and solve. -* - CALL DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) - CALL DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) -* - IF( WANTZ ) THEN -* -* Backtransform eigenvectors to the original problem. -* - NEIG = N - IF( INFO.GT.0 ) - $ NEIG = INFO - 1 - IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN -* -* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; -* backtransform eigenvectors: x = inv(L)**T*y or inv(U)*y -* - IF( UPPER ) THEN - TRANS = 'N' - ELSE - TRANS = 'T' - END IF -* - CALL DTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE, - $ B, LDB, A, LDA ) -* - ELSE IF( ITYPE.EQ.3 ) THEN -* -* For B*A*x=(lambda)*x; -* backtransform eigenvectors: x = L*y or U**T*y -* - IF( UPPER ) THEN - TRANS = 'T' - ELSE - TRANS = 'N' - END IF -* - CALL DTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE, - $ B, LDB, A, LDA ) - END IF - END IF -* - WORK( 1 ) = LWKOPT - RETURN -* -* End of DSYGV -* - END diff --git a/lib/linalg/dsygvd.cpp b/lib/linalg/dsygvd.cpp new file mode 100644 index 0000000000..59c69d21d1 --- /dev/null +++ b/lib/linalg/dsygvd.cpp @@ -0,0 +1,127 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static doublereal c_b11 = 1.; +int dsygvd_(integer *itype, char *jobz, char *uplo, integer *n, doublereal *a, integer *lda, + doublereal *b, integer *ldb, doublereal *w, doublereal *work, integer *lwork, + integer *iwork, integer *liwork, integer *info, ftnlen jobz_len, ftnlen uplo_len) +{ + integer a_dim1, a_offset, b_dim1, b_offset, i__1; + doublereal d__1, d__2; + integer lopt; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern int dtrmm_(char *, char *, char *, char *, integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, + ftnlen); + integer lwmin; + char trans[1]; + integer liopt; + extern int dtrsm_(char *, char *, char *, char *, integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, + ftnlen); + logical upper, wantz; + extern int xerbla_(char *, integer *, ftnlen), + dpotrf_(char *, integer *, doublereal *, integer *, integer *, ftnlen); + integer liwmin; + extern int dsyevd_(char *, char *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *, integer *, integer *, integer *, ftnlen, ftnlen), + dsygst_(integer *, char *, integer *, doublereal *, integer *, doublereal *, integer *, + integer *, ftnlen); + logical lquery; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + --w; + --work; + --iwork; + wantz = lsame_(jobz, (char *)"V", (ftnlen)1, (ftnlen)1); + upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); + lquery = *lwork == -1 || *liwork == -1; + *info = 0; + if (*n <= 1) { + liwmin = 1; + lwmin = 1; + } else if (wantz) { + liwmin = *n * 5 + 3; + i__1 = *n; + lwmin = *n * 6 + 1 + (i__1 * i__1 << 1); + } else { + liwmin = 1; + lwmin = (*n << 1) + 1; + } + lopt = lwmin; + liopt = liwmin; + 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) { + work[1] = (doublereal)lopt; + iwork[1] = liopt; + if (*lwork < lwmin && !lquery) { + *info = -11; + } else if (*liwork < liwmin && !lquery) { + *info = -13; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"DSYGVD", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + if (*n == 0) { + return 0; + } + dpotrf_(uplo, n, &b[b_offset], ldb, info, (ftnlen)1); + if (*info != 0) { + *info = *n + *info; + return 0; + } + dsygst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info, (ftnlen)1); + dsyevd_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, &iwork[1], liwork, info, + (ftnlen)1, (ftnlen)1); + d__1 = (doublereal)lopt; + lopt = (integer)max(d__1, work[1]); + d__1 = (doublereal)liopt, d__2 = (doublereal)iwork[1]; + liopt = (integer)max(d__1, d__2); + if (wantz && *info == 0) { + if (*itype == 1 || *itype == 2) { + if (upper) { + *(unsigned char *)trans = 'N'; + } else { + *(unsigned char *)trans = 'T'; + } + dtrsm_((char *)"Left", uplo, trans, (char *)"Non-unit", n, n, &c_b11, &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 = 'T'; + } else { + *(unsigned char *)trans = 'N'; + } + dtrmm_((char *)"Left", uplo, trans, (char *)"Non-unit", n, n, &c_b11, &b[b_offset], ldb, &a[a_offset], + lda, (ftnlen)4, (ftnlen)1, (ftnlen)1, (ftnlen)8); + } + } + work[1] = (doublereal)lopt; + iwork[1] = liopt; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dsygvd.f b/lib/linalg/dsygvd.f deleted file mode 100644 index 3b38665a75..0000000000 --- a/lib/linalg/dsygvd.f +++ /dev/null @@ -1,377 +0,0 @@ -*> \brief \b DSYGVD -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DSYGVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, -* LWORK, IWORK, LIWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER JOBZ, UPLO -* INTEGER INFO, ITYPE, LDA, LDB, LIWORK, LWORK, N -* .. -* .. Array Arguments .. -* INTEGER IWORK( * ) -* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSYGVD computes all the eigenvalues, and optionally, the eigenvectors -*> of a real generalized symmetric-definite eigenproblem, of the form -*> A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and -*> B are assumed to be symmetric and B is also positive definite. -*> If eigenvectors are desired, it uses a divide and conquer algorithm. -*> -*> The divide and conquer algorithm makes very mild assumptions about -*> floating point arithmetic. It will work on machines with a guard -*> digit in add/subtract, or on those binary machines without guard -*> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or -*> Cray-2. It could conceivably fail on hexadecimal or decimal machines -*> without guard digits, but we know of none. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] ITYPE -*> \verbatim -*> ITYPE is INTEGER -*> Specifies the problem type to be solved: -*> = 1: A*x = (lambda)*B*x -*> = 2: A*B*x = (lambda)*x -*> = 3: B*A*x = (lambda)*x -*> \endverbatim -*> -*> \param[in] JOBZ -*> \verbatim -*> JOBZ is CHARACTER*1 -*> = 'N': Compute eigenvalues only; -*> = 'V': Compute eigenvalues and eigenvectors. -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangles of A and B are stored; -*> = 'L': Lower triangles of A and B are stored. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrices A and B. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA, N) -*> On entry, the symmetric matrix A. If UPLO = 'U', the -*> leading N-by-N upper triangular part of A contains the -*> upper triangular part of the matrix A. If UPLO = 'L', -*> the leading N-by-N lower triangular part of A contains -*> the lower triangular part of the matrix A. -*> -*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the -*> matrix Z of eigenvectors. The eigenvectors are normalized -*> as follows: -*> if ITYPE = 1 or 2, Z**T*B*Z = I; -*> if ITYPE = 3, Z**T*inv(B)*Z = I. -*> If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') -*> or the lower triangle (if UPLO='L') of A, including the -*> diagonal, is destroyed. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB, N) -*> On entry, the symmetric matrix B. If UPLO = 'U', the -*> leading N-by-N upper triangular part of B contains the -*> upper triangular part of the matrix B. If UPLO = 'L', -*> the leading N-by-N lower triangular part of B contains -*> the lower triangular part of the matrix B. -*> -*> On exit, if INFO <= N, the part of B containing the matrix is -*> overwritten by the triangular factor U or L from the Cholesky -*> factorization B = U**T*U or B = L*L**T. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >= max(1,N). -*> \endverbatim -*> -*> \param[out] W -*> \verbatim -*> W is DOUBLE PRECISION array, dimension (N) -*> If INFO = 0, the eigenvalues in ascending order. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. -*> If N <= 1, LWORK >= 1. -*> If JOBZ = 'N' and N > 1, LWORK >= 2*N+1. -*> If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal sizes of the WORK and IWORK -*> arrays, returns these values as the first entries of the WORK -*> and IWORK arrays, and no error message related to LWORK or -*> LIWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) -*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. -*> \endverbatim -*> -*> \param[in] LIWORK -*> \verbatim -*> LIWORK is INTEGER -*> The dimension of the array IWORK. -*> If N <= 1, LIWORK >= 1. -*> If JOBZ = 'N' and N > 1, LIWORK >= 1. -*> If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. -*> -*> If LIWORK = -1, then a workspace query is assumed; the -*> routine only calculates the optimal sizes of the WORK and -*> IWORK arrays, returns these values as the first entries of -*> the WORK and IWORK arrays, and no error message related to -*> LWORK or LIWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> > 0: DPOTRF or DSYEVD returned an error code: -*> <= N: if INFO = i and JOBZ = 'N', then the algorithm -*> failed to converge; i off-diagonal elements of an -*> intermediate tridiagonal form did not converge to -*> zero; -*> if INFO = i and JOBZ = 'V', then the algorithm -*> failed to compute an eigenvalue while working on -*> the submatrix lying in rows and columns INFO/(N+1) -*> through mod(INFO,N+1); -*> > N: if INFO = N + i, for 1 <= i <= N, then the leading -*> minor of order i of B is not positive definite. -*> The factorization of B could not be completed and -*> no eigenvalues or eigenvectors were computed. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleSYeigen -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Modified so that no backsubstitution is performed if DSYEVD fails to -*> converge (NEIG in old code could be greater than N causing out of -*> bounds reference to A - reported by Ralf Meyer). Also corrected the -*> description of INFO and the test on ITYPE. Sven, 16 Feb 05. -*> \endverbatim -* -*> \par Contributors: -* ================== -*> -*> Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA -*> -* ===================================================================== - SUBROUTINE DSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, - $ LWORK, IWORK, LIWORK, INFO ) -* -* -- LAPACK driver routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER JOBZ, UPLO - INTEGER INFO, ITYPE, LDA, LDB, LIWORK, LWORK, N -* .. -* .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY, UPPER, WANTZ - CHARACTER TRANS - INTEGER LIOPT, LIWMIN, LOPT, LWMIN -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DPOTRF, DSYEVD, DSYGST, DTRMM, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - WANTZ = LSAME( JOBZ, 'V' ) - UPPER = LSAME( UPLO, 'U' ) - LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) -* - INFO = 0 - IF( N.LE.1 ) THEN - LIWMIN = 1 - LWMIN = 1 - ELSE IF( WANTZ ) THEN - LIWMIN = 3 + 5*N - LWMIN = 1 + 6*N + 2*N**2 - ELSE - LIWMIN = 1 - LWMIN = 2*N + 1 - END IF - LOPT = LWMIN - LIOPT = LIWMIN - IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN - INFO = -1 - ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - END IF -* - IF( INFO.EQ.0 ) THEN - WORK( 1 ) = LOPT - IWORK( 1 ) = LIOPT -* - IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN - INFO = -11 - ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN - INFO = -13 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSYGVD', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Form a Cholesky factorization of B. -* - CALL DPOTRF( UPLO, N, B, LDB, INFO ) - IF( INFO.NE.0 ) THEN - INFO = N + INFO - RETURN - END IF -* -* Transform problem to standard eigenvalue problem and solve. -* - CALL DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) - CALL DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, LIWORK, - $ INFO ) - LOPT = INT( MAX( DBLE( LOPT ), DBLE( WORK( 1 ) ) ) ) - LIOPT = INT( MAX( DBLE( LIOPT ), DBLE( IWORK( 1 ) ) ) ) -* - IF( WANTZ .AND. INFO.EQ.0 ) THEN -* -* Backtransform eigenvectors to the original problem. -* - IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN -* -* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; -* backtransform eigenvectors: x = inv(L)**T*y or inv(U)*y -* - IF( UPPER ) THEN - TRANS = 'N' - ELSE - TRANS = 'T' - END IF -* - CALL DTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, N, ONE, - $ B, LDB, A, LDA ) -* - ELSE IF( ITYPE.EQ.3 ) THEN -* -* For B*A*x=(lambda)*x; -* backtransform eigenvectors: x = L*y or U**T*y -* - IF( UPPER ) THEN - TRANS = 'T' - ELSE - TRANS = 'N' - END IF -* - CALL DTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, N, ONE, - $ B, LDB, A, LDA ) - END IF - END IF -* - WORK( 1 ) = LOPT - IWORK( 1 ) = LIOPT -* - RETURN -* -* End of DSYGVD -* - END diff --git a/lib/linalg/dsymm.cpp b/lib/linalg/dsymm.cpp new file mode 100644 index 0000000000..f50e24cf3c --- /dev/null +++ b/lib/linalg/dsymm.cpp @@ -0,0 +1,161 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dsymm_(char *side, char *uplo, integer *m, integer *n, doublereal *alpha, doublereal *a, + integer *lda, doublereal *b, integer *ldb, doublereal *beta, doublereal *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; + integer i__, j, k, info; + doublereal 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 *)"DSYMM ", &info, (ftnlen)6); + return 0; + } + if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) { + return 0; + } + if (*alpha == 0.) { + if (*beta == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; + } + } + } + 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__) { + temp1 = *alpha * b[i__ + j * b_dim1]; + temp2 = 0.; + i__3 = i__ - 1; + for (k = 1; k <= i__3; ++k) { + c__[k + j * c_dim1] += temp1 * a[k + i__ * a_dim1]; + temp2 += b[k + j * b_dim1] * a[k + i__ * a_dim1]; + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = temp1 * a[i__ + i__ * a_dim1] + *alpha * temp2; + } else { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] + + temp1 * a[i__ + i__ * a_dim1] + *alpha * temp2; + } + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (i__ = *m; i__ >= 1; --i__) { + temp1 = *alpha * b[i__ + j * b_dim1]; + temp2 = 0.; + i__2 = *m; + for (k = i__ + 1; k <= i__2; ++k) { + c__[k + j * c_dim1] += temp1 * a[k + i__ * a_dim1]; + temp2 += b[k + j * b_dim1] * a[k + i__ * a_dim1]; + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = temp1 * a[i__ + i__ * a_dim1] + *alpha * temp2; + } else { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] + + temp1 * a[i__ + i__ * a_dim1] + *alpha * temp2; + } + } + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * a[j + j * a_dim1]; + if (*beta == 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = temp1 * b[i__ + j * b_dim1]; + } + } else { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = + *beta * c__[i__ + j * c_dim1] + temp1 * b[i__ + j * b_dim1]; + } + } + i__2 = j - 1; + for (k = 1; k <= i__2; ++k) { + if (upper) { + temp1 = *alpha * a[k + j * a_dim1]; + } else { + temp1 = *alpha * a[j + k * a_dim1]; + } + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] += temp1 * b[i__ + k * b_dim1]; + } + } + i__2 = *n; + for (k = j + 1; k <= i__2; ++k) { + if (upper) { + temp1 = *alpha * a[j + k * a_dim1]; + } else { + temp1 = *alpha * a[k + j * a_dim1]; + } + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] += temp1 * b[i__ + k * b_dim1]; + } + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dsymm.f b/lib/linalg/dsymm.f deleted file mode 100644 index 683e79f6ad..0000000000 --- a/lib/linalg/dsymm.f +++ /dev/null @@ -1,364 +0,0 @@ -*> \brief \b DSYMM -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION ALPHA,BETA -* INTEGER LDA,LDB,LDC,M,N -* CHARACTER SIDE,UPLO -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSYMM performs one of the matrix-matrix operations -*> -*> C := alpha*A*B + beta*C, -*> -*> or -*> -*> C := alpha*B*A + beta*C, -*> -*> where alpha and beta are scalars, A is a symmetric matrix and B and -*> C are m by n matrices. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> On entry, SIDE specifies whether the symmetric matrix A -*> appears on the left or right in the operation as follows: -*> -*> SIDE = 'L' or 'l' C := alpha*A*B + beta*C, -*> -*> SIDE = 'R' or 'r' C := alpha*B*A + beta*C, -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the upper or lower -*> triangular part of the symmetric matrix A is to be -*> referenced as follows: -*> -*> UPLO = 'U' or 'u' Only the upper triangular part of the -*> symmetric matrix is to be referenced. -*> -*> UPLO = 'L' or 'l' Only the lower triangular part of the -*> symmetric matrix is to be referenced. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> On entry, M specifies the number of rows of the matrix C. -*> M must be at least zero. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the number of columns of the matrix C. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is DOUBLE PRECISION. -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension ( LDA, ka ), where ka is -*> m when SIDE = 'L' or 'l' and is n otherwise. -*> Before entry with SIDE = 'L' or 'l', the m by m part of -*> the array A must contain the symmetric matrix, such that -*> when UPLO = 'U' or 'u', the leading m by m upper triangular -*> part of the array A must contain the upper triangular part -*> of the symmetric matrix and the strictly lower triangular -*> part of A is not referenced, and when UPLO = 'L' or 'l', -*> the leading m by m lower triangular part of the array A -*> must contain the lower triangular part of the symmetric -*> matrix and the strictly upper triangular part of A is not -*> referenced. -*> Before entry with SIDE = 'R' or 'r', the n by n part of -*> the array A must contain the symmetric matrix, such that -*> when UPLO = 'U' or 'u', the leading n by n upper triangular -*> part of the array A must contain the upper triangular part -*> of the symmetric matrix and the strictly lower triangular -*> part of A is not referenced, and when UPLO = 'L' or 'l', -*> the leading n by n lower triangular part of the array A -*> must contain the lower triangular part of the symmetric -*> matrix and the strictly upper triangular part of A is not -*> referenced. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. When SIDE = 'L' or 'l' then -*> LDA must be at least max( 1, m ), otherwise LDA must be at -*> least max( 1, n ). -*> \endverbatim -*> -*> \param[in] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension ( LDB, N ) -*> Before entry, the leading m by n part of the array B must -*> contain the matrix B. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> On entry, LDB specifies the first dimension of B as declared -*> in the calling (sub) program. LDB must be at least -*> max( 1, m ). -*> \endverbatim -*> -*> \param[in] BETA -*> \verbatim -*> BETA is DOUBLE PRECISION. -*> On entry, BETA specifies the scalar beta. When BETA is -*> supplied as zero then C need not be set on input. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension ( LDC, N ) -*> Before entry, the leading m by n part of the array C must -*> contain the matrix C, except when beta is zero, in which -*> case C need not be set on entry. -*> On exit, the array C is overwritten by the m by n updated -*> matrix. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> On entry, LDC specifies the first dimension of C as declared -*> in the calling (sub) program. LDC must be at least -*> max( 1, m ). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level3 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 3 Blas routine. -*> -*> -- Written on 8-February-1989. -*> Jack Dongarra, Argonne National Laboratory. -*> Iain Duff, AERE Harwell. -*> Jeremy Du Croz, Numerical Algorithms Group Ltd. -*> Sven Hammarling, Numerical Algorithms Group Ltd. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* -* -- Reference BLAS level3 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA,BETA - INTEGER LDA,LDB,LDC,M,N - CHARACTER SIDE,UPLO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP1,TEMP2 - INTEGER I,INFO,J,K,NROWA - LOGICAL UPPER -* .. -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) -* .. -* -* Set NROWA as the number of rows of A. -* - IF (LSAME(SIDE,'L')) THEN - NROWA = M - ELSE - NROWA = N - END IF - UPPER = LSAME(UPLO,'U') -* -* Test the input parameters. -* - INFO = 0 - IF ((.NOT.LSAME(SIDE,'L')) .AND. (.NOT.LSAME(SIDE,'R'))) THEN - INFO = 1 - ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN - INFO = 2 - ELSE IF (M.LT.0) THEN - INFO = 3 - ELSE IF (N.LT.0) THEN - INFO = 4 - ELSE IF (LDA.LT.MAX(1,NROWA)) THEN - INFO = 7 - ELSE IF (LDB.LT.MAX(1,M)) THEN - INFO = 9 - ELSE IF (LDC.LT.MAX(1,M)) THEN - INFO = 12 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DSYMM ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((M.EQ.0) .OR. (N.EQ.0) .OR. - + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN -* -* And when alpha.eq.zero. -* - IF (ALPHA.EQ.ZERO) THEN - IF (BETA.EQ.ZERO) THEN - DO 20 J = 1,N - DO 10 I = 1,M - C(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1,N - DO 30 I = 1,M - C(I,J) = BETA*C(I,J) - 30 CONTINUE - 40 CONTINUE - END IF - RETURN - END IF -* -* Start the operations. -* - IF (LSAME(SIDE,'L')) THEN -* -* Form C := alpha*A*B + beta*C. -* - IF (UPPER) THEN - DO 70 J = 1,N - DO 60 I = 1,M - TEMP1 = ALPHA*B(I,J) - TEMP2 = ZERO - DO 50 K = 1,I - 1 - C(K,J) = C(K,J) + TEMP1*A(K,I) - TEMP2 = TEMP2 + B(K,J)*A(K,I) - 50 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = TEMP1*A(I,I) + ALPHA*TEMP2 - ELSE - C(I,J) = BETA*C(I,J) + TEMP1*A(I,I) + - + ALPHA*TEMP2 - END IF - 60 CONTINUE - 70 CONTINUE - ELSE - DO 100 J = 1,N - DO 90 I = M,1,-1 - TEMP1 = ALPHA*B(I,J) - TEMP2 = ZERO - DO 80 K = I + 1,M - C(K,J) = C(K,J) + TEMP1*A(K,I) - TEMP2 = TEMP2 + B(K,J)*A(K,I) - 80 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = TEMP1*A(I,I) + ALPHA*TEMP2 - ELSE - C(I,J) = BETA*C(I,J) + TEMP1*A(I,I) + - + ALPHA*TEMP2 - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form C := alpha*B*A + beta*C. -* - DO 170 J = 1,N - TEMP1 = ALPHA*A(J,J) - IF (BETA.EQ.ZERO) THEN - DO 110 I = 1,M - C(I,J) = TEMP1*B(I,J) - 110 CONTINUE - ELSE - DO 120 I = 1,M - C(I,J) = BETA*C(I,J) + TEMP1*B(I,J) - 120 CONTINUE - END IF - DO 140 K = 1,J - 1 - IF (UPPER) THEN - TEMP1 = ALPHA*A(K,J) - ELSE - TEMP1 = ALPHA*A(J,K) - END IF - DO 130 I = 1,M - C(I,J) = C(I,J) + TEMP1*B(I,K) - 130 CONTINUE - 140 CONTINUE - DO 160 K = J + 1,N - IF (UPPER) THEN - TEMP1 = ALPHA*A(J,K) - ELSE - TEMP1 = ALPHA*A(K,J) - END IF - DO 150 I = 1,M - C(I,J) = C(I,J) + TEMP1*B(I,K) - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE - END IF -* - RETURN -* -* End of DSYMM -* - END diff --git a/lib/linalg/dsymv.cpp b/lib/linalg/dsymv.cpp new file mode 100644 index 0000000000..07fea66571 --- /dev/null +++ b/lib/linalg/dsymv.cpp @@ -0,0 +1,155 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dsymv_(char *uplo, integer *n, doublereal *alpha, doublereal *a, integer *lda, doublereal *x, + integer *incx, doublereal *beta, doublereal *y, integer *incy, ftnlen uplo_len) +{ + integer a_dim1, a_offset, i__1, i__2; + integer i__, j, ix, iy, jx, jy, kx, ky, info; + doublereal 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 *)"DSYMV ", &info, (ftnlen)6); + return 0; + } + if (*n == 0 || *alpha == 0. && *beta == 1.) { + 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 != 1.) { + if (*incy == 1) { + if (*beta == 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = 0.; + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = *beta * y[i__]; + } + } + } else { + iy = ky; + if (*beta == 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = 0.; + iy += *incy; + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = *beta * y[iy]; + iy += *incy; + } + } + } + } + if (*alpha == 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) { + temp1 = *alpha * x[j]; + temp2 = 0.; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + y[i__] += temp1 * a[i__ + j * a_dim1]; + temp2 += a[i__ + j * a_dim1] * x[i__]; + } + y[j] = y[j] + temp1 * a[j + j * a_dim1] + *alpha * temp2; + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[jx]; + temp2 = 0.; + ix = kx; + iy = ky; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + y[iy] += temp1 * a[i__ + j * a_dim1]; + temp2 += a[i__ + j * a_dim1] * x[ix]; + ix += *incx; + iy += *incy; + } + y[jy] = y[jy] + temp1 * a[j + j * a_dim1] + *alpha * temp2; + jx += *incx; + jy += *incy; + } + } + } else { + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[j]; + temp2 = 0.; + y[j] += temp1 * a[j + j * a_dim1]; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + y[i__] += temp1 * a[i__ + j * a_dim1]; + temp2 += a[i__ + j * a_dim1] * x[i__]; + } + y[j] += *alpha * temp2; + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[jx]; + temp2 = 0.; + y[jy] += temp1 * a[j + j * a_dim1]; + ix = jx; + iy = jy; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + iy += *incy; + y[iy] += temp1 * a[i__ + j * a_dim1]; + temp2 += a[i__ + j * a_dim1] * x[ix]; + } + y[jy] += *alpha * temp2; + jx += *incx; + jy += *incy; + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dsymv.f b/lib/linalg/dsymv.f deleted file mode 100644 index 17310d7c62..0000000000 --- a/lib/linalg/dsymv.f +++ /dev/null @@ -1,330 +0,0 @@ -*> \brief \b DSYMV -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION ALPHA,BETA -* INTEGER INCX,INCY,LDA,N -* CHARACTER UPLO -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A(LDA,*),X(*),Y(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSYMV performs the matrix-vector operation -*> -*> y := alpha*A*x + beta*y, -*> -*> where alpha and beta are scalars, x and y are n element vectors and -*> A is an n by n symmetric matrix. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the upper or lower -*> triangular part of the array A is to be referenced as -*> follows: -*> -*> UPLO = 'U' or 'u' Only the upper triangular part of A -*> is to be referenced. -*> -*> UPLO = 'L' or 'l' Only the lower triangular part of A -*> is to be referenced. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the order of the matrix A. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is DOUBLE PRECISION. -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension ( LDA, N ) -*> Before entry with UPLO = 'U' or 'u', the leading n by n -*> upper triangular part of the array A must contain the upper -*> triangular part of the symmetric matrix and the strictly -*> lower triangular part of A is not referenced. -*> Before entry with UPLO = 'L' or 'l', the leading n by n -*> lower triangular part of the array A must contain the lower -*> triangular part of the symmetric matrix and the strictly -*> upper triangular part of A is not referenced. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. LDA must be at least -*> max( 1, n ). -*> \endverbatim -*> -*> \param[in] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension at least -*> ( 1 + ( n - 1 )*abs( INCX ) ). -*> Before entry, the incremented array X must contain the n -*> element vector x. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> On entry, INCX specifies the increment for the elements of -*> X. INCX must not be zero. -*> \endverbatim -*> -*> \param[in] BETA -*> \verbatim -*> BETA is DOUBLE PRECISION. -*> On entry, BETA specifies the scalar beta. When BETA is -*> supplied as zero then Y need not be set on input. -*> \endverbatim -*> -*> \param[in,out] Y -*> \verbatim -*> Y is DOUBLE PRECISION array, dimension at least -*> ( 1 + ( n - 1 )*abs( INCY ) ). -*> Before entry, the incremented array Y must contain the n -*> element vector y. On exit, Y is overwritten by the updated -*> vector y. -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> On entry, INCY specifies the increment for the elements of -*> Y. INCY must not be zero. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level2 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 2 Blas routine. -*> The vector and matrix arguments are not referenced when N = 0, or M = 0 -*> -*> -- Written on 22-October-1986. -*> Jack Dongarra, Argonne National Lab. -*> Jeremy Du Croz, Nag Central Office. -*> Sven Hammarling, Nag Central Office. -*> Richard Hanson, Sandia National Labs. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* -* -- Reference BLAS level2 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA,BETA - INTEGER INCX,INCY,LDA,N - CHARACTER UPLO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),X(*),Y(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP1,TEMP2 - INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN - INFO = 1 - ELSE IF (N.LT.0) THEN - INFO = 2 - ELSE IF (LDA.LT.MAX(1,N)) THEN - INFO = 5 - ELSE IF (INCX.EQ.0) THEN - INFO = 7 - ELSE IF (INCY.EQ.0) THEN - INFO = 10 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DSYMV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN -* -* Set up the start points in X and Y. -* - IF (INCX.GT.0) THEN - KX = 1 - ELSE - KX = 1 - (N-1)*INCX - END IF - IF (INCY.GT.0) THEN - KY = 1 - ELSE - KY = 1 - (N-1)*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* -* First form y := beta*y. -* - IF (BETA.NE.ONE) THEN - IF (INCY.EQ.1) THEN - IF (BETA.EQ.ZERO) THEN - DO 10 I = 1,N - Y(I) = ZERO - 10 CONTINUE - ELSE - DO 20 I = 1,N - Y(I) = BETA*Y(I) - 20 CONTINUE - END IF - ELSE - IY = KY - IF (BETA.EQ.ZERO) THEN - DO 30 I = 1,N - Y(IY) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40 I = 1,N - Y(IY) = BETA*Y(IY) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF (ALPHA.EQ.ZERO) RETURN - IF (LSAME(UPLO,'U')) THEN -* -* Form y when A is stored in upper triangle. -* - IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN - DO 60 J = 1,N - TEMP1 = ALPHA*X(J) - TEMP2 = ZERO - DO 50 I = 1,J - 1 - Y(I) = Y(I) + TEMP1*A(I,J) - TEMP2 = TEMP2 + A(I,J)*X(I) - 50 CONTINUE - Y(J) = Y(J) + TEMP1*A(J,J) + ALPHA*TEMP2 - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80 J = 1,N - TEMP1 = ALPHA*X(JX) - TEMP2 = ZERO - IX = KX - IY = KY - DO 70 I = 1,J - 1 - Y(IY) = Y(IY) + TEMP1*A(I,J) - TEMP2 = TEMP2 + A(I,J)*X(IX) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y(JY) = Y(JY) + TEMP1*A(J,J) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - ELSE -* -* Form y when A is stored in lower triangle. -* - IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN - DO 100 J = 1,N - TEMP1 = ALPHA*X(J) - TEMP2 = ZERO - Y(J) = Y(J) + TEMP1*A(J,J) - DO 90 I = J + 1,N - Y(I) = Y(I) + TEMP1*A(I,J) - TEMP2 = TEMP2 + A(I,J)*X(I) - 90 CONTINUE - Y(J) = Y(J) + ALPHA*TEMP2 - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120 J = 1,N - TEMP1 = ALPHA*X(JX) - TEMP2 = ZERO - Y(JY) = Y(JY) + TEMP1*A(J,J) - IX = JX - IY = JY - DO 110 I = J + 1,N - IX = IX + INCX - IY = IY + INCY - Y(IY) = Y(IY) + TEMP1*A(I,J) - TEMP2 = TEMP2 + A(I,J)*X(IX) - 110 CONTINUE - Y(JY) = Y(JY) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYMV -* - END diff --git a/lib/linalg/dsyr2.cpp b/lib/linalg/dsyr2.cpp new file mode 100644 index 0000000000..b3e43c9b9b --- /dev/null +++ b/lib/linalg/dsyr2.cpp @@ -0,0 +1,120 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dsyr2_(char *uplo, integer *n, doublereal *alpha, doublereal *x, integer *incx, doublereal *y, + integer *incy, doublereal *a, integer *lda, ftnlen uplo_len) +{ + integer a_dim1, a_offset, i__1, i__2; + integer i__, j, ix, iy, jx, jy, kx, ky, info; + doublereal temp1, temp2; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern int xerbla_(char *, integer *, ftnlen); + --x; + --y; + 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 (*incy == 0) { + info = 7; + } else if (*lda < max(1, *n)) { + info = 9; + } + if (info != 0) { + xerbla_((char *)"DSYR2 ", &info, (ftnlen)6); + return 0; + } + if (*n == 0 || *alpha == 0.) { + return 0; + } + if (*incx != 1 || *incy != 1) { + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + jx = kx; + jy = ky; + } + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0. || y[j] != 0.) { + temp1 = *alpha * y[j]; + temp2 = *alpha * x[j]; + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[i__] * temp1 + y[i__] * temp2; + } + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0. || y[jy] != 0.) { + temp1 = *alpha * y[jy]; + temp2 = *alpha * x[jx]; + ix = kx; + iy = ky; + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[ix] * temp1 + y[iy] * temp2; + ix += *incx; + iy += *incy; + } + } + jx += *incx; + jy += *incy; + } + } + } else { + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0. || y[j] != 0.) { + temp1 = *alpha * y[j]; + temp2 = *alpha * x[j]; + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[i__] * temp1 + y[i__] * temp2; + } + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0. || y[jy] != 0.) { + temp1 = *alpha * y[jy]; + temp2 = *alpha * x[jx]; + ix = jx; + iy = jy; + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[ix] * temp1 + y[iy] * temp2; + ix += *incx; + iy += *incy; + } + } + jx += *incx; + jy += *incy; + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dsyr2.f b/lib/linalg/dsyr2.f deleted file mode 100644 index 4bad19b96b..0000000000 --- a/lib/linalg/dsyr2.f +++ /dev/null @@ -1,295 +0,0 @@ -*> \brief \b DSYR2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION ALPHA -* INTEGER INCX,INCY,LDA,N -* CHARACTER UPLO -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A(LDA,*),X(*),Y(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSYR2 performs the symmetric rank 2 operation -*> -*> A := alpha*x*y**T + alpha*y*x**T + A, -*> -*> where alpha is a scalar, x and y are n element vectors and A is an n -*> by n symmetric matrix. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the upper or lower -*> triangular part of the array A is to be referenced as -*> follows: -*> -*> UPLO = 'U' or 'u' Only the upper triangular part of A -*> is to be referenced. -*> -*> UPLO = 'L' or 'l' Only the lower triangular part of A -*> is to be referenced. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the order of the matrix A. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is DOUBLE PRECISION. -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension at least -*> ( 1 + ( n - 1 )*abs( INCX ) ). -*> Before entry, the incremented array X must contain the n -*> element vector x. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> On entry, INCX specifies the increment for the elements of -*> X. INCX must not be zero. -*> \endverbatim -*> -*> \param[in] Y -*> \verbatim -*> Y is DOUBLE PRECISION array, dimension at least -*> ( 1 + ( n - 1 )*abs( INCY ) ). -*> Before entry, the incremented array Y must contain the n -*> element vector y. -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> On entry, INCY specifies the increment for the elements of -*> Y. INCY must not be zero. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension ( LDA, N ) -*> Before entry with UPLO = 'U' or 'u', the leading n by n -*> upper triangular part of the array A must contain the upper -*> triangular part of the symmetric matrix and the strictly -*> lower triangular part of A is not referenced. On exit, the -*> upper triangular part of the array A is overwritten by the -*> upper triangular part of the updated matrix. -*> Before entry with UPLO = 'L' or 'l', the leading n by n -*> lower triangular part of the array A must contain the lower -*> triangular part of the symmetric matrix and the strictly -*> upper triangular part of A is not referenced. On exit, the -*> lower triangular part of the array A is overwritten by the -*> lower triangular part of the updated matrix. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. LDA must be at least -*> max( 1, n ). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level2 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 2 Blas routine. -*> -*> -- Written on 22-October-1986. -*> Jack Dongarra, Argonne National Lab. -*> Jeremy Du Croz, Nag Central Office. -*> Sven Hammarling, Nag Central Office. -*> Richard Hanson, Sandia National Labs. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* -* -- Reference BLAS level2 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX,INCY,LDA,N - CHARACTER UPLO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),X(*),Y(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER (ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP1,TEMP2 - INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN - INFO = 1 - ELSE IF (N.LT.0) THEN - INFO = 2 - ELSE IF (INCX.EQ.0) THEN - INFO = 5 - ELSE IF (INCY.EQ.0) THEN - INFO = 7 - ELSE IF (LDA.LT.MAX(1,N)) THEN - INFO = 9 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DSYR2 ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN -* -* Set up the start points in X and Y if the increments are not both -* unity. -* - IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN - IF (INCX.GT.0) THEN - KX = 1 - ELSE - KX = 1 - (N-1)*INCX - END IF - IF (INCY.GT.0) THEN - KY = 1 - ELSE - KY = 1 - (N-1)*INCY - END IF - JX = KX - JY = KY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* - IF (LSAME(UPLO,'U')) THEN -* -* Form A when A is stored in the upper triangle. -* - IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN - DO 20 J = 1,N - IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN - TEMP1 = ALPHA*Y(J) - TEMP2 = ALPHA*X(J) - DO 10 I = 1,J - A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2 - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - DO 40 J = 1,N - IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN - TEMP1 = ALPHA*Y(JY) - TEMP2 = ALPHA*X(JX) - IX = KX - IY = KY - DO 30 I = 1,J - A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2 - IX = IX + INCX - IY = IY + INCY - 30 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - 40 CONTINUE - END IF - ELSE -* -* Form A when A is stored in the lower triangle. -* - IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN - DO 60 J = 1,N - IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN - TEMP1 = ALPHA*Y(J) - TEMP2 = ALPHA*X(J) - DO 50 I = J,N - A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2 - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - DO 80 J = 1,N - IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN - TEMP1 = ALPHA*Y(JY) - TEMP2 = ALPHA*X(JX) - IX = JX - IY = JY - DO 70 I = J,N - A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2 - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYR2 -* - END diff --git a/lib/linalg/dsyr2k.cpp b/lib/linalg/dsyr2k.cpp new file mode 100644 index 0000000000..9928b2e618 --- /dev/null +++ b/lib/linalg/dsyr2k.cpp @@ -0,0 +1,201 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dsyr2k_(char *uplo, char *trans, integer *n, integer *k, doublereal *alpha, doublereal *a, + integer *lda, doublereal *b, integer *ldb, doublereal *beta, doublereal *c__, + integer *ldc, ftnlen uplo_len, ftnlen trans_len) +{ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, i__3; + integer i__, j, l, info; + doublereal 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_(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 *)"T", (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 (*ldb < max(1, nrowa)) { + info = 9; + } else if (*ldc < max(1, *n)) { + info = 12; + } + if (info != 0) { + xerbla_((char *)"DSYR2K", &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__) { + c__[i__ + j * c_dim1] = 0.; + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; + } + } + } + } else { + if (*beta == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; + } + } + } + } + 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__) { + c__[i__ + j * c_dim1] = 0.; + } + } else if (*beta != 1.) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + if (a[j + l * a_dim1] != 0. || b[j + l * b_dim1] != 0.) { + temp1 = *alpha * b[j + l * b_dim1]; + temp2 = *alpha * a[j + l * a_dim1]; + i__3 = j; + for (i__ = 1; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] = c__[i__ + j * c_dim1] + + a[i__ + l * a_dim1] * temp1 + + b[i__ + l * b_dim1] * temp2; + } + } + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; + } + } else if (*beta != 1.) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + if (a[j + l * a_dim1] != 0. || b[j + l * b_dim1] != 0.) { + temp1 = *alpha * b[j + l * b_dim1]; + temp2 = *alpha * a[j + l * a_dim1]; + i__3 = *n; + for (i__ = j; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] = c__[i__ + j * c_dim1] + + a[i__ + l * a_dim1] * temp1 + + b[i__ + l * b_dim1] * temp2; + } + } + } + } + } + } else { + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + temp1 = 0.; + temp2 = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + temp1 += a[l + i__ * a_dim1] * b[l + j * b_dim1]; + temp2 += b[l + i__ * b_dim1] * a[l + j * a_dim1]; + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = *alpha * temp1 + *alpha * temp2; + } else { + c__[i__ + j * c_dim1] = + *beta * c__[i__ + j * c_dim1] + *alpha * temp1 + *alpha * temp2; + } + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + temp1 = 0.; + temp2 = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + temp1 += a[l + i__ * a_dim1] * b[l + j * b_dim1]; + temp2 += b[l + i__ * b_dim1] * a[l + j * a_dim1]; + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = *alpha * temp1 + *alpha * temp2; + } else { + c__[i__ + j * c_dim1] = + *beta * c__[i__ + j * c_dim1] + *alpha * temp1 + *alpha * temp2; + } + } + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dsyr2k.f b/lib/linalg/dsyr2k.f deleted file mode 100644 index f5d16e0854..0000000000 --- a/lib/linalg/dsyr2k.f +++ /dev/null @@ -1,396 +0,0 @@ -*> \brief \b DSYR2K -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION ALPHA,BETA -* INTEGER K,LDA,LDB,LDC,N -* CHARACTER TRANS,UPLO -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSYR2K performs one of the symmetric rank 2k operations -*> -*> C := alpha*A*B**T + alpha*B*A**T + beta*C, -*> -*> or -*> -*> C := alpha*A**T*B + alpha*B**T*A + beta*C, -*> -*> where alpha and beta are scalars, C is an n by n symmetric matrix -*> and A and B are n by k matrices in the first case and k by n -*> matrices in the second case. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the upper or lower -*> triangular part of the array C is to be referenced as -*> follows: -*> -*> UPLO = 'U' or 'u' Only the upper triangular part of C -*> is to be referenced. -*> -*> UPLO = 'L' or 'l' Only the lower triangular part of C -*> is to be referenced. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> On entry, TRANS specifies the operation to be performed as -*> follows: -*> -*> TRANS = 'N' or 'n' C := alpha*A*B**T + alpha*B*A**T + -*> beta*C. -*> -*> TRANS = 'T' or 't' C := alpha*A**T*B + alpha*B**T*A + -*> beta*C. -*> -*> TRANS = 'C' or 'c' C := alpha*A**T*B + alpha*B**T*A + -*> beta*C. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the order of the matrix C. N must be -*> at least zero. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> On entry with TRANS = 'N' or 'n', K specifies the number -*> of columns of the matrices A and B, and on entry with -*> TRANS = 'T' or 't' or 'C' or 'c', K specifies the number -*> of rows of the matrices A and B. K must be at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is DOUBLE PRECISION. -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension ( LDA, ka ), where ka is -*> k when TRANS = 'N' or 'n', and is n otherwise. -*> Before entry with TRANS = 'N' or 'n', the leading n by k -*> part of the array A must contain the matrix A, otherwise -*> the leading k by n part of the array A must contain the -*> matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. When TRANS = 'N' or 'n' -*> then LDA must be at least max( 1, n ), otherwise LDA must -*> be at least max( 1, k ). -*> \endverbatim -*> -*> \param[in] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension ( LDB, kb ), where kb is -*> k when TRANS = 'N' or 'n', and is n otherwise. -*> Before entry with TRANS = 'N' or 'n', the leading n by k -*> part of the array B must contain the matrix B, otherwise -*> the leading k by n part of the array B must contain the -*> matrix B. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> On entry, LDB specifies the first dimension of B as declared -*> in the calling (sub) program. When TRANS = 'N' or 'n' -*> then LDB must be at least max( 1, n ), otherwise LDB must -*> be at least max( 1, k ). -*> \endverbatim -*> -*> \param[in] BETA -*> \verbatim -*> BETA is DOUBLE PRECISION. -*> On entry, BETA specifies the scalar beta. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension ( LDC, N ) -*> Before entry with UPLO = 'U' or 'u', the leading n by n -*> upper triangular part of the array C must contain the upper -*> triangular part of the symmetric matrix and the strictly -*> lower triangular part of C is not referenced. On exit, the -*> upper triangular part of the array C is overwritten by the -*> upper triangular part of the updated matrix. -*> Before entry with UPLO = 'L' or 'l', the leading n by n -*> lower triangular part of the array C must contain the lower -*> triangular part of the symmetric matrix and the strictly -*> upper triangular part of C is not referenced. On exit, the -*> lower triangular part of the array C is overwritten by the -*> lower triangular part of the updated matrix. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> On entry, LDC specifies the first dimension of C as declared -*> in the calling (sub) program. LDC must be at least -*> max( 1, n ). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level3 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 3 Blas routine. -*> -*> -*> -- Written on 8-February-1989. -*> Jack Dongarra, Argonne National Laboratory. -*> Iain Duff, AERE Harwell. -*> Jeremy Du Croz, Numerical Algorithms Group Ltd. -*> Sven Hammarling, Numerical Algorithms Group Ltd. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* -* -- Reference BLAS level3 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA,BETA - INTEGER K,LDA,LDB,LDC,N - CHARACTER TRANS,UPLO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP1,TEMP2 - INTEGER I,INFO,J,L,NROWA - LOGICAL UPPER -* .. -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) -* .. -* -* Test the input parameters. -* - IF (LSAME(TRANS,'N')) THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME(UPLO,'U') -* - INFO = 0 - IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN - INFO = 1 - ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND. - + (.NOT.LSAME(TRANS,'T')) .AND. - + (.NOT.LSAME(TRANS,'C'))) THEN - INFO = 2 - ELSE IF (N.LT.0) THEN - INFO = 3 - ELSE IF (K.LT.0) THEN - INFO = 4 - ELSE IF (LDA.LT.MAX(1,NROWA)) THEN - INFO = 7 - ELSE IF (LDB.LT.MAX(1,NROWA)) THEN - INFO = 9 - ELSE IF (LDC.LT.MAX(1,N)) THEN - INFO = 12 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DSYR2K',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR. - + (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN -* -* And when alpha.eq.zero. -* - IF (ALPHA.EQ.ZERO) THEN - IF (UPPER) THEN - IF (BETA.EQ.ZERO) THEN - DO 20 J = 1,N - DO 10 I = 1,J - C(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1,N - DO 30 I = 1,J - C(I,J) = BETA*C(I,J) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE - IF (BETA.EQ.ZERO) THEN - DO 60 J = 1,N - DO 50 I = J,N - C(I,J) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80 J = 1,N - DO 70 I = J,N - C(I,J) = BETA*C(I,J) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF (LSAME(TRANS,'N')) THEN -* -* Form C := alpha*A*B**T + alpha*B*A**T + C. -* - IF (UPPER) THEN - DO 130 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 90 I = 1,J - C(I,J) = ZERO - 90 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 100 I = 1,J - C(I,J) = BETA*C(I,J) - 100 CONTINUE - END IF - DO 120 L = 1,K - IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN - TEMP1 = ALPHA*B(J,L) - TEMP2 = ALPHA*A(J,L) - DO 110 I = 1,J - C(I,J) = C(I,J) + A(I,L)*TEMP1 + - + B(I,L)*TEMP2 - 110 CONTINUE - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 140 I = J,N - C(I,J) = ZERO - 140 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 150 I = J,N - C(I,J) = BETA*C(I,J) - 150 CONTINUE - END IF - DO 170 L = 1,K - IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN - TEMP1 = ALPHA*B(J,L) - TEMP2 = ALPHA*A(J,L) - DO 160 I = J,N - C(I,J) = C(I,J) + A(I,L)*TEMP1 + - + B(I,L)*TEMP2 - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*A**T*B + alpha*B**T*A + C. -* - IF (UPPER) THEN - DO 210 J = 1,N - DO 200 I = 1,J - TEMP1 = ZERO - TEMP2 = ZERO - DO 190 L = 1,K - TEMP1 = TEMP1 + A(L,I)*B(L,J) - TEMP2 = TEMP2 + B(L,I)*A(L,J) - 190 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2 - ELSE - C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 + - + ALPHA*TEMP2 - END IF - 200 CONTINUE - 210 CONTINUE - ELSE - DO 240 J = 1,N - DO 230 I = J,N - TEMP1 = ZERO - TEMP2 = ZERO - DO 220 L = 1,K - TEMP1 = TEMP1 + A(L,I)*B(L,J) - TEMP2 = TEMP2 + B(L,I)*A(L,J) - 220 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2 - ELSE - C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 + - + ALPHA*TEMP2 - END IF - 230 CONTINUE - 240 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYR2K -* - END diff --git a/lib/linalg/dsyrk.cpp b/lib/linalg/dsyrk.cpp new file mode 100644 index 0000000000..1c383f311f --- /dev/null +++ b/lib/linalg/dsyrk.cpp @@ -0,0 +1,184 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dsyrk_(char *uplo, char *trans, integer *n, integer *k, doublereal *alpha, doublereal *a, + integer *lda, doublereal *beta, doublereal *c__, integer *ldc, ftnlen uplo_len, + ftnlen trans_len) +{ + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3; + integer i__, j, l, info; + doublereal temp; + 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; + 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 *)"T", (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 *)"DSYRK ", &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__) { + c__[i__ + j * c_dim1] = 0.; + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; + } + } + } + } else { + if (*beta == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; + } + } + } + } + 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__) { + c__[i__ + j * c_dim1] = 0.; + } + } else if (*beta != 1.) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + if (a[j + l * a_dim1] != 0.) { + temp = *alpha * a[j + l * a_dim1]; + i__3 = j; + for (i__ = 1; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] += temp * a[i__ + l * a_dim1]; + } + } + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; + } + } else if (*beta != 1.) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + if (a[j + l * a_dim1] != 0.) { + temp = *alpha * a[j + l * a_dim1]; + i__3 = *n; + for (i__ = j; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] += temp * a[i__ + l * a_dim1]; + } + } + } + } + } + } else { + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + temp += a[l + i__ * a_dim1] * a[l + j * a_dim1]; + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = *alpha * temp; + } else { + c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[i__ + j * c_dim1]; + } + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + temp = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + temp += a[l + i__ * a_dim1] * a[l + j * a_dim1]; + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = *alpha * temp; + } else { + c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[i__ + j * c_dim1]; + } + } + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dsyrk.f b/lib/linalg/dsyrk.f deleted file mode 100644 index 0548c0ce2f..0000000000 --- a/lib/linalg/dsyrk.f +++ /dev/null @@ -1,361 +0,0 @@ -*> \brief \b DSYRK -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION ALPHA,BETA -* INTEGER K,LDA,LDC,N -* CHARACTER TRANS,UPLO -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A(LDA,*),C(LDC,*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSYRK performs one of the symmetric rank k operations -*> -*> C := alpha*A*A**T + beta*C, -*> -*> or -*> -*> C := alpha*A**T*A + beta*C, -*> -*> where alpha and beta are scalars, C is an n by n symmetric matrix -*> and A is an n by k matrix in the first case and a k by n matrix -*> in the second case. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the upper or lower -*> triangular part of the array C is to be referenced as -*> follows: -*> -*> UPLO = 'U' or 'u' Only the upper triangular part of C -*> is to be referenced. -*> -*> UPLO = 'L' or 'l' Only the lower triangular part of C -*> is to be referenced. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> On entry, TRANS specifies the operation to be performed as -*> follows: -*> -*> TRANS = 'N' or 'n' C := alpha*A*A**T + beta*C. -*> -*> TRANS = 'T' or 't' C := alpha*A**T*A + beta*C. -*> -*> TRANS = 'C' or 'c' C := alpha*A**T*A + beta*C. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the order of the matrix C. N must be -*> at least zero. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> On entry with TRANS = 'N' or 'n', K specifies the number -*> of columns of the matrix A, and on entry with -*> TRANS = 'T' or 't' or 'C' or 'c', K specifies the number -*> of rows of the matrix A. K must be at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is DOUBLE PRECISION. -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension ( LDA, ka ), where ka is -*> k when TRANS = 'N' or 'n', and is n otherwise. -*> Before entry with TRANS = 'N' or 'n', the leading n by k -*> part of the array A must contain the matrix A, otherwise -*> the leading k by n part of the array A must contain the -*> matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. When TRANS = 'N' or 'n' -*> then LDA must be at least max( 1, n ), otherwise LDA must -*> be at least max( 1, k ). -*> \endverbatim -*> -*> \param[in] BETA -*> \verbatim -*> BETA is DOUBLE PRECISION. -*> On entry, BETA specifies the scalar beta. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension ( LDC, N ) -*> Before entry with UPLO = 'U' or 'u', the leading n by n -*> upper triangular part of the array C must contain the upper -*> triangular part of the symmetric matrix and the strictly -*> lower triangular part of C is not referenced. On exit, the -*> upper triangular part of the array C is overwritten by the -*> upper triangular part of the updated matrix. -*> Before entry with UPLO = 'L' or 'l', the leading n by n -*> lower triangular part of the array C must contain the lower -*> triangular part of the symmetric matrix and the strictly -*> upper triangular part of C is not referenced. On exit, the -*> lower triangular part of the array C is overwritten by the -*> lower triangular part of the updated matrix. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> On entry, LDC specifies the first dimension of C as declared -*> in the calling (sub) program. LDC must be at least -*> max( 1, n ). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level3 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 3 Blas routine. -*> -*> -- Written on 8-February-1989. -*> Jack Dongarra, Argonne National Laboratory. -*> Iain Duff, AERE Harwell. -*> Jeremy Du Croz, Numerical Algorithms Group Ltd. -*> Sven Hammarling, Numerical Algorithms Group Ltd. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) -* -* -- Reference BLAS level3 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA,BETA - INTEGER K,LDA,LDC,N - CHARACTER TRANS,UPLO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),C(LDC,*) -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,J,L,NROWA - LOGICAL UPPER -* .. -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) -* .. -* -* Test the input parameters. -* - IF (LSAME(TRANS,'N')) THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME(UPLO,'U') -* - INFO = 0 - IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN - INFO = 1 - ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND. - + (.NOT.LSAME(TRANS,'T')) .AND. - + (.NOT.LSAME(TRANS,'C'))) THEN - INFO = 2 - ELSE IF (N.LT.0) THEN - INFO = 3 - ELSE IF (K.LT.0) THEN - INFO = 4 - ELSE IF (LDA.LT.MAX(1,NROWA)) THEN - INFO = 7 - ELSE IF (LDC.LT.MAX(1,N)) THEN - INFO = 10 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DSYRK ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR. - + (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN -* -* And when alpha.eq.zero. -* - IF (ALPHA.EQ.ZERO) THEN - IF (UPPER) THEN - IF (BETA.EQ.ZERO) THEN - DO 20 J = 1,N - DO 10 I = 1,J - C(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1,N - DO 30 I = 1,J - C(I,J) = BETA*C(I,J) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE - IF (BETA.EQ.ZERO) THEN - DO 60 J = 1,N - DO 50 I = J,N - C(I,J) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80 J = 1,N - DO 70 I = J,N - C(I,J) = BETA*C(I,J) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF (LSAME(TRANS,'N')) THEN -* -* Form C := alpha*A*A**T + beta*C. -* - IF (UPPER) THEN - DO 130 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 90 I = 1,J - C(I,J) = ZERO - 90 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 100 I = 1,J - C(I,J) = BETA*C(I,J) - 100 CONTINUE - END IF - DO 120 L = 1,K - IF (A(J,L).NE.ZERO) THEN - TEMP = ALPHA*A(J,L) - DO 110 I = 1,J - C(I,J) = C(I,J) + TEMP*A(I,L) - 110 CONTINUE - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 140 I = J,N - C(I,J) = ZERO - 140 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 150 I = J,N - C(I,J) = BETA*C(I,J) - 150 CONTINUE - END IF - DO 170 L = 1,K - IF (A(J,L).NE.ZERO) THEN - TEMP = ALPHA*A(J,L) - DO 160 I = J,N - C(I,J) = C(I,J) + TEMP*A(I,L) - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*A**T*A + beta*C. -* - IF (UPPER) THEN - DO 210 J = 1,N - DO 200 I = 1,J - TEMP = ZERO - DO 190 L = 1,K - TEMP = TEMP + A(L,I)*A(L,J) - 190 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 200 CONTINUE - 210 CONTINUE - ELSE - DO 240 J = 1,N - DO 230 I = J,N - TEMP = ZERO - DO 220 L = 1,K - TEMP = TEMP + A(L,I)*A(L,J) - 220 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 230 CONTINUE - 240 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYRK -* - END diff --git a/lib/linalg/dsytd2.cpp b/lib/linalg/dsytd2.cpp new file mode 100644 index 0000000000..57362588af --- /dev/null +++ b/lib/linalg/dsytd2.cpp @@ -0,0 +1,98 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +static doublereal c_b8 = 0.; +static doublereal c_b14 = -1.; +int dsytd2_(char *uplo, integer *n, doublereal *a, integer *lda, doublereal *d__, doublereal *e, + doublereal *tau, integer *info, ftnlen uplo_len) +{ + integer a_dim1, a_offset, i__1, i__2, i__3; + integer i__; + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *); + doublereal taui; + extern int dsyr2_(char *, integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, integer *, ftnlen); + doublereal alpha; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern int daxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *); + logical upper; + extern int dsymv_(char *, integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, ftnlen), + dlarfg_(integer *, doublereal *, doublereal *, integer *, doublereal *), + xerbla_(char *, integer *, ftnlen); + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --d__; + --e; + --tau; + *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 *)"DSYTD2", &i__1, (ftnlen)6); + return 0; + } + if (*n <= 0) { + return 0; + } + if (upper) { + for (i__ = *n - 1; i__ >= 1; --i__) { + dlarfg_(&i__, &a[i__ + (i__ + 1) * a_dim1], &a[(i__ + 1) * a_dim1 + 1], &c__1, &taui); + e[i__] = a[i__ + (i__ + 1) * a_dim1]; + if (taui != 0.) { + a[i__ + (i__ + 1) * a_dim1] = 1.; + dsymv_(uplo, &i__, &taui, &a[a_offset], lda, &a[(i__ + 1) * a_dim1 + 1], &c__1, + &c_b8, &tau[1], &c__1, (ftnlen)1); + alpha = taui * -.5 * ddot_(&i__, &tau[1], &c__1, &a[(i__ + 1) * a_dim1 + 1], &c__1); + daxpy_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &tau[1], &c__1); + dsyr2_(uplo, &i__, &c_b14, &a[(i__ + 1) * a_dim1 + 1], &c__1, &tau[1], &c__1, + &a[a_offset], lda, (ftnlen)1); + a[i__ + (i__ + 1) * a_dim1] = e[i__]; + } + d__[i__ + 1] = a[i__ + 1 + (i__ + 1) * a_dim1]; + tau[i__] = taui; + } + d__[1] = a[a_dim1 + 1]; + } else { + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n - i__; + i__3 = i__ + 2; + dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3, *n) + i__ * a_dim1], &c__1, + &taui); + e[i__] = a[i__ + 1 + i__ * a_dim1]; + if (taui != 0.) { + a[i__ + 1 + i__ * a_dim1] = 1.; + i__2 = *n - i__; + dsymv_(uplo, &i__2, &taui, &a[i__ + 1 + (i__ + 1) * a_dim1], lda, + &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b8, &tau[i__], &c__1, (ftnlen)1); + i__2 = *n - i__; + alpha = + taui * -.5 * ddot_(&i__2, &tau[i__], &c__1, &a[i__ + 1 + i__ * a_dim1], &c__1); + i__2 = *n - i__; + daxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[i__], &c__1); + i__2 = *n - i__; + dsyr2_(uplo, &i__2, &c_b14, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[i__], &c__1, + &a[i__ + 1 + (i__ + 1) * a_dim1], lda, (ftnlen)1); + a[i__ + 1 + i__ * a_dim1] = e[i__]; + } + d__[i__] = a[i__ + i__ * a_dim1]; + tau[i__] = taui; + } + d__[*n] = a[*n + *n * a_dim1]; + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dsytd2.f b/lib/linalg/dsytd2.f deleted file mode 100644 index 977b6daa41..0000000000 --- a/lib/linalg/dsytd2.f +++ /dev/null @@ -1,320 +0,0 @@ -*> \brief \b DSYTD2 reduces a symmetric matrix to real symmetric tridiagonal form by an orthogonal similarity transformation (unblocked algorithm). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DSYTD2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal -*> form T by an orthogonal similarity transformation: Q**T * A * Q = T. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> Specifies whether the upper or lower triangular part of the -*> symmetric matrix A is stored: -*> = 'U': Upper triangular -*> = 'L': Lower triangular -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the symmetric matrix A. If UPLO = 'U', the leading -*> n-by-n upper triangular part of A contains the upper -*> triangular part of the matrix A, and the strictly lower -*> triangular part of A is not referenced. If UPLO = 'L', the -*> leading n-by-n lower triangular part of A contains the lower -*> triangular part of the matrix A, and the strictly upper -*> triangular part of A is not referenced. -*> On exit, if UPLO = 'U', the diagonal and first superdiagonal -*> of A are overwritten by the corresponding elements of the -*> tridiagonal matrix T, and the elements above the first -*> superdiagonal, with the array TAU, represent the orthogonal -*> matrix Q as a product of elementary reflectors; if UPLO -*> = 'L', the diagonal and first subdiagonal of A are over- -*> written by the corresponding elements of the tridiagonal -*> matrix T, and the elements below the first subdiagonal, with -*> the array TAU, represent the orthogonal matrix Q as a product -*> of elementary reflectors. See Further Details. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> The diagonal elements of the tridiagonal matrix T: -*> D(i) = A(i,i). -*> \endverbatim -*> -*> \param[out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N-1) -*> The off-diagonal elements of the tridiagonal matrix T: -*> E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. -*> \endverbatim -*> -*> \param[out] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (N-1) -*> The scalar factors of the elementary reflectors (see Further -*> Details). -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleSYcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> If UPLO = 'U', the matrix Q is represented as a product of elementary -*> reflectors -*> -*> Q = H(n-1) . . . H(2) H(1). -*> -*> Each H(i) has the form -*> -*> H(i) = I - tau * v * v**T -*> -*> where tau is a real scalar, and v is a real vector with -*> v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in -*> A(1:i-1,i+1), and tau in TAU(i). -*> -*> If UPLO = 'L', the matrix Q is represented as a product of elementary -*> reflectors -*> -*> Q = H(1) H(2) . . . H(n-1). -*> -*> Each H(i) has the form -*> -*> H(i) = I - tau * v * v**T -*> -*> where tau is a real scalar, and v is a real vector with -*> v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), -*> and tau in TAU(i). -*> -*> The contents of A on exit are illustrated by the following examples -*> with n = 5: -*> -*> if UPLO = 'U': if UPLO = 'L': -*> -*> ( d e v2 v3 v4 ) ( d ) -*> ( d e v3 v4 ) ( e d ) -*> ( d e v4 ) ( v1 e d ) -*> ( d e ) ( v1 v2 e d ) -*> ( d ) ( v1 v2 v3 e d ) -*> -*> where d and e denote diagonal and off-diagonal elements of T, and vi -*> denotes an element of the vector defining H(i). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO, HALF - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0, - $ HALF = 1.0D0 / 2.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I - DOUBLE PRECISION ALPHA, TAUI -* .. -* .. External Subroutines .. - EXTERNAL DAXPY, DLARFG, DSYMV, DSYR2, XERBLA -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DDOT - EXTERNAL LSAME, DDOT -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSYTD2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Reduce the upper triangle of A -* - DO 10 I = N - 1, 1, -1 -* -* Generate elementary reflector H(i) = I - tau * v * v**T -* to annihilate A(1:i-1,i+1) -* - CALL DLARFG( I, A( I, I+1 ), A( 1, I+1 ), 1, TAUI ) - E( I ) = A( I, I+1 ) -* - IF( TAUI.NE.ZERO ) THEN -* -* Apply H(i) from both sides to A(1:i,1:i) -* - A( I, I+1 ) = ONE -* -* Compute x := tau * A * v storing x in TAU(1:i) -* - CALL DSYMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO, - $ TAU, 1 ) -* -* Compute w := x - 1/2 * tau * (x**T * v) * v -* - ALPHA = -HALF*TAUI*DDOT( I, TAU, 1, A( 1, I+1 ), 1 ) - CALL DAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 ) -* -* Apply the transformation as a rank-2 update: -* A := A - v * w**T - w * v**T -* - CALL DSYR2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A, - $ LDA ) -* - A( I, I+1 ) = E( I ) - END IF - D( I+1 ) = A( I+1, I+1 ) - TAU( I ) = TAUI - 10 CONTINUE - D( 1 ) = A( 1, 1 ) - ELSE -* -* Reduce the lower triangle of A -* - DO 20 I = 1, N - 1 -* -* Generate elementary reflector H(i) = I - tau * v * v**T -* to annihilate A(i+2:n,i) -* - CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, - $ TAUI ) - E( I ) = A( I+1, I ) -* - IF( TAUI.NE.ZERO ) THEN -* -* Apply H(i) from both sides to A(i+1:n,i+1:n) -* - A( I+1, I ) = ONE -* -* Compute x := tau * A * v storing y in TAU(i:n-1) -* - CALL DSYMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA, - $ A( I+1, I ), 1, ZERO, TAU( I ), 1 ) -* -* Compute w := x - 1/2 * tau * (x**T * v) * v -* - ALPHA = -HALF*TAUI*DDOT( N-I, TAU( I ), 1, A( I+1, I ), - $ 1 ) - CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 ) -* -* Apply the transformation as a rank-2 update: -* A := A - v * w**T - w * v**T -* - CALL DSYR2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1, - $ A( I+1, I+1 ), LDA ) -* - A( I+1, I ) = E( I ) - END IF - D( I ) = A( I, I ) - TAU( I ) = TAUI - 20 CONTINUE - D( N ) = A( N, N ) - END IF -* - RETURN -* -* End of DSYTD2 -* - END diff --git a/lib/linalg/dsytrd.cpp b/lib/linalg/dsytrd.cpp new file mode 100644 index 0000000000..a414b9a530 --- /dev/null +++ b/lib/linalg/dsytrd.cpp @@ -0,0 +1,133 @@ +#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 doublereal c_b22 = -1.; +static doublereal c_b23 = 1.; +int dsytrd_(char *uplo, integer *n, doublereal *a, integer *lda, doublereal *d__, doublereal *e, + doublereal *tau, doublereal *work, integer *lwork, integer *info, ftnlen uplo_len) +{ + integer a_dim1, a_offset, i__1, i__2, i__3; + integer i__, j, nb, kk, nx, iws; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + integer nbmin, iinfo; + logical upper; + extern int dsytd2_(char *, integer *, doublereal *, integer *, doublereal *, doublereal *, + doublereal *, integer *, ftnlen), + dsyr2k_(char *, char *, integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen), + dlatrd_(char *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, + doublereal *, 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; + --d__; + --e; + --tau; + --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 = -9; + } + if (*info == 0) { + nb = ilaenv_(&c__1, (char *)"DSYTRD", 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 *)"DSYTRD", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + if (*n == 0) { + work[1] = 1.; + return 0; + } + nx = *n; + iws = 1; + if (nb > 1 && nb < *n) { + i__1 = nb, + i__2 = ilaenv_(&c__3, (char *)"DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); + nx = max(i__1, i__2); + if (nx < *n) { + ldwork = *n; + iws = ldwork * nb; + if (*lwork < iws) { + i__1 = *lwork / ldwork; + nb = max(i__1, 1); + nbmin = + ilaenv_(&c__2, (char *)"DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); + if (nb < nbmin) { + nx = *n; + } + } + } else { + nx = *n; + } + } else { + nb = 1; + } + if (upper) { + kk = *n - (*n - nx + nb - 1) / nb * nb; + i__1 = kk + 1; + i__2 = -nb; + for (i__ = *n - nb + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + i__3 = i__ + nb - 1; + dlatrd_(uplo, &i__3, &nb, &a[a_offset], lda, &e[1], &tau[1], &work[1], &ldwork, + (ftnlen)1); + i__3 = i__ - 1; + dsyr2k_(uplo, (char *)"No transpose", &i__3, &nb, &c_b22, &a[i__ * a_dim1 + 1], lda, &work[1], + &ldwork, &c_b23, &a[a_offset], lda, (ftnlen)1, (ftnlen)12); + i__3 = i__ + nb - 1; + for (j = i__; j <= i__3; ++j) { + a[j - 1 + j * a_dim1] = e[j - 1]; + d__[j] = a[j + j * a_dim1]; + } + } + dsytd2_(uplo, &kk, &a[a_offset], lda, &d__[1], &e[1], &tau[1], &iinfo, (ftnlen)1); + } else { + i__2 = *n - nx; + i__1 = nb; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { + i__3 = *n - i__ + 1; + dlatrd_(uplo, &i__3, &nb, &a[i__ + i__ * a_dim1], lda, &e[i__], &tau[i__], &work[1], + &ldwork, (ftnlen)1); + i__3 = *n - i__ - nb + 1; + dsyr2k_(uplo, (char *)"No transpose", &i__3, &nb, &c_b22, &a[i__ + nb + i__ * a_dim1], lda, + &work[nb + 1], &ldwork, &c_b23, &a[i__ + nb + (i__ + nb) * a_dim1], lda, + (ftnlen)1, (ftnlen)12); + i__3 = i__ + nb - 1; + for (j = i__; j <= i__3; ++j) { + a[j + 1 + j * a_dim1] = e[j]; + d__[j] = a[j + j * a_dim1]; + } + } + i__1 = *n - i__ + 1; + dsytd2_(uplo, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], &tau[i__], &iinfo, + (ftnlen)1); + } + work[1] = (doublereal)lwkopt; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dsytrd.f b/lib/linalg/dsytrd.f deleted file mode 100644 index 3dcfc3db2b..0000000000 --- a/lib/linalg/dsytrd.f +++ /dev/null @@ -1,373 +0,0 @@ -*> \brief \b DSYTRD -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DSYTRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ), -* $ WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DSYTRD reduces a real symmetric matrix A to real symmetric -*> tridiagonal form T by an orthogonal similarity transformation: -*> Q**T * A * Q = T. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A is stored; -*> = 'L': Lower triangle of A is stored. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the symmetric matrix A. If UPLO = 'U', the leading -*> N-by-N upper triangular part of A contains the upper -*> triangular part of the matrix A, and the strictly lower -*> triangular part of A is not referenced. If UPLO = 'L', the -*> leading N-by-N lower triangular part of A contains the lower -*> triangular part of the matrix A, and the strictly upper -*> triangular part of A is not referenced. -*> On exit, if UPLO = 'U', the diagonal and first superdiagonal -*> of A are overwritten by the corresponding elements of the -*> tridiagonal matrix T, and the elements above the first -*> superdiagonal, with the array TAU, represent the orthogonal -*> matrix Q as a product of elementary reflectors; if UPLO -*> = 'L', the diagonal and first subdiagonal of A are over- -*> written by the corresponding elements of the tridiagonal -*> matrix T, and the elements below the first subdiagonal, with -*> the array TAU, represent the orthogonal matrix Q as a product -*> of elementary reflectors. See Further Details. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> The diagonal elements of the tridiagonal matrix T: -*> D(i) = A(i,i). -*> \endverbatim -*> -*> \param[out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N-1) -*> The off-diagonal elements of the tridiagonal matrix T: -*> E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. -*> \endverbatim -*> -*> \param[out] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (N-1) -*> The scalar factors of the elementary reflectors (see Further -*> Details). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. LWORK >= 1. -*> For optimum performance LWORK >= N*NB, where NB is the -*> optimal blocksize. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal size of the WORK array, returns -*> this value as the first entry of the WORK array, and no error -*> message related to LWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleSYcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> If UPLO = 'U', the matrix Q is represented as a product of elementary -*> reflectors -*> -*> Q = H(n-1) . . . H(2) H(1). -*> -*> Each H(i) has the form -*> -*> H(i) = I - tau * v * v**T -*> -*> where tau is a real scalar, and v is a real vector with -*> v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in -*> A(1:i-1,i+1), and tau in TAU(i). -*> -*> If UPLO = 'L', the matrix Q is represented as a product of elementary -*> reflectors -*> -*> Q = H(1) H(2) . . . H(n-1). -*> -*> Each H(i) has the form -*> -*> H(i) = I - tau * v * v**T -*> -*> where tau is a real scalar, and v is a real vector with -*> v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), -*> and tau in TAU(i). -*> -*> The contents of A on exit are illustrated by the following examples -*> with n = 5: -*> -*> if UPLO = 'U': if UPLO = 'L': -*> -*> ( d e v2 v3 v4 ) ( d ) -*> ( d e v3 v4 ) ( e d ) -*> ( d e v4 ) ( v1 e d ) -*> ( d e ) ( v1 v2 e d ) -*> ( d ) ( v1 v2 v3 e d ) -*> -*> where d and e denote diagonal and off-diagonal elements of T, and vi -*> denotes an element of the vector defining H(i). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ), - $ WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY, UPPER - INTEGER I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB, - $ NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL DLATRD, DSYR2K, DSYTD2, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - LQUERY = ( LWORK.EQ.-1 ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN - INFO = -9 - END IF -* - IF( INFO.EQ.0 ) THEN -* -* Determine the block size. -* - NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) - LWKOPT = N*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSYTRD', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NX = N - IWS = 1 - IF( NB.GT.1 .AND. NB.LT.N ) THEN -* -* Determine when to cross over from blocked to unblocked code -* (last block is always handled by unblocked code). -* - NX = MAX( NB, ILAENV( 3, 'DSYTRD', UPLO, N, -1, -1, -1 ) ) - IF( NX.LT.N ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: determine the -* minimum value of NB, and reduce NB or force use of -* unblocked code by setting NX = N. -* - NB = MAX( LWORK / LDWORK, 1 ) - NBMIN = ILAENV( 2, 'DSYTRD', UPLO, N, -1, -1, -1 ) - IF( NB.LT.NBMIN ) - $ NX = N - END IF - ELSE - NX = N - END IF - ELSE - NB = 1 - END IF -* - IF( UPPER ) THEN -* -* Reduce the upper triangle of A. -* Columns 1:kk are handled by the unblocked method. -* - KK = N - ( ( N-NX+NB-1 ) / NB )*NB - DO 20 I = N - NB + 1, KK + 1, -NB -* -* Reduce columns i:i+nb-1 to tridiagonal form and form the -* matrix W which is needed to update the unreduced part of -* the matrix -* - CALL DLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK, - $ LDWORK ) -* -* Update the unreduced submatrix A(1:i-1,1:i-1), using an -* update of the form: A := A - V*W**T - W*V**T -* - CALL DSYR2K( UPLO, 'No transpose', I-1, NB, -ONE, A( 1, I ), - $ LDA, WORK, LDWORK, ONE, A, LDA ) -* -* Copy superdiagonal elements back into A, and diagonal -* elements into D -* - DO 10 J = I, I + NB - 1 - A( J-1, J ) = E( J-1 ) - D( J ) = A( J, J ) - 10 CONTINUE - 20 CONTINUE -* -* Use unblocked code to reduce the last or only block -* - CALL DSYTD2( UPLO, KK, A, LDA, D, E, TAU, IINFO ) - ELSE -* -* Reduce the lower triangle of A -* - DO 40 I = 1, N - NX, NB -* -* Reduce columns i:i+nb-1 to tridiagonal form and form the -* matrix W which is needed to update the unreduced part of -* the matrix -* - CALL DLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ), - $ TAU( I ), WORK, LDWORK ) -* -* Update the unreduced submatrix A(i+ib:n,i+ib:n), using -* an update of the form: A := A - V*W**T - W*V**T -* - CALL DSYR2K( UPLO, 'No transpose', N-I-NB+1, NB, -ONE, - $ A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE, - $ A( I+NB, I+NB ), LDA ) -* -* Copy subdiagonal elements back into A, and diagonal -* elements into D -* - DO 30 J = I, I + NB - 1 - A( J+1, J ) = E( J ) - D( J ) = A( J, J ) - 30 CONTINUE - 40 CONTINUE -* -* Use unblocked code to reduce the last or only block -* - CALL DSYTD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ), - $ TAU( I ), IINFO ) - END IF -* - WORK( 1 ) = LWKOPT - RETURN -* -* End of DSYTRD -* - END diff --git a/lib/linalg/dtrmm.cpp b/lib/linalg/dtrmm.cpp new file mode 100644 index 0000000000..1ef32afb54 --- /dev/null +++ b/lib/linalg/dtrmm.cpp @@ -0,0 +1,243 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dtrmm_(char *side, char *uplo, char *transa, char *diag, integer *m, integer *n, + doublereal *alpha, doublereal *a, integer *lda, doublereal *b, integer *ldb, + ftnlen side_len, ftnlen uplo_len, ftnlen transa_len, ftnlen diag_len) +{ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; + integer i__, j, k, info; + doublereal temp; + logical lside; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + integer nrowa; + logical upper; + extern int 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; + lside = lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1); + if (lside) { + nrowa = *m; + } else { + nrowa = *n; + } + nounit = lsame_(diag, (char *)"N", (ftnlen)1, (ftnlen)1); + upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); + info = 0; + if (!lside && !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 (!lsame_(transa, (char *)"N", (ftnlen)1, (ftnlen)1) && + !lsame_(transa, (char *)"T", (ftnlen)1, (ftnlen)1) && + !lsame_(transa, (char *)"C", (ftnlen)1, (ftnlen)1)) { + info = 3; + } else if (!lsame_(diag, (char *)"U", (ftnlen)1, (ftnlen)1) && + !lsame_(diag, (char *)"N", (ftnlen)1, (ftnlen)1)) { + info = 4; + } else if (*m < 0) { + info = 5; + } else if (*n < 0) { + info = 6; + } else if (*lda < max(1, nrowa)) { + info = 9; + } else if (*ldb < max(1, *m)) { + info = 11; + } + if (info != 0) { + xerbla_((char *)"DTRMM ", &info, (ftnlen)6); + return 0; + } + if (*m == 0 || *n == 0) { + return 0; + } + if (*alpha == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = 0.; + } + } + return 0; + } + if (lside) { + if (lsame_(transa, (char *)"N", (ftnlen)1, (ftnlen)1)) { + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (k = 1; k <= i__2; ++k) { + if (b[k + j * b_dim1] != 0.) { + temp = *alpha * b[k + j * b_dim1]; + i__3 = k - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + b[i__ + j * b_dim1] += temp * a[i__ + k * a_dim1]; + } + if (nounit) { + temp *= a[k + k * a_dim1]; + } + b[k + j * b_dim1] = temp; + } + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (k = *m; k >= 1; --k) { + if (b[k + j * b_dim1] != 0.) { + temp = *alpha * b[k + j * b_dim1]; + b[k + j * b_dim1] = temp; + if (nounit) { + b[k + j * b_dim1] *= a[k + k * a_dim1]; + } + i__2 = *m; + for (i__ = k + 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] += temp * a[i__ + k * a_dim1]; + } + } + } + } + } + } else { + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (i__ = *m; i__ >= 1; --i__) { + temp = b[i__ + j * b_dim1]; + if (nounit) { + temp *= a[i__ + i__ * a_dim1]; + } + i__2 = i__ - 1; + for (k = 1; k <= i__2; ++k) { + temp += a[k + i__ * a_dim1] * b[k + j * b_dim1]; + } + b[i__ + j * b_dim1] = *alpha * temp; + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = b[i__ + j * b_dim1]; + if (nounit) { + temp *= a[i__ + i__ * a_dim1]; + } + i__3 = *m; + for (k = i__ + 1; k <= i__3; ++k) { + temp += a[k + i__ * a_dim1] * b[k + j * b_dim1]; + } + b[i__ + j * b_dim1] = *alpha * temp; + } + } + } + } + } else { + if (lsame_(transa, (char *)"N", (ftnlen)1, (ftnlen)1)) { + if (upper) { + for (j = *n; j >= 1; --j) { + temp = *alpha; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; + } + i__1 = j - 1; + for (k = 1; k <= i__1; ++k) { + if (a[k + j * a_dim1] != 0.) { + temp = *alpha * a[k + j * a_dim1]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] += temp * b[i__ + k * b_dim1]; + } + } + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = *alpha; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; + } + i__2 = *n; + for (k = j + 1; k <= i__2; ++k) { + if (a[k + j * a_dim1] != 0.) { + temp = *alpha * a[k + j * a_dim1]; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + b[i__ + j * b_dim1] += temp * b[i__ + k * b_dim1]; + } + } + } + } + } + } else { + if (upper) { + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + i__2 = k - 1; + for (j = 1; j <= i__2; ++j) { + if (a[j + k * a_dim1] != 0.) { + temp = *alpha * a[j + k * a_dim1]; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + b[i__ + j * b_dim1] += temp * b[i__ + k * b_dim1]; + } + } + } + temp = *alpha; + if (nounit) { + temp *= a[k + k * a_dim1]; + } + if (temp != 1.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; + } + } + } + } else { + for (k = *n; k >= 1; --k) { + i__1 = *n; + for (j = k + 1; j <= i__1; ++j) { + if (a[j + k * a_dim1] != 0.) { + temp = *alpha * a[j + k * a_dim1]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] += temp * b[i__ + k * b_dim1]; + } + } + } + temp = *alpha; + if (nounit) { + temp *= a[k + k * a_dim1]; + } + if (temp != 1.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; + } + } + } + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dtrmm.f b/lib/linalg/dtrmm.f deleted file mode 100644 index b2cc0a1fa8..0000000000 --- a/lib/linalg/dtrmm.f +++ /dev/null @@ -1,412 +0,0 @@ -*> \brief \b DTRMM -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION ALPHA -* INTEGER LDA,LDB,M,N -* CHARACTER DIAG,SIDE,TRANSA,UPLO -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A(LDA,*),B(LDB,*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DTRMM performs one of the matrix-matrix operations -*> -*> B := alpha*op( A )*B, or B := alpha*B*op( A ), -*> -*> where alpha is a scalar, B is an m by n matrix, A is a unit, or -*> non-unit, upper or lower triangular matrix and op( A ) is one of -*> -*> op( A ) = A or op( A ) = A**T. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> On entry, SIDE specifies whether op( A ) multiplies B from -*> the left or right as follows: -*> -*> SIDE = 'L' or 'l' B := alpha*op( A )*B. -*> -*> SIDE = 'R' or 'r' B := alpha*B*op( A ). -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the matrix A is an upper or -*> lower triangular matrix as follows: -*> -*> UPLO = 'U' or 'u' A is an upper triangular matrix. -*> -*> UPLO = 'L' or 'l' A is a lower triangular matrix. -*> \endverbatim -*> -*> \param[in] TRANSA -*> \verbatim -*> TRANSA is CHARACTER*1 -*> On entry, TRANSA specifies the form of op( A ) to be used in -*> the matrix multiplication as follows: -*> -*> TRANSA = 'N' or 'n' op( A ) = A. -*> -*> TRANSA = 'T' or 't' op( A ) = A**T. -*> -*> TRANSA = 'C' or 'c' op( A ) = A**T. -*> \endverbatim -*> -*> \param[in] DIAG -*> \verbatim -*> DIAG is CHARACTER*1 -*> On entry, DIAG specifies whether or not A is unit triangular -*> as follows: -*> -*> DIAG = 'U' or 'u' A is assumed to be unit triangular. -*> -*> DIAG = 'N' or 'n' A is not assumed to be unit -*> triangular. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> On entry, M specifies the number of rows of B. M must be at -*> least zero. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the number of columns of B. N must be -*> at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is DOUBLE PRECISION. -*> On entry, ALPHA specifies the scalar alpha. When alpha is -*> zero then A is not referenced and B need not be set before -*> entry. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension ( LDA, k ), where k is m -*> when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. -*> Before entry with UPLO = 'U' or 'u', the leading k by k -*> upper triangular part of the array A must contain the upper -*> triangular matrix and the strictly lower triangular part of -*> A is not referenced. -*> Before entry with UPLO = 'L' or 'l', the leading k by k -*> lower triangular part of the array A must contain the lower -*> triangular matrix and the strictly upper triangular part of -*> A is not referenced. -*> Note that when DIAG = 'U' or 'u', the diagonal elements of -*> A are not referenced either, but are assumed to be unity. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. When SIDE = 'L' or 'l' then -*> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -*> then LDA must be at least max( 1, n ). -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension ( LDB, N ) -*> Before entry, the leading m by n part of the array B must -*> contain the matrix B, and on exit is overwritten by the -*> transformed matrix. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> On entry, LDB specifies the first dimension of B as declared -*> in the calling (sub) program. LDB must be at least -*> max( 1, m ). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level3 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 3 Blas routine. -*> -*> -- Written on 8-February-1989. -*> Jack Dongarra, Argonne National Laboratory. -*> Iain Duff, AERE Harwell. -*> Jeremy Du Croz, Numerical Algorithms Group Ltd. -*> Sven Hammarling, Numerical Algorithms Group Ltd. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* -* -- Reference BLAS level3 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER LDA,LDB,M,N - CHARACTER DIAG,SIDE,TRANSA,UPLO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),B(LDB,*) -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,J,K,NROWA - LOGICAL LSIDE,NOUNIT,UPPER -* .. -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) -* .. -* -* Test the input parameters. -* - LSIDE = LSAME(SIDE,'L') - IF (LSIDE) THEN - NROWA = M - ELSE - NROWA = N - END IF - NOUNIT = LSAME(DIAG,'N') - UPPER = LSAME(UPLO,'U') -* - INFO = 0 - IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN - INFO = 1 - ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN - INFO = 2 - ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. - + (.NOT.LSAME(TRANSA,'T')) .AND. - + (.NOT.LSAME(TRANSA,'C'))) THEN - INFO = 3 - ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN - INFO = 4 - ELSE IF (M.LT.0) THEN - INFO = 5 - ELSE IF (N.LT.0) THEN - INFO = 6 - ELSE IF (LDA.LT.MAX(1,NROWA)) THEN - INFO = 9 - ELSE IF (LDB.LT.MAX(1,M)) THEN - INFO = 11 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DTRMM ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (M.EQ.0 .OR. N.EQ.0) RETURN -* -* And when alpha.eq.zero. -* - IF (ALPHA.EQ.ZERO) THEN - DO 20 J = 1,N - DO 10 I = 1,M - B(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF (LSIDE) THEN - IF (LSAME(TRANSA,'N')) THEN -* -* Form B := alpha*A*B. -* - IF (UPPER) THEN - DO 50 J = 1,N - DO 40 K = 1,M - IF (B(K,J).NE.ZERO) THEN - TEMP = ALPHA*B(K,J) - DO 30 I = 1,K - 1 - B(I,J) = B(I,J) + TEMP*A(I,K) - 30 CONTINUE - IF (NOUNIT) TEMP = TEMP*A(K,K) - B(K,J) = TEMP - END IF - 40 CONTINUE - 50 CONTINUE - ELSE - DO 80 J = 1,N - DO 70 K = M,1,-1 - IF (B(K,J).NE.ZERO) THEN - TEMP = ALPHA*B(K,J) - B(K,J) = TEMP - IF (NOUNIT) B(K,J) = B(K,J)*A(K,K) - DO 60 I = K + 1,M - B(I,J) = B(I,J) + TEMP*A(I,K) - 60 CONTINUE - END IF - 70 CONTINUE - 80 CONTINUE - END IF - ELSE -* -* Form B := alpha*A**T*B. -* - IF (UPPER) THEN - DO 110 J = 1,N - DO 100 I = M,1,-1 - TEMP = B(I,J) - IF (NOUNIT) TEMP = TEMP*A(I,I) - DO 90 K = 1,I - 1 - TEMP = TEMP + A(K,I)*B(K,J) - 90 CONTINUE - B(I,J) = ALPHA*TEMP - 100 CONTINUE - 110 CONTINUE - ELSE - DO 140 J = 1,N - DO 130 I = 1,M - TEMP = B(I,J) - IF (NOUNIT) TEMP = TEMP*A(I,I) - DO 120 K = I + 1,M - TEMP = TEMP + A(K,I)*B(K,J) - 120 CONTINUE - B(I,J) = ALPHA*TEMP - 130 CONTINUE - 140 CONTINUE - END IF - END IF - ELSE - IF (LSAME(TRANSA,'N')) THEN -* -* Form B := alpha*B*A. -* - IF (UPPER) THEN - DO 180 J = N,1,-1 - TEMP = ALPHA - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 150 I = 1,M - B(I,J) = TEMP*B(I,J) - 150 CONTINUE - DO 170 K = 1,J - 1 - IF (A(K,J).NE.ZERO) THEN - TEMP = ALPHA*A(K,J) - DO 160 I = 1,M - B(I,J) = B(I,J) + TEMP*B(I,K) - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - ELSE - DO 220 J = 1,N - TEMP = ALPHA - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 190 I = 1,M - B(I,J) = TEMP*B(I,J) - 190 CONTINUE - DO 210 K = J + 1,N - IF (A(K,J).NE.ZERO) THEN - TEMP = ALPHA*A(K,J) - DO 200 I = 1,M - B(I,J) = B(I,J) + TEMP*B(I,K) - 200 CONTINUE - END IF - 210 CONTINUE - 220 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*A**T. -* - IF (UPPER) THEN - DO 260 K = 1,N - DO 240 J = 1,K - 1 - IF (A(J,K).NE.ZERO) THEN - TEMP = ALPHA*A(J,K) - DO 230 I = 1,M - B(I,J) = B(I,J) + TEMP*B(I,K) - 230 CONTINUE - END IF - 240 CONTINUE - TEMP = ALPHA - IF (NOUNIT) TEMP = TEMP*A(K,K) - IF (TEMP.NE.ONE) THEN - DO 250 I = 1,M - B(I,K) = TEMP*B(I,K) - 250 CONTINUE - END IF - 260 CONTINUE - ELSE - DO 300 K = N,1,-1 - DO 280 J = K + 1,N - IF (A(J,K).NE.ZERO) THEN - TEMP = ALPHA*A(J,K) - DO 270 I = 1,M - B(I,J) = B(I,J) + TEMP*B(I,K) - 270 CONTINUE - END IF - 280 CONTINUE - TEMP = ALPHA - IF (NOUNIT) TEMP = TEMP*A(K,K) - IF (TEMP.NE.ONE) THEN - DO 290 I = 1,M - B(I,K) = TEMP*B(I,K) - 290 CONTINUE - END IF - 300 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRMM -* - END diff --git a/lib/linalg/dtrmv.cpp b/lib/linalg/dtrmv.cpp new file mode 100644 index 0000000000..3631f6fb24 --- /dev/null +++ b/lib/linalg/dtrmv.cpp @@ -0,0 +1,184 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dtrmv_(char *uplo, char *trans, char *diag, integer *n, doublereal *a, integer *lda, + doublereal *x, integer *incx, ftnlen uplo_len, ftnlen trans_len, ftnlen diag_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); + logical nounit; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + info = 0; + 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 (!lsame_(diag, (char *)"U", (ftnlen)1, (ftnlen)1) && + !lsame_(diag, (char *)"N", (ftnlen)1, (ftnlen)1)) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*lda < max(1, *n)) { + info = 6; + } else if (*incx == 0) { + info = 8; + } + if (info != 0) { + xerbla_((char *)"DTRMV ", &info, (ftnlen)6); + return 0; + } + if (*n == 0) { + return 0; + } + nounit = lsame_(diag, (char *)"N", (ftnlen)1, (ftnlen)1); + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + if (lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)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 = x[j]; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + x[i__] += temp * a[i__ + j * a_dim1]; + } + if (nounit) { + x[j] *= a[j + j * a_dim1]; + } + } + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.) { + temp = x[jx]; + ix = kx; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + x[ix] += temp * a[i__ + j * a_dim1]; + ix += *incx; + } + if (nounit) { + x[jx] *= a[j + j * a_dim1]; + } + } + jx += *incx; + } + } + } else { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + if (x[j] != 0.) { + temp = x[j]; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + x[i__] += temp * a[i__ + j * a_dim1]; + } + if (nounit) { + x[j] *= a[j + j * a_dim1]; + } + } + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + if (x[jx] != 0.) { + temp = x[jx]; + ix = kx; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + x[ix] += temp * a[i__ + j * a_dim1]; + ix -= *incx; + } + if (nounit) { + x[jx] *= a[j + j * a_dim1]; + } + } + jx -= *incx; + } + } + } + } else { + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + temp = x[j]; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + for (i__ = j - 1; i__ >= 1; --i__) { + temp += a[i__ + j * a_dim1] * x[i__]; + } + x[j] = temp; + } + } else { + jx = kx + (*n - 1) * *incx; + for (j = *n; j >= 1; --j) { + temp = x[jx]; + ix = jx; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + for (i__ = j - 1; i__ >= 1; --i__) { + ix -= *incx; + temp += a[i__ + j * a_dim1] * x[ix]; + } + x[jx] = temp; + jx -= *incx; + } + } + } else { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[j]; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + temp += a[i__ + j * a_dim1] * x[i__]; + } + x[j] = temp; + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[jx]; + ix = jx; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + temp += a[i__ + j * a_dim1] * x[ix]; + } + x[jx] = temp; + jx += *incx; + } + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dtrmv.f b/lib/linalg/dtrmv.f deleted file mode 100644 index e8af8e6136..0000000000 --- a/lib/linalg/dtrmv.f +++ /dev/null @@ -1,339 +0,0 @@ -*> \brief \b DTRMV -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) -* -* .. Scalar Arguments .. -* INTEGER INCX,LDA,N -* CHARACTER DIAG,TRANS,UPLO -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A(LDA,*),X(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DTRMV performs one of the matrix-vector operations -*> -*> x := A*x, or x := A**T*x, -*> -*> where x is an n element vector and A is an n by n unit, or non-unit, -*> upper or lower triangular matrix. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the matrix is an upper or -*> lower triangular matrix as follows: -*> -*> UPLO = 'U' or 'u' A is an upper triangular matrix. -*> -*> UPLO = 'L' or 'l' A is a lower triangular matrix. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> On entry, TRANS specifies the operation to be performed as -*> follows: -*> -*> TRANS = 'N' or 'n' x := A*x. -*> -*> TRANS = 'T' or 't' x := A**T*x. -*> -*> TRANS = 'C' or 'c' x := A**T*x. -*> \endverbatim -*> -*> \param[in] DIAG -*> \verbatim -*> DIAG is CHARACTER*1 -*> On entry, DIAG specifies whether or not A is unit -*> triangular as follows: -*> -*> DIAG = 'U' or 'u' A is assumed to be unit triangular. -*> -*> DIAG = 'N' or 'n' A is not assumed to be unit -*> triangular. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the order of the matrix A. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension ( LDA, N ) -*> Before entry with UPLO = 'U' or 'u', the leading n by n -*> upper triangular part of the array A must contain the upper -*> triangular matrix and the strictly lower triangular part of -*> A is not referenced. -*> Before entry with UPLO = 'L' or 'l', the leading n by n -*> lower triangular part of the array A must contain the lower -*> triangular matrix and the strictly upper triangular part of -*> A is not referenced. -*> Note that when DIAG = 'U' or 'u', the diagonal elements of -*> A are not referenced either, but are assumed to be unity. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. LDA must be at least -*> max( 1, n ). -*> \endverbatim -*> -*> \param[in,out] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension at least -*> ( 1 + ( n - 1 )*abs( INCX ) ). -*> Before entry, the incremented array X must contain the n -*> element vector x. On exit, X is overwritten with the -*> transformed vector x. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> On entry, INCX specifies the increment for the elements of -*> X. INCX must not be zero. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level2 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 2 Blas routine. -*> The vector and matrix arguments are not referenced when N = 0, or M = 0 -*> -*> -- Written on 22-October-1986. -*> Jack Dongarra, Argonne National Lab. -*> Jeremy Du Croz, Nag Central Office. -*> Sven Hammarling, Nag Central Office. -*> Richard Hanson, Sandia National Labs. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) -* -* -- Reference BLAS level2 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX,LDA,N - CHARACTER DIAG,TRANS,UPLO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),X(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER (ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,IX,J,JX,KX - LOGICAL NOUNIT -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN - INFO = 1 - ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. - + .NOT.LSAME(TRANS,'C')) THEN - INFO = 2 - ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN - INFO = 3 - ELSE IF (N.LT.0) THEN - INFO = 4 - ELSE IF (LDA.LT.MAX(1,N)) THEN - INFO = 6 - ELSE IF (INCX.EQ.0) THEN - INFO = 8 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DTRMV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (N.EQ.0) RETURN -* - NOUNIT = LSAME(DIAG,'N') -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF (INCX.LE.0) THEN - KX = 1 - (N-1)*INCX - ELSE IF (INCX.NE.1) THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF (LSAME(TRANS,'N')) THEN -* -* Form x := A*x. -* - IF (LSAME(UPLO,'U')) THEN - IF (INCX.EQ.1) THEN - DO 20 J = 1,N - IF (X(J).NE.ZERO) THEN - TEMP = X(J) - DO 10 I = 1,J - 1 - X(I) = X(I) + TEMP*A(I,J) - 10 CONTINUE - IF (NOUNIT) X(J) = X(J)*A(J,J) - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40 J = 1,N - IF (X(JX).NE.ZERO) THEN - TEMP = X(JX) - IX = KX - DO 30 I = 1,J - 1 - X(IX) = X(IX) + TEMP*A(I,J) - IX = IX + INCX - 30 CONTINUE - IF (NOUNIT) X(JX) = X(JX)*A(J,J) - END IF - JX = JX + INCX - 40 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 60 J = N,1,-1 - IF (X(J).NE.ZERO) THEN - TEMP = X(J) - DO 50 I = N,J + 1,-1 - X(I) = X(I) + TEMP*A(I,J) - 50 CONTINUE - IF (NOUNIT) X(J) = X(J)*A(J,J) - END IF - 60 CONTINUE - ELSE - KX = KX + (N-1)*INCX - JX = KX - DO 80 J = N,1,-1 - IF (X(JX).NE.ZERO) THEN - TEMP = X(JX) - IX = KX - DO 70 I = N,J + 1,-1 - X(IX) = X(IX) + TEMP*A(I,J) - IX = IX - INCX - 70 CONTINUE - IF (NOUNIT) X(JX) = X(JX)*A(J,J) - END IF - JX = JX - INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A**T*x. -* - IF (LSAME(UPLO,'U')) THEN - IF (INCX.EQ.1) THEN - DO 100 J = N,1,-1 - TEMP = X(J) - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 90 I = J - 1,1,-1 - TEMP = TEMP + A(I,J)*X(I) - 90 CONTINUE - X(J) = TEMP - 100 CONTINUE - ELSE - JX = KX + (N-1)*INCX - DO 120 J = N,1,-1 - TEMP = X(JX) - IX = JX - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 110 I = J - 1,1,-1 - IX = IX - INCX - TEMP = TEMP + A(I,J)*X(IX) - 110 CONTINUE - X(JX) = TEMP - JX = JX - INCX - 120 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 140 J = 1,N - TEMP = X(J) - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 130 I = J + 1,N - TEMP = TEMP + A(I,J)*X(I) - 130 CONTINUE - X(J) = TEMP - 140 CONTINUE - ELSE - JX = KX - DO 160 J = 1,N - TEMP = X(JX) - IX = JX - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 150 I = J + 1,N - IX = IX + INCX - TEMP = TEMP + A(I,J)*X(IX) - 150 CONTINUE - X(JX) = TEMP - JX = JX + INCX - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRMV -* - END diff --git a/lib/linalg/dtrsm.cpp b/lib/linalg/dtrsm.cpp new file mode 100644 index 0000000000..9c0873f8dc --- /dev/null +++ b/lib/linalg/dtrsm.cpp @@ -0,0 +1,265 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dtrsm_(char *side, char *uplo, char *transa, char *diag, integer *m, integer *n, + doublereal *alpha, doublereal *a, integer *lda, doublereal *b, integer *ldb, + ftnlen side_len, ftnlen uplo_len, ftnlen transa_len, ftnlen diag_len) +{ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; + integer i__, j, k, info; + doublereal temp; + logical lside; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + integer nrowa; + logical upper; + extern int 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; + lside = lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1); + if (lside) { + nrowa = *m; + } else { + nrowa = *n; + } + nounit = lsame_(diag, (char *)"N", (ftnlen)1, (ftnlen)1); + upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); + info = 0; + if (!lside && !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 (!lsame_(transa, (char *)"N", (ftnlen)1, (ftnlen)1) && + !lsame_(transa, (char *)"T", (ftnlen)1, (ftnlen)1) && + !lsame_(transa, (char *)"C", (ftnlen)1, (ftnlen)1)) { + info = 3; + } else if (!lsame_(diag, (char *)"U", (ftnlen)1, (ftnlen)1) && + !lsame_(diag, (char *)"N", (ftnlen)1, (ftnlen)1)) { + info = 4; + } else if (*m < 0) { + info = 5; + } else if (*n < 0) { + info = 6; + } else if (*lda < max(1, nrowa)) { + info = 9; + } else if (*ldb < max(1, *m)) { + info = 11; + } + if (info != 0) { + xerbla_((char *)"DTRSM ", &info, (ftnlen)6); + return 0; + } + if (*m == 0 || *n == 0) { + return 0; + } + if (*alpha == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = 0.; + } + } + return 0; + } + if (lside) { + if (lsame_(transa, (char *)"N", (ftnlen)1, (ftnlen)1)) { + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*alpha != 1.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1]; + } + } + for (k = *m; k >= 1; --k) { + if (b[k + j * b_dim1] != 0.) { + if (nounit) { + b[k + j * b_dim1] /= a[k + k * a_dim1]; + } + i__2 = k - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[i__ + k * a_dim1]; + } + } + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*alpha != 1.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1]; + } + } + i__2 = *m; + for (k = 1; k <= i__2; ++k) { + if (b[k + j * b_dim1] != 0.) { + if (nounit) { + b[k + j * b_dim1] /= a[k + k * a_dim1]; + } + i__3 = *m; + for (i__ = k + 1; i__ <= i__3; ++i__) { + b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[i__ + k * a_dim1]; + } + } + } + } + } + } else { + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = *alpha * b[i__ + j * b_dim1]; + i__3 = i__ - 1; + for (k = 1; k <= i__3; ++k) { + temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1]; + } + if (nounit) { + temp /= a[i__ + i__ * a_dim1]; + } + b[i__ + j * b_dim1] = temp; + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (i__ = *m; i__ >= 1; --i__) { + temp = *alpha * b[i__ + j * b_dim1]; + i__2 = *m; + for (k = i__ + 1; k <= i__2; ++k) { + temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1]; + } + if (nounit) { + temp /= a[i__ + i__ * a_dim1]; + } + b[i__ + j * b_dim1] = temp; + } + } + } + } + } else { + if (lsame_(transa, (char *)"N", (ftnlen)1, (ftnlen)1)) { + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*alpha != 1.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1]; + } + } + i__2 = j - 1; + for (k = 1; k <= i__2; ++k) { + if (a[k + j * a_dim1] != 0.) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[i__ + k * b_dim1]; + } + } + } + if (nounit) { + temp = 1. / a[j + j * a_dim1]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; + } + } + } + } else { + for (j = *n; j >= 1; --j) { + if (*alpha != 1.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1]; + } + } + i__1 = *n; + for (k = j + 1; k <= i__1; ++k) { + if (a[k + j * a_dim1] != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[i__ + k * b_dim1]; + } + } + } + if (nounit) { + temp = 1. / a[j + j * a_dim1]; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; + } + } + } + } + } else { + if (upper) { + for (k = *n; k >= 1; --k) { + if (nounit) { + temp = 1. / a[k + k * a_dim1]; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; + } + } + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { + if (a[j + k * a_dim1] != 0.) { + temp = a[j + k * a_dim1]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] -= temp * b[i__ + k * b_dim1]; + } + } + } + if (*alpha != 1.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1]; + } + } + } + } else { + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (nounit) { + temp = 1. / a[k + k * a_dim1]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; + } + } + i__2 = *n; + for (j = k + 1; j <= i__2; ++j) { + if (a[j + k * a_dim1] != 0.) { + temp = a[j + k * a_dim1]; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + b[i__ + j * b_dim1] -= temp * b[i__ + k * b_dim1]; + } + } + } + if (*alpha != 1.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1]; + } + } + } + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dtrsm.f b/lib/linalg/dtrsm.f deleted file mode 100644 index fa8080bc92..0000000000 --- a/lib/linalg/dtrsm.f +++ /dev/null @@ -1,440 +0,0 @@ -*> \brief \b DTRSM -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION ALPHA -* INTEGER LDA,LDB,M,N -* CHARACTER DIAG,SIDE,TRANSA,UPLO -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A(LDA,*),B(LDB,*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DTRSM solves one of the matrix equations -*> -*> op( A )*X = alpha*B, or X*op( A ) = alpha*B, -*> -*> where alpha is a scalar, X and B are m by n matrices, A is a unit, or -*> non-unit, upper or lower triangular matrix and op( A ) is one of -*> -*> op( A ) = A or op( A ) = A**T. -*> -*> The matrix X is overwritten on B. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> On entry, SIDE specifies whether op( A ) appears on the left -*> or right of X as follows: -*> -*> SIDE = 'L' or 'l' op( A )*X = alpha*B. -*> -*> SIDE = 'R' or 'r' X*op( A ) = alpha*B. -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the matrix A is an upper or -*> lower triangular matrix as follows: -*> -*> UPLO = 'U' or 'u' A is an upper triangular matrix. -*> -*> UPLO = 'L' or 'l' A is a lower triangular matrix. -*> \endverbatim -*> -*> \param[in] TRANSA -*> \verbatim -*> TRANSA is CHARACTER*1 -*> On entry, TRANSA specifies the form of op( A ) to be used in -*> the matrix multiplication as follows: -*> -*> TRANSA = 'N' or 'n' op( A ) = A. -*> -*> TRANSA = 'T' or 't' op( A ) = A**T. -*> -*> TRANSA = 'C' or 'c' op( A ) = A**T. -*> \endverbatim -*> -*> \param[in] DIAG -*> \verbatim -*> DIAG is CHARACTER*1 -*> On entry, DIAG specifies whether or not A is unit triangular -*> as follows: -*> -*> DIAG = 'U' or 'u' A is assumed to be unit triangular. -*> -*> DIAG = 'N' or 'n' A is not assumed to be unit -*> triangular. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> On entry, M specifies the number of rows of B. M must be at -*> least zero. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the number of columns of B. N must be -*> at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is DOUBLE PRECISION. -*> On entry, ALPHA specifies the scalar alpha. When alpha is -*> zero then A is not referenced and B need not be set before -*> entry. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension ( LDA, k ), -*> where k is m when SIDE = 'L' or 'l' -*> and k is n when SIDE = 'R' or 'r'. -*> Before entry with UPLO = 'U' or 'u', the leading k by k -*> upper triangular part of the array A must contain the upper -*> triangular matrix and the strictly lower triangular part of -*> A is not referenced. -*> Before entry with UPLO = 'L' or 'l', the leading k by k -*> lower triangular part of the array A must contain the lower -*> triangular matrix and the strictly upper triangular part of -*> A is not referenced. -*> Note that when DIAG = 'U' or 'u', the diagonal elements of -*> A are not referenced either, but are assumed to be unity. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. When SIDE = 'L' or 'l' then -*> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -*> then LDA must be at least max( 1, n ). -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension ( LDB, N ) -*> Before entry, the leading m by n part of the array B must -*> contain the right-hand side matrix B, and on exit is -*> overwritten by the solution matrix X. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> On entry, LDB specifies the first dimension of B as declared -*> in the calling (sub) program. LDB must be at least -*> max( 1, m ). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level3 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 3 Blas routine. -*> -*> -*> -- Written on 8-February-1989. -*> Jack Dongarra, Argonne National Laboratory. -*> Iain Duff, AERE Harwell. -*> Jeremy Du Croz, Numerical Algorithms Group Ltd. -*> Sven Hammarling, Numerical Algorithms Group Ltd. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* -* -- Reference BLAS level3 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER LDA,LDB,M,N - CHARACTER DIAG,SIDE,TRANSA,UPLO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),B(LDB,*) -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,J,K,NROWA - LOGICAL LSIDE,NOUNIT,UPPER -* .. -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) -* .. -* -* Test the input parameters. -* - LSIDE = LSAME(SIDE,'L') - IF (LSIDE) THEN - NROWA = M - ELSE - NROWA = N - END IF - NOUNIT = LSAME(DIAG,'N') - UPPER = LSAME(UPLO,'U') -* - INFO = 0 - IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN - INFO = 1 - ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN - INFO = 2 - ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. - + (.NOT.LSAME(TRANSA,'T')) .AND. - + (.NOT.LSAME(TRANSA,'C'))) THEN - INFO = 3 - ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN - INFO = 4 - ELSE IF (M.LT.0) THEN - INFO = 5 - ELSE IF (N.LT.0) THEN - INFO = 6 - ELSE IF (LDA.LT.MAX(1,NROWA)) THEN - INFO = 9 - ELSE IF (LDB.LT.MAX(1,M)) THEN - INFO = 11 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DTRSM ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (M.EQ.0 .OR. N.EQ.0) RETURN -* -* And when alpha.eq.zero. -* - IF (ALPHA.EQ.ZERO) THEN - DO 20 J = 1,N - DO 10 I = 1,M - B(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF (LSIDE) THEN - IF (LSAME(TRANSA,'N')) THEN -* -* Form B := alpha*inv( A )*B. -* - IF (UPPER) THEN - DO 60 J = 1,N - IF (ALPHA.NE.ONE) THEN - DO 30 I = 1,M - B(I,J) = ALPHA*B(I,J) - 30 CONTINUE - END IF - DO 50 K = M,1,-1 - IF (B(K,J).NE.ZERO) THEN - IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) - DO 40 I = 1,K - 1 - B(I,J) = B(I,J) - B(K,J)*A(I,K) - 40 CONTINUE - END IF - 50 CONTINUE - 60 CONTINUE - ELSE - DO 100 J = 1,N - IF (ALPHA.NE.ONE) THEN - DO 70 I = 1,M - B(I,J) = ALPHA*B(I,J) - 70 CONTINUE - END IF - DO 90 K = 1,M - IF (B(K,J).NE.ZERO) THEN - IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) - DO 80 I = K + 1,M - B(I,J) = B(I,J) - B(K,J)*A(I,K) - 80 CONTINUE - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form B := alpha*inv( A**T )*B. -* - IF (UPPER) THEN - DO 130 J = 1,N - DO 120 I = 1,M - TEMP = ALPHA*B(I,J) - DO 110 K = 1,I - 1 - TEMP = TEMP - A(K,I)*B(K,J) - 110 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(I,I) - B(I,J) = TEMP - 120 CONTINUE - 130 CONTINUE - ELSE - DO 160 J = 1,N - DO 150 I = M,1,-1 - TEMP = ALPHA*B(I,J) - DO 140 K = I + 1,M - TEMP = TEMP - A(K,I)*B(K,J) - 140 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(I,I) - B(I,J) = TEMP - 150 CONTINUE - 160 CONTINUE - END IF - END IF - ELSE - IF (LSAME(TRANSA,'N')) THEN -* -* Form B := alpha*B*inv( A ). -* - IF (UPPER) THEN - DO 210 J = 1,N - IF (ALPHA.NE.ONE) THEN - DO 170 I = 1,M - B(I,J) = ALPHA*B(I,J) - 170 CONTINUE - END IF - DO 190 K = 1,J - 1 - IF (A(K,J).NE.ZERO) THEN - DO 180 I = 1,M - B(I,J) = B(I,J) - A(K,J)*B(I,K) - 180 CONTINUE - END IF - 190 CONTINUE - IF (NOUNIT) THEN - TEMP = ONE/A(J,J) - DO 200 I = 1,M - B(I,J) = TEMP*B(I,J) - 200 CONTINUE - END IF - 210 CONTINUE - ELSE - DO 260 J = N,1,-1 - IF (ALPHA.NE.ONE) THEN - DO 220 I = 1,M - B(I,J) = ALPHA*B(I,J) - 220 CONTINUE - END IF - DO 240 K = J + 1,N - IF (A(K,J).NE.ZERO) THEN - DO 230 I = 1,M - B(I,J) = B(I,J) - A(K,J)*B(I,K) - 230 CONTINUE - END IF - 240 CONTINUE - IF (NOUNIT) THEN - TEMP = ONE/A(J,J) - DO 250 I = 1,M - B(I,J) = TEMP*B(I,J) - 250 CONTINUE - END IF - 260 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*inv( A**T ). -* - IF (UPPER) THEN - DO 310 K = N,1,-1 - IF (NOUNIT) THEN - TEMP = ONE/A(K,K) - DO 270 I = 1,M - B(I,K) = TEMP*B(I,K) - 270 CONTINUE - END IF - DO 290 J = 1,K - 1 - IF (A(J,K).NE.ZERO) THEN - TEMP = A(J,K) - DO 280 I = 1,M - B(I,J) = B(I,J) - TEMP*B(I,K) - 280 CONTINUE - END IF - 290 CONTINUE - IF (ALPHA.NE.ONE) THEN - DO 300 I = 1,M - B(I,K) = ALPHA*B(I,K) - 300 CONTINUE - END IF - 310 CONTINUE - ELSE - DO 360 K = 1,N - IF (NOUNIT) THEN - TEMP = ONE/A(K,K) - DO 320 I = 1,M - B(I,K) = TEMP*B(I,K) - 320 CONTINUE - END IF - DO 340 J = K + 1,N - IF (A(J,K).NE.ZERO) THEN - TEMP = A(J,K) - DO 330 I = 1,M - B(I,J) = B(I,J) - TEMP*B(I,K) - 330 CONTINUE - END IF - 340 CONTINUE - IF (ALPHA.NE.ONE) THEN - DO 350 I = 1,M - B(I,K) = ALPHA*B(I,K) - 350 CONTINUE - END IF - 360 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRSM -* - END diff --git a/lib/linalg/dtrsv.cpp b/lib/linalg/dtrsv.cpp new file mode 100644 index 0000000000..51d3436ebf --- /dev/null +++ b/lib/linalg/dtrsv.cpp @@ -0,0 +1,184 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int dtrsv_(char *uplo, char *trans, char *diag, integer *n, doublereal *a, integer *lda, + doublereal *x, integer *incx, ftnlen uplo_len, ftnlen trans_len, ftnlen diag_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); + logical nounit; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + info = 0; + 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 (!lsame_(diag, (char *)"U", (ftnlen)1, (ftnlen)1) && + !lsame_(diag, (char *)"N", (ftnlen)1, (ftnlen)1)) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*lda < max(1, *n)) { + info = 6; + } else if (*incx == 0) { + info = 8; + } + if (info != 0) { + xerbla_((char *)"DTRSV ", &info, (ftnlen)6); + return 0; + } + if (*n == 0) { + return 0; + } + nounit = lsame_(diag, (char *)"N", (ftnlen)1, (ftnlen)1); + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + if (lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1)) { + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + if (x[j] != 0.) { + if (nounit) { + x[j] /= a[j + j * a_dim1]; + } + temp = x[j]; + for (i__ = j - 1; i__ >= 1; --i__) { + x[i__] -= temp * a[i__ + j * a_dim1]; + } + } + } + } else { + jx = kx + (*n - 1) * *incx; + for (j = *n; j >= 1; --j) { + if (x[jx] != 0.) { + if (nounit) { + x[jx] /= a[j + j * a_dim1]; + } + temp = x[jx]; + ix = jx; + for (i__ = j - 1; i__ >= 1; --i__) { + ix -= *incx; + x[ix] -= temp * a[i__ + j * a_dim1]; + } + } + jx -= *incx; + } + } + } else { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.) { + if (nounit) { + x[j] /= a[j + j * a_dim1]; + } + temp = x[j]; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + x[i__] -= temp * a[i__ + j * a_dim1]; + } + } + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.) { + if (nounit) { + x[jx] /= a[j + j * a_dim1]; + } + temp = x[jx]; + ix = jx; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + x[ix] -= temp * a[i__ + j * a_dim1]; + } + } + jx += *incx; + } + } + } + } else { + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[j]; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + temp -= a[i__ + j * a_dim1] * x[i__]; + } + if (nounit) { + temp /= a[j + j * a_dim1]; + } + x[j] = temp; + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[jx]; + ix = kx; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + temp -= a[i__ + j * a_dim1] * x[ix]; + ix += *incx; + } + if (nounit) { + temp /= a[j + j * a_dim1]; + } + x[jx] = temp; + jx += *incx; + } + } + } else { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + temp = x[j]; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + temp -= a[i__ + j * a_dim1] * x[i__]; + } + if (nounit) { + temp /= a[j + j * a_dim1]; + } + x[j] = temp; + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + temp = x[jx]; + ix = kx; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + temp -= a[i__ + j * a_dim1] * x[ix]; + ix -= *incx; + } + if (nounit) { + temp /= a[j + j * a_dim1]; + } + x[jx] = temp; + jx -= *incx; + } + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dtrsv.f b/lib/linalg/dtrsv.f deleted file mode 100644 index d8ea9fa898..0000000000 --- a/lib/linalg/dtrsv.f +++ /dev/null @@ -1,335 +0,0 @@ -*> \brief \b DTRSV -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE DTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) -* -* .. Scalar Arguments .. -* INTEGER INCX,LDA,N -* CHARACTER DIAG,TRANS,UPLO -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A(LDA,*),X(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DTRSV solves one of the systems of equations -*> -*> A*x = b, or A**T*x = b, -*> -*> where b and x are n element vectors and A is an n by n unit, or -*> non-unit, upper or lower triangular matrix. -*> -*> No test for singularity or near-singularity is included in this -*> routine. Such tests must be performed before calling this routine. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the matrix is an upper or -*> lower triangular matrix as follows: -*> -*> UPLO = 'U' or 'u' A is an upper triangular matrix. -*> -*> UPLO = 'L' or 'l' A is a lower triangular matrix. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> On entry, TRANS specifies the equations to be solved as -*> follows: -*> -*> TRANS = 'N' or 'n' A*x = b. -*> -*> TRANS = 'T' or 't' A**T*x = b. -*> -*> TRANS = 'C' or 'c' A**T*x = b. -*> \endverbatim -*> -*> \param[in] DIAG -*> \verbatim -*> DIAG is CHARACTER*1 -*> On entry, DIAG specifies whether or not A is unit -*> triangular as follows: -*> -*> DIAG = 'U' or 'u' A is assumed to be unit triangular. -*> -*> DIAG = 'N' or 'n' A is not assumed to be unit -*> triangular. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the order of the matrix A. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension ( LDA, N ) -*> Before entry with UPLO = 'U' or 'u', the leading n by n -*> upper triangular part of the array A must contain the upper -*> triangular matrix and the strictly lower triangular part of -*> A is not referenced. -*> Before entry with UPLO = 'L' or 'l', the leading n by n -*> lower triangular part of the array A must contain the lower -*> triangular matrix and the strictly upper triangular part of -*> A is not referenced. -*> Note that when DIAG = 'U' or 'u', the diagonal elements of -*> A are not referenced either, but are assumed to be unity. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. LDA must be at least -*> max( 1, n ). -*> \endverbatim -*> -*> \param[in,out] X -*> \verbatim -*> X is DOUBLE PRECISION array, dimension at least -*> ( 1 + ( n - 1 )*abs( INCX ) ). -*> Before entry, the incremented array X must contain the n -*> element right-hand side vector b. On exit, X is overwritten -*> with the solution vector x. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> On entry, INCX specifies the increment for the elements of -*> X. INCX must not be zero. -*> -*> Level 2 Blas routine. -*> -*> -- Written on 22-October-1986. -*> Jack Dongarra, Argonne National Lab. -*> Jeremy Du Croz, Nag Central Office. -*> Sven Hammarling, Nag Central Office. -*> Richard Hanson, Sandia National Labs. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup double_blas_level1 -* -* ===================================================================== - SUBROUTINE DTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX,LDA,N - CHARACTER DIAG,TRANS,UPLO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),X(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER (ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,IX,J,JX,KX - LOGICAL NOUNIT -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN - INFO = 1 - ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. - + .NOT.LSAME(TRANS,'C')) THEN - INFO = 2 - ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN - INFO = 3 - ELSE IF (N.LT.0) THEN - INFO = 4 - ELSE IF (LDA.LT.MAX(1,N)) THEN - INFO = 6 - ELSE IF (INCX.EQ.0) THEN - INFO = 8 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DTRSV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (N.EQ.0) RETURN -* - NOUNIT = LSAME(DIAG,'N') -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF (INCX.LE.0) THEN - KX = 1 - (N-1)*INCX - ELSE IF (INCX.NE.1) THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF (LSAME(TRANS,'N')) THEN -* -* Form x := inv( A )*x. -* - IF (LSAME(UPLO,'U')) THEN - IF (INCX.EQ.1) THEN - DO 20 J = N,1,-1 - IF (X(J).NE.ZERO) THEN - IF (NOUNIT) X(J) = X(J)/A(J,J) - TEMP = X(J) - DO 10 I = J - 1,1,-1 - X(I) = X(I) - TEMP*A(I,J) - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - JX = KX + (N-1)*INCX - DO 40 J = N,1,-1 - IF (X(JX).NE.ZERO) THEN - IF (NOUNIT) X(JX) = X(JX)/A(J,J) - TEMP = X(JX) - IX = JX - DO 30 I = J - 1,1,-1 - IX = IX - INCX - X(IX) = X(IX) - TEMP*A(I,J) - 30 CONTINUE - END IF - JX = JX - INCX - 40 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 60 J = 1,N - IF (X(J).NE.ZERO) THEN - IF (NOUNIT) X(J) = X(J)/A(J,J) - TEMP = X(J) - DO 50 I = J + 1,N - X(I) = X(I) - TEMP*A(I,J) - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80 J = 1,N - IF (X(JX).NE.ZERO) THEN - IF (NOUNIT) X(JX) = X(JX)/A(J,J) - TEMP = X(JX) - IX = JX - DO 70 I = J + 1,N - IX = IX + INCX - X(IX) = X(IX) - TEMP*A(I,J) - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := inv( A**T )*x. -* - IF (LSAME(UPLO,'U')) THEN - IF (INCX.EQ.1) THEN - DO 100 J = 1,N - TEMP = X(J) - DO 90 I = 1,J - 1 - TEMP = TEMP - A(I,J)*X(I) - 90 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(J,J) - X(J) = TEMP - 100 CONTINUE - ELSE - JX = KX - DO 120 J = 1,N - TEMP = X(JX) - IX = KX - DO 110 I = 1,J - 1 - TEMP = TEMP - A(I,J)*X(IX) - IX = IX + INCX - 110 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(J,J) - X(JX) = TEMP - JX = JX + INCX - 120 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 140 J = N,1,-1 - TEMP = X(J) - DO 130 I = N,J + 1,-1 - TEMP = TEMP - A(I,J)*X(I) - 130 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(J,J) - X(J) = TEMP - 140 CONTINUE - ELSE - KX = KX + (N-1)*INCX - JX = KX - DO 160 J = N,1,-1 - TEMP = X(JX) - IX = KX - DO 150 I = N,J + 1,-1 - TEMP = TEMP - A(I,J)*X(IX) - IX = IX - INCX - 150 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(J,J) - X(JX) = TEMP - JX = JX - INCX - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRSV -* - END diff --git a/lib/linalg/dtrti2.cpp b/lib/linalg/dtrti2.cpp new file mode 100644 index 0000000000..a0e26f9268 --- /dev/null +++ b/lib/linalg/dtrti2.cpp @@ -0,0 +1,75 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +int dtrti2_(char *uplo, char *diag, integer *n, doublereal *a, integer *lda, integer *info, + ftnlen uplo_len, ftnlen diag_len) +{ + integer a_dim1, a_offset, i__1, i__2; + integer j; + doublereal ajj; + extern int dscal_(integer *, doublereal *, doublereal *, integer *); + extern logical lsame_(char *, char *, ftnlen, ftnlen); + logical upper; + extern int dtrmv_(char *, char *, char *, integer *, doublereal *, integer *, doublereal *, + integer *, ftnlen, ftnlen, ftnlen), + xerbla_(char *, integer *, ftnlen); + logical nounit; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + *info = 0; + upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); + nounit = lsame_(diag, (char *)"N", (ftnlen)1, (ftnlen)1); + if (!upper && !lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { + *info = -1; + } else if (!nounit && !lsame_(diag, (char *)"U", (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 *)"DTRTI2", &i__1, (ftnlen)6); + return 0; + } + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (nounit) { + a[j + j * a_dim1] = 1. / a[j + j * a_dim1]; + ajj = -a[j + j * a_dim1]; + } else { + ajj = -1.; + } + i__2 = j - 1; + dtrmv_((char *)"Upper", (char *)"No transpose", diag, &i__2, &a[a_offset], lda, &a[j * a_dim1 + 1], + &c__1, (ftnlen)5, (ftnlen)12, (ftnlen)1); + i__2 = j - 1; + dscal_(&i__2, &ajj, &a[j * a_dim1 + 1], &c__1); + } + } else { + for (j = *n; j >= 1; --j) { + if (nounit) { + a[j + j * a_dim1] = 1. / a[j + j * a_dim1]; + ajj = -a[j + j * a_dim1]; + } else { + ajj = -1.; + } + if (j < *n) { + i__1 = *n - j; + dtrmv_((char *)"Lower", (char *)"No transpose", diag, &i__1, &a[j + 1 + (j + 1) * a_dim1], lda, + &a[j + 1 + j * a_dim1], &c__1, (ftnlen)5, (ftnlen)12, (ftnlen)1); + i__1 = *n - j; + dscal_(&i__1, &ajj, &a[j + 1 + j * a_dim1], &c__1); + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dtrti2.f b/lib/linalg/dtrti2.f deleted file mode 100644 index 0d9115554c..0000000000 --- a/lib/linalg/dtrti2.f +++ /dev/null @@ -1,209 +0,0 @@ -*> \brief \b DTRTI2 computes the inverse of a triangular matrix (unblocked algorithm). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DTRTI2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER DIAG, UPLO -* INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DTRTI2 computes the inverse of a real upper or lower triangular -*> matrix. -*> -*> This is the Level 2 BLAS version of the algorithm. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> Specifies whether the matrix A is upper or lower triangular. -*> = 'U': Upper triangular -*> = 'L': Lower triangular -*> \endverbatim -*> -*> \param[in] DIAG -*> \verbatim -*> DIAG is CHARACTER*1 -*> Specifies whether or not the matrix A is unit triangular. -*> = 'N': Non-unit triangular -*> = 'U': Unit triangular -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the triangular matrix A. If UPLO = 'U', the -*> leading n by n upper triangular part of the array A contains -*> the upper triangular matrix, and the strictly lower -*> triangular part of A is not referenced. If UPLO = 'L', the -*> leading n by n lower triangular part of the array A contains -*> the lower triangular matrix, and the strictly upper -*> triangular part of A is not referenced. If DIAG = 'U', the -*> diagonal elements of A are also not referenced and are -*> assumed to be 1. -*> -*> On exit, the (triangular) inverse of the original matrix, in -*> the same storage format. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -k, the k-th argument had an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER DIAG, UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOUNIT, UPPER - INTEGER J - DOUBLE PRECISION AJJ -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DSCAL, DTRMV, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - NOUNIT = LSAME( DIAG, 'N' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DTRTI2', -INFO ) - RETURN - END IF -* - IF( UPPER ) THEN -* -* Compute inverse of upper triangular matrix. -* - DO 10 J = 1, N - IF( NOUNIT ) THEN - A( J, J ) = ONE / A( J, J ) - AJJ = -A( J, J ) - ELSE - AJJ = -ONE - END IF -* -* Compute elements 1:j-1 of j-th column. -* - CALL DTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA, - $ A( 1, J ), 1 ) - CALL DSCAL( J-1, AJJ, A( 1, J ), 1 ) - 10 CONTINUE - ELSE -* -* Compute inverse of lower triangular matrix. -* - DO 20 J = N, 1, -1 - IF( NOUNIT ) THEN - A( J, J ) = ONE / A( J, J ) - AJJ = -A( J, J ) - ELSE - AJJ = -ONE - END IF - IF( J.LT.N ) THEN -* -* Compute elements j+1:n of j-th column. -* - CALL DTRMV( 'Lower', 'No transpose', DIAG, N-J, - $ A( J+1, J+1 ), LDA, A( J+1, J ), 1 ) - CALL DSCAL( N-J, AJJ, A( J+1, J ), 1 ) - END IF - 20 CONTINUE - END IF -* - RETURN -* -* End of DTRTI2 -* - END diff --git a/lib/linalg/dtrtri.cpp b/lib/linalg/dtrtri.cpp new file mode 100644 index 0000000000..55c6b1b01f --- /dev/null +++ b/lib/linalg/dtrtri.cpp @@ -0,0 +1,109 @@ +#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_b18 = 1.; +static doublereal c_b22 = -1.; +int dtrtri_(char *uplo, char *diag, integer *n, doublereal *a, integer *lda, integer *info, + ftnlen uplo_len, ftnlen diag_len) +{ + address a__1[2]; + integer a_dim1, a_offset, i__1, i__2[2], i__3, i__4, i__5; + char ch__1[2]; + int s_lmp_cat(char *, char **, integer *, integer *, ftnlen); + integer j, jb, nb, nn; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern int dtrmm_(char *, char *, char *, char *, integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, + ftnlen), + dtrsm_(char *, char *, char *, char *, integer *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); + logical upper; + extern int dtrti2_(char *, char *, integer *, doublereal *, integer *, integer *, ftnlen, + ftnlen), + xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, + ftnlen, ftnlen); + logical nounit; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + *info = 0; + upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); + nounit = lsame_(diag, (char *)"N", (ftnlen)1, (ftnlen)1); + if (!upper && !lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { + *info = -1; + } else if (!nounit && !lsame_(diag, (char *)"U", (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 *)"DTRTRI", &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; + } + i__2[0] = 1, a__1[0] = uplo; + i__2[1] = 1, a__1[1] = diag; + s_lmp_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2); + nb = ilaenv_(&c__1, (char *)"DTRTRI", ch__1, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)2); + if (nb <= 1 || nb >= *n) { + dtrti2_(uplo, diag, n, &a[a_offset], lda, info, (ftnlen)1, (ftnlen)1); + } else { + if (upper) { + i__1 = *n; + i__3 = nb; + for (j = 1; i__3 < 0 ? j >= i__1 : j <= i__1; j += i__3) { + i__4 = nb, i__5 = *n - j + 1; + jb = min(i__4, i__5); + i__4 = j - 1; + dtrmm_((char *)"Left", (char *)"Upper", (char *)"No transpose", diag, &i__4, &jb, &c_b18, &a[a_offset], lda, + &a[j * a_dim1 + 1], lda, (ftnlen)4, (ftnlen)5, (ftnlen)12, (ftnlen)1); + i__4 = j - 1; + dtrsm_((char *)"Right", (char *)"Upper", (char *)"No transpose", diag, &i__4, &jb, &c_b22, + &a[j + j * a_dim1], lda, &a[j * a_dim1 + 1], lda, (ftnlen)5, (ftnlen)5, + (ftnlen)12, (ftnlen)1); + dtrti2_((char *)"Upper", diag, &jb, &a[j + j * a_dim1], lda, info, (ftnlen)5, (ftnlen)1); + } + } else { + nn = (*n - 1) / nb * nb + 1; + i__3 = -nb; + for (j = nn; i__3 < 0 ? j >= 1 : j <= 1; j += i__3) { + i__1 = nb, i__4 = *n - j + 1; + jb = min(i__1, i__4); + if (j + jb <= *n) { + i__1 = *n - j - jb + 1; + dtrmm_((char *)"Left", (char *)"Lower", (char *)"No transpose", diag, &i__1, &jb, &c_b18, + &a[j + jb + (j + jb) * a_dim1], lda, &a[j + jb + j * a_dim1], lda, + (ftnlen)4, (ftnlen)5, (ftnlen)12, (ftnlen)1); + i__1 = *n - j - jb + 1; + dtrsm_((char *)"Right", (char *)"Lower", (char *)"No transpose", diag, &i__1, &jb, &c_b22, + &a[j + j * a_dim1], lda, &a[j + jb + j * a_dim1], lda, (ftnlen)5, + (ftnlen)5, (ftnlen)12, (ftnlen)1); + } + dtrti2_((char *)"Lower", diag, &jb, &a[j + j * a_dim1], lda, info, (ftnlen)5, (ftnlen)1); + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dtrtri.f b/lib/linalg/dtrtri.f deleted file mode 100644 index 1cf9a9aafb..0000000000 --- a/lib/linalg/dtrtri.f +++ /dev/null @@ -1,239 +0,0 @@ -*> \brief \b DTRTRI -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DTRTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER DIAG, UPLO -* INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DTRTRI computes the inverse of a real upper or lower triangular -*> matrix A. -*> -*> This is the Level 3 BLAS version of the algorithm. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': A is upper triangular; -*> = 'L': A is lower triangular. -*> \endverbatim -*> -*> \param[in] DIAG -*> \verbatim -*> DIAG is CHARACTER*1 -*> = 'N': A is non-unit triangular; -*> = 'U': A is unit triangular. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> On entry, the triangular matrix A. If UPLO = 'U', the -*> leading N-by-N upper triangular part of the array A contains -*> the upper triangular matrix, and the strictly lower -*> triangular part of A is not referenced. If UPLO = 'L', the -*> leading N-by-N lower triangular part of the array A contains -*> the lower triangular matrix, and the strictly upper -*> triangular part of A is not referenced. If DIAG = 'U', the -*> diagonal elements of A are also not referenced and are -*> assumed to be 1. -*> On exit, the (triangular) inverse of the original matrix, in -*> the same storage format. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> > 0: if INFO = i, A(i,i) is exactly zero. The triangular -*> matrix is singular and its inverse can not be computed. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER DIAG, UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOUNIT, UPPER - INTEGER J, JB, NB, NN -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DTRMM, DTRSM, DTRTI2, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - NOUNIT = LSAME( DIAG, 'N' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DTRTRI', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Check for singularity if non-unit. -* - IF( NOUNIT ) THEN - DO 10 INFO = 1, N - IF( A( INFO, INFO ).EQ.ZERO ) - $ RETURN - 10 CONTINUE - INFO = 0 - END IF -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'DTRTRI', UPLO // DIAG, N, -1, -1, -1 ) - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code -* - CALL DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) - ELSE -* -* Use blocked code -* - IF( UPPER ) THEN -* -* Compute inverse of upper triangular matrix -* - DO 20 J = 1, N, NB - JB = MIN( NB, N-J+1 ) -* -* Compute rows 1:j-1 of current block column -* - CALL DTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1, - $ JB, ONE, A, LDA, A( 1, J ), LDA ) - CALL DTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1, - $ JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA ) -* -* Compute inverse of current diagonal block -* - CALL DTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO ) - 20 CONTINUE - ELSE -* -* Compute inverse of lower triangular matrix -* - NN = ( ( N-1 ) / NB )*NB + 1 - DO 30 J = NN, 1, -NB - JB = MIN( NB, N-J+1 ) - IF( J+JB.LE.N ) THEN -* -* Compute rows j+jb:n of current block column -* - CALL DTRMM( 'Left', 'Lower', 'No transpose', DIAG, - $ N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA, - $ A( J+JB, J ), LDA ) - CALL DTRSM( 'Right', 'Lower', 'No transpose', DIAG, - $ N-J-JB+1, JB, -ONE, A( J, J ), LDA, - $ A( J+JB, J ), LDA ) - END IF -* -* Compute inverse of current diagonal block -* - CALL DTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO ) - 30 CONTINUE - END IF - END IF -* - RETURN -* -* End of DTRTRI -* - END diff --git a/lib/linalg/dznrm2.cpp b/lib/linalg/dznrm2.cpp new file mode 100644 index 0000000000..f636330367 --- /dev/null +++ b/lib/linalg/dznrm2.cpp @@ -0,0 +1,53 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +doublereal dznrm2_(integer *n, doublecomplex *x, integer *incx) +{ + integer i__1, i__2, i__3; + doublereal ret_val, d__1; + double d_lmp_imag(doublecomplex *), sqrt(doublereal); + integer ix; + doublereal ssq, temp, norm, scale; + --x; + if (*n < 1 || *incx < 1) { + norm = 0.; + } else { + scale = 0.; + ssq = 1.; + i__1 = (*n - 1) * *incx + 1; + i__2 = *incx; + for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { + i__3 = ix; + if (x[i__3].r != 0.) { + i__3 = ix; + temp = (d__1 = x[i__3].r, abs(d__1)); + if (scale < temp) { + d__1 = scale / temp; + ssq = ssq * (d__1 * d__1) + 1.; + scale = temp; + } else { + d__1 = temp / scale; + ssq += d__1 * d__1; + } + } + if (d_lmp_imag(&x[ix]) != 0.) { + temp = (d__1 = d_lmp_imag(&x[ix]), abs(d__1)); + if (scale < temp) { + d__1 = scale / temp; + ssq = ssq * (d__1 * d__1) + 1.; + scale = temp; + } else { + d__1 = temp / scale; + ssq += d__1 * d__1; + } + } + } + norm = scale * sqrt(ssq); + } + ret_val = norm; + return ret_val; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/dznrm2.f b/lib/linalg/dznrm2.f deleted file mode 100644 index e5a71d98f6..0000000000 --- a/lib/linalg/dznrm2.f +++ /dev/null @@ -1,140 +0,0 @@ -*> \brief \b DZNRM2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* DOUBLE PRECISION FUNCTION DZNRM2(N,X,INCX) -* -* .. Scalar Arguments .. -* INTEGER INCX,N -* .. -* .. Array Arguments .. -* COMPLEX*16 X(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DZNRM2 returns the euclidean norm of a vector via the function -*> name, so that -*> -*> DZNRM2 := sqrt( x**H*x ) -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> number of elements in input vector(s) -*> \endverbatim -*> -*> \param[in] X -*> \verbatim -*> X is COMPLEX*16 array, dimension (N) -*> complex vector with N elements -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> storage spacing between elements of X -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date December 2016 -* -*> \ingroup double_blas_level1 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> -- This version written on 25-October-1982. -*> Modified on 14-October-1993 to inline the call to ZLASSQ. -*> Sven Hammarling, Nag Ltd. -*> \endverbatim -*> -* ===================================================================== - DOUBLE PRECISION FUNCTION DZNRM2(N,X,INCX) -* -* -- Reference BLAS level1 routine (version 3.7.0) -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - INTEGER INCX,N -* .. -* .. Array Arguments .. - COMPLEX*16 X(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE,ZERO - PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION NORM,SCALE,SSQ,TEMP - INTEGER IX -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS,DBLE,DIMAG,SQRT -* .. - IF (N.LT.1 .OR. INCX.LT.1) THEN - NORM = ZERO - ELSE - SCALE = ZERO - SSQ = ONE -* The following loop is equivalent to this call to the LAPACK -* auxiliary routine: -* CALL ZLASSQ( N, X, INCX, SCALE, SSQ ) -* - DO 10 IX = 1,1 + (N-1)*INCX,INCX - IF (DBLE(X(IX)).NE.ZERO) THEN - TEMP = ABS(DBLE(X(IX))) - IF (SCALE.LT.TEMP) THEN - SSQ = ONE + SSQ* (SCALE/TEMP)**2 - SCALE = TEMP - ELSE - SSQ = SSQ + (TEMP/SCALE)**2 - END IF - END IF - IF (DIMAG(X(IX)).NE.ZERO) THEN - TEMP = ABS(DIMAG(X(IX))) - IF (SCALE.LT.TEMP) THEN - SSQ = ONE + SSQ* (SCALE/TEMP)**2 - SCALE = TEMP - ELSE - SSQ = SSQ + (TEMP/SCALE)**2 - END IF - END IF - 10 CONTINUE - NORM = SCALE*SQRT(SSQ) - END IF -* - DZNRM2 = NORM - RETURN -* -* End of DZNRM2. -* - END diff --git a/lib/linalg/i_lmp_dnnt.cpp b/lib/linalg/i_lmp_dnnt.cpp new file mode 100644 index 0000000000..8050697bb9 --- /dev/null +++ b/lib/linalg/i_lmp_dnnt.cpp @@ -0,0 +1,12 @@ + +#include "lmp_f2c.h" + +#undef abs +#include + +extern "C" { +integer i_lmp_dnnt(doublereal *x) +{ + return (integer)(*x >= 0. ? floor(*x + .5) : -floor(.5 - *x)); +} +} diff --git a/lib/linalg/i_lmp_len.cpp b/lib/linalg/i_lmp_len.cpp new file mode 100644 index 0000000000..b6101b29ad --- /dev/null +++ b/lib/linalg/i_lmp_len.cpp @@ -0,0 +1,10 @@ + +#include "lmp_f2c.h" + +extern "C" { + +integer i_lmp_len(char *s, ftnlen n) +{ + return (n); +} +} diff --git a/lib/linalg/i_lmp_nint.cpp b/lib/linalg/i_lmp_nint.cpp new file mode 100644 index 0000000000..f41ca6b3eb --- /dev/null +++ b/lib/linalg/i_lmp_nint.cpp @@ -0,0 +1,13 @@ + +#include "lmp_f2c.h" +#undef abs + +#include + +extern "C" { + +integer i_lmp_nint(real *x) +{ + return (integer)(*x >= 0 ? floor(*x + .5) : -floor(.5 - *x)); +} +} diff --git a/lib/linalg/idamax.cpp b/lib/linalg/idamax.cpp new file mode 100644 index 0000000000..ab2c24dc15 --- /dev/null +++ b/lib/linalg/idamax.cpp @@ -0,0 +1,46 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +integer idamax_(integer *n, doublereal *dx, integer *incx) +{ + integer ret_val, i__1; + doublereal d__1; + integer i__, ix; + doublereal dmax__; + --dx; + ret_val = 0; + if (*n < 1 || *incx <= 0) { + return ret_val; + } + ret_val = 1; + if (*n == 1) { + return ret_val; + } + if (*incx == 1) { + dmax__ = abs(dx[1]); + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + if ((d__1 = dx[i__], abs(d__1)) > dmax__) { + ret_val = i__; + dmax__ = (d__1 = dx[i__], abs(d__1)); + } + } + } else { + ix = 1; + dmax__ = abs(dx[1]); + ix += *incx; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + if ((d__1 = dx[ix], abs(d__1)) > dmax__) { + ret_val = i__; + dmax__ = (d__1 = dx[ix], abs(d__1)); + } + ix += *incx; + } + } + return ret_val; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/idamax.f b/lib/linalg/idamax.f deleted file mode 100644 index 1be301ea3e..0000000000 --- a/lib/linalg/idamax.f +++ /dev/null @@ -1,126 +0,0 @@ -*> \brief \b IDAMAX -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* INTEGER FUNCTION IDAMAX(N,DX,INCX) -* -* .. Scalar Arguments .. -* INTEGER INCX,N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION DX(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> IDAMAX finds the index of the first element having maximum absolute value. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> number of elements in input vector(s) -*> \endverbatim -*> -*> \param[in] DX -*> \verbatim -*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> storage spacing between elements of DX -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup aux_blas -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> jack dongarra, linpack, 3/11/78. -*> modified 3/93 to return if incx .le. 0. -*> modified 12/3/93, array(1) declarations changed to array(*) -*> \endverbatim -*> -* ===================================================================== - INTEGER FUNCTION IDAMAX(N,DX,INCX) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX,N -* .. -* .. Array Arguments .. - DOUBLE PRECISION DX(*) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - DOUBLE PRECISION DMAX - INTEGER I,IX -* .. -* .. Intrinsic Functions .. - INTRINSIC DABS -* .. - IDAMAX = 0 - IF (N.LT.1 .OR. INCX.LE.0) RETURN - IDAMAX = 1 - IF (N.EQ.1) RETURN - IF (INCX.EQ.1) THEN -* -* code for increment equal to 1 -* - DMAX = DABS(DX(1)) - DO I = 2,N - IF (DABS(DX(I)).GT.DMAX) THEN - IDAMAX = I - DMAX = DABS(DX(I)) - END IF - END DO - ELSE -* -* code for increment not equal to 1 -* - IX = 1 - DMAX = DABS(DX(1)) - IX = IX + INCX - DO I = 2,N - IF (DABS(DX(IX)).GT.DMAX) THEN - IDAMAX = I - DMAX = DABS(DX(IX)) - END IF - IX = IX + INCX - END DO - END IF - RETURN -* -* End of IDAMAX -* - END diff --git a/lib/linalg/ieeeck.cpp b/lib/linalg/ieeeck.cpp new file mode 100644 index 0000000000..c8cf58ba81 --- /dev/null +++ b/lib/linalg/ieeeck.cpp @@ -0,0 +1,87 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +integer ieeeck_(integer *ispec, real *zero, real *one) +{ + integer ret_val; + real nan1, nan2, nan3, nan4, nan5, nan6, neginf, posinf, negzro, newzro; + ret_val = 1; + posinf = *one / *zero; + if (posinf <= *one) { + ret_val = 0; + return ret_val; + } + neginf = -(*one) / *zero; + if (neginf >= *zero) { + ret_val = 0; + return ret_val; + } + negzro = *one / (neginf + *one); + if (negzro != *zero) { + ret_val = 0; + return ret_val; + } + neginf = *one / negzro; + if (neginf >= *zero) { + ret_val = 0; + return ret_val; + } + newzro = negzro + *zero; + if (newzro != *zero) { + ret_val = 0; + return ret_val; + } + posinf = *one / newzro; + if (posinf <= *one) { + ret_val = 0; + return ret_val; + } + neginf *= posinf; + if (neginf >= *zero) { + ret_val = 0; + return ret_val; + } + posinf *= posinf; + if (posinf <= *one) { + ret_val = 0; + return ret_val; + } + if (*ispec == 0) { + return ret_val; + } + nan1 = posinf + neginf; + nan2 = posinf / neginf; + nan3 = posinf / posinf; + nan4 = posinf * *zero; + nan5 = neginf * negzro; + nan6 = nan5 * *zero; + if (nan1 == nan1) { + ret_val = 0; + return ret_val; + } + if (nan2 == nan2) { + ret_val = 0; + return ret_val; + } + if (nan3 == nan3) { + ret_val = 0; + return ret_val; + } + if (nan4 == nan4) { + ret_val = 0; + return ret_val; + } + if (nan5 == nan5) { + ret_val = 0; + return ret_val; + } + if (nan6 == nan6) { + ret_val = 0; + return ret_val; + } + return ret_val; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/ieeeck.f b/lib/linalg/ieeeck.f deleted file mode 100644 index f9f6332ecf..0000000000 --- a/lib/linalg/ieeeck.f +++ /dev/null @@ -1,200 +0,0 @@ -*> \brief \b IEEECK -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download IEEECK + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) -* -* .. Scalar Arguments .. -* INTEGER ISPEC -* REAL ONE, ZERO -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> IEEECK is called from the ILAENV to verify that Infinity and -*> possibly NaN arithmetic is safe (i.e. will not trap). -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] ISPEC -*> \verbatim -*> ISPEC is INTEGER -*> Specifies whether to test just for infinity arithmetic -*> or whether to test for infinity and NaN arithmetic. -*> = 0: Verify infinity arithmetic only. -*> = 1: Verify infinity and NaN arithmetic. -*> \endverbatim -*> -*> \param[in] ZERO -*> \verbatim -*> ZERO is REAL -*> Must contain the value 0.0 -*> This is passed to prevent the compiler from optimizing -*> away this code. -*> \endverbatim -*> -*> \param[in] ONE -*> \verbatim -*> ONE is REAL -*> Must contain the value 1.0 -*> This is passed to prevent the compiler from optimizing -*> away this code. -*> -*> RETURN VALUE: INTEGER -*> = 0: Arithmetic failed to produce the correct answers -*> = 1: Arithmetic produced the correct answers -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER ISPEC - REAL ONE, ZERO -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, - $ NEGZRO, NEWZRO, POSINF -* .. -* .. Executable Statements .. - IEEECK = 1 -* - POSINF = ONE / ZERO - IF( POSINF.LE.ONE ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGINF = -ONE / ZERO - IF( NEGINF.GE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGZRO = ONE / ( NEGINF+ONE ) - IF( NEGZRO.NE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGINF = ONE / NEGZRO - IF( NEGINF.GE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - NEWZRO = NEGZRO + ZERO - IF( NEWZRO.NE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - POSINF = ONE / NEWZRO - IF( POSINF.LE.ONE ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGINF = NEGINF*POSINF - IF( NEGINF.GE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - POSINF = POSINF*POSINF - IF( POSINF.LE.ONE ) THEN - IEEECK = 0 - RETURN - END IF -* -* -* -* -* Return if we were only asked to check infinity arithmetic -* - IF( ISPEC.EQ.0 ) - $ RETURN -* - NAN1 = POSINF + NEGINF -* - NAN2 = POSINF / NEGINF -* - NAN3 = POSINF / POSINF -* - NAN4 = POSINF*ZERO -* - NAN5 = NEGINF*NEGZRO -* - NAN6 = NAN5*ZERO -* - IF( NAN1.EQ.NAN1 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN2.EQ.NAN2 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN3.EQ.NAN3 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN4.EQ.NAN4 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN5.EQ.NAN5 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN6.EQ.NAN6 ) THEN - IEEECK = 0 - RETURN - END IF -* - RETURN - END diff --git a/lib/linalg/iladlc.cpp b/lib/linalg/iladlc.cpp new file mode 100644 index 0000000000..019cf7f056 --- /dev/null +++ b/lib/linalg/iladlc.cpp @@ -0,0 +1,30 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +integer iladlc_(integer *m, integer *n, doublereal *a, integer *lda) +{ + integer a_dim1, a_offset, ret_val, i__1; + integer i__; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + if (*n == 0) { + ret_val = *n; + } else if (a[*n * a_dim1 + 1] != 0. || a[*m + *n * a_dim1] != 0.) { + ret_val = *n; + } else { + for (ret_val = *n; ret_val >= 1; --ret_val) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (a[i__ + ret_val * a_dim1] != 0.) { + return ret_val; + } + } + } + } + return ret_val; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/iladlc.f b/lib/linalg/iladlc.f deleted file mode 100644 index a98e7218bf..0000000000 --- a/lib/linalg/iladlc.f +++ /dev/null @@ -1,115 +0,0 @@ -*> \brief \b ILADLC scans a matrix for its last non-zero column. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ILADLC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* INTEGER FUNCTION ILADLC( M, N, A, LDA ) -* -* .. Scalar Arguments .. -* INTEGER M, N, LDA -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ILADLC scans A for its last non-zero column. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> The m by n matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - INTEGER FUNCTION ILADLC( M, N, A, LDA ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER M, N, LDA -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I -* .. -* .. Executable Statements .. -* -* Quick test for the common case where one corner is non-zero. - IF( N.EQ.0 ) THEN - ILADLC = N - ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN - ILADLC = N - ELSE -* Now scan each column from the end, returning with the first non-zero. - DO ILADLC = N, 1, -1 - DO I = 1, M - IF( A(I, ILADLC).NE.ZERO ) RETURN - END DO - END DO - END IF - RETURN - END diff --git a/lib/linalg/iladlr.cpp b/lib/linalg/iladlr.cpp new file mode 100644 index 0000000000..9718267951 --- /dev/null +++ b/lib/linalg/iladlr.cpp @@ -0,0 +1,31 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +integer iladlr_(integer *m, integer *n, doublereal *a, integer *lda) +{ + integer a_dim1, a_offset, ret_val, i__1; + integer i__, j; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + if (*m == 0) { + ret_val = *m; + } else if (a[*m + a_dim1] != 0. || a[*m + *n * a_dim1] != 0.) { + ret_val = *m; + } else { + ret_val = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__ = *m; + while (a[max(i__, 1) + j * a_dim1] == 0. && i__ >= 1) { + --i__; + } + ret_val = max(ret_val, i__); + } + } + return ret_val; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/iladlr.f b/lib/linalg/iladlr.f deleted file mode 100644 index b1abded84b..0000000000 --- a/lib/linalg/iladlr.f +++ /dev/null @@ -1,118 +0,0 @@ -*> \brief \b ILADLR scans a matrix for its last non-zero row. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ILADLR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* INTEGER FUNCTION ILADLR( M, N, A, LDA ) -* -* .. Scalar Arguments .. -* INTEGER M, N, LDA -* .. -* .. Array Arguments .. -* DOUBLE PRECISION A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ILADLR scans A for its last non-zero row. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> The m by n matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - INTEGER FUNCTION ILADLR( M, N, A, LDA ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER M, N, LDA -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J -* .. -* .. Executable Statements .. -* -* Quick test for the common case where one corner is non-zero. - IF( M.EQ.0 ) THEN - ILADLR = M - ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN - ILADLR = M - ELSE -* Scan up each column tracking the last zero row seen. - ILADLR = 0 - DO J = 1, N - I=M - DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1)) - I=I-1 - ENDDO - ILADLR = MAX( ILADLR, I ) - END DO - END IF - RETURN - END diff --git a/lib/linalg/ilaenv.cpp b/lib/linalg/ilaenv.cpp new file mode 100644 index 0000000000..1cc1c571f1 --- /dev/null +++ b/lib/linalg/ilaenv.cpp @@ -0,0 +1,573 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +static real c_b176 = (float)0.; +static real c_b177 = (float)1.; +static integer c__0 = 0; +integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1, integer *n2, integer *n3, + integer *n4, ftnlen name_len, ftnlen opts_len) +{ + integer ret_val, i__1, i__2, i__3; + int s_lmp_copy(char *, char *, ftnlen, ftnlen); + integer i_lmp_len(char *, ftnlen), s_lmp_cmp(char *, char *, ftnlen, ftnlen); + logical twostage; + integer i__; + char c1[1], c2[2], c3[3], c4[2]; + integer ic, nb, iz, nx; + logical cname; + integer nbmin; + logical sname; + extern integer ieeeck_(integer *, real *, real *); + char subnam[16]; + extern integer iparmq_(integer *, char *, char *, integer *, integer *, integer *, integer *, + ftnlen, ftnlen); + switch (*ispec) { + case 1: + goto L10; + case 2: + goto L10; + case 3: + goto L10; + case 4: + goto L80; + case 5: + goto L90; + case 6: + goto L100; + case 7: + goto L110; + case 8: + goto L120; + case 9: + goto L130; + case 10: + goto L140; + case 11: + goto L150; + case 12: + goto L160; + case 13: + goto L160; + case 14: + goto L160; + case 15: + goto L160; + case 16: + goto L160; + case 17: + goto L160; + } + ret_val = -1; + return ret_val; +L10: + ret_val = 1; + s_lmp_copy(subnam, name__, (ftnlen)16, name_len); + ic = *(unsigned char *)subnam; + iz = 'Z'; + if (iz == 90 || iz == 122) { + if (ic >= 97 && ic <= 122) { + *(unsigned char *)subnam = (char)(ic - 32); + for (i__ = 2; i__ <= 6; ++i__) { + ic = *(unsigned char *)&subnam[i__ - 1]; + if (ic >= 97 && ic <= 122) { + *(unsigned char *)&subnam[i__ - 1] = (char)(ic - 32); + } + } + } + } else if (iz == 233 || iz == 169) { + if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= 162 && ic <= 169) { + *(unsigned char *)subnam = (char)(ic + 64); + for (i__ = 2; i__ <= 6; ++i__) { + ic = *(unsigned char *)&subnam[i__ - 1]; + if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= 162 && ic <= 169) { + *(unsigned char *)&subnam[i__ - 1] = (char)(ic + 64); + } + } + } + } else if (iz == 218 || iz == 250) { + if (ic >= 225 && ic <= 250) { + *(unsigned char *)subnam = (char)(ic - 32); + for (i__ = 2; i__ <= 6; ++i__) { + ic = *(unsigned char *)&subnam[i__ - 1]; + if (ic >= 225 && ic <= 250) { + *(unsigned char *)&subnam[i__ - 1] = (char)(ic - 32); + } + } + } + } + *(unsigned char *)c1 = *(unsigned char *)subnam; + sname = *(unsigned char *)c1 == 'S' || *(unsigned char *)c1 == 'D'; + cname = *(unsigned char *)c1 == 'C' || *(unsigned char *)c1 == 'Z'; + if (!(cname || sname)) { + return ret_val; + } + s_lmp_copy(c2, subnam + 1, (ftnlen)2, (ftnlen)2); + s_lmp_copy(c3, subnam + 3, (ftnlen)3, (ftnlen)3); + s_lmp_copy(c4, c3 + 1, (ftnlen)2, (ftnlen)2); + twostage = i_lmp_len(subnam, (ftnlen)16) >= 11 && *(unsigned char *)&subnam[10] == '2'; + switch (*ispec) { + case 1: + goto L50; + case 2: + goto L60; + case 3: + goto L70; + } +L50: + nb = 1; + if (s_lmp_cmp(subnam + 1, (char *)"LAORH", (ftnlen)5, (ftnlen)5) == 0) { + if (sname) { + nb = 32; + } else { + nb = 32; + } + } else if (s_lmp_cmp(c2, (char *)"GE", (ftnlen)2, (ftnlen)2) == 0) { + if (s_lmp_cmp(c3, (char *)"TRF", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nb = 64; + } else { + nb = 64; + } + } else if (s_lmp_cmp(c3, (char *)"QRF", (ftnlen)3, (ftnlen)3) == 0 || + s_lmp_cmp(c3, (char *)"RQF", (ftnlen)3, (ftnlen)3) == 0 || + s_lmp_cmp(c3, (char *)"LQF", (ftnlen)3, (ftnlen)3) == 0 || + s_lmp_cmp(c3, (char *)"QLF", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nb = 32; + } else { + nb = 32; + } + } else if (s_lmp_cmp(c3, (char *)"QR ", (ftnlen)3, (ftnlen)3) == 0) { + if (*n3 == 1) { + if (sname) { + if (*n1 * *n2 <= 131072 || *n1 <= 8192) { + nb = *n1; + } else { + nb = 32768 / *n2; + } + } else { + if (*n1 * *n2 <= 131072 || *n1 <= 8192) { + nb = *n1; + } else { + nb = 32768 / *n2; + } + } + } else { + if (sname) { + nb = 1; + } else { + nb = 1; + } + } + } else if (s_lmp_cmp(c3, (char *)"LQ ", (ftnlen)3, (ftnlen)3) == 0) { + if (*n3 == 2) { + if (sname) { + if (*n1 * *n2 <= 131072 || *n1 <= 8192) { + nb = *n1; + } else { + nb = 32768 / *n2; + } + } else { + if (*n1 * *n2 <= 131072 || *n1 <= 8192) { + nb = *n1; + } else { + nb = 32768 / *n2; + } + } + } else { + if (sname) { + nb = 1; + } else { + nb = 1; + } + } + } else if (s_lmp_cmp(c3, (char *)"HRD", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nb = 32; + } else { + nb = 32; + } + } else if (s_lmp_cmp(c3, (char *)"BRD", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nb = 32; + } else { + nb = 32; + } + } else if (s_lmp_cmp(c3, (char *)"TRI", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nb = 64; + } else { + nb = 64; + } + } + } else if (s_lmp_cmp(c2, (char *)"PO", (ftnlen)2, (ftnlen)2) == 0) { + if (s_lmp_cmp(c3, (char *)"TRF", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nb = 64; + } else { + nb = 64; + } + } + } else if (s_lmp_cmp(c2, (char *)"SY", (ftnlen)2, (ftnlen)2) == 0) { + if (s_lmp_cmp(c3, (char *)"TRF", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + if (twostage) { + nb = 192; + } else { + nb = 64; + } + } else { + if (twostage) { + nb = 192; + } else { + nb = 64; + } + } + } else if (sname && s_lmp_cmp(c3, (char *)"TRD", (ftnlen)3, (ftnlen)3) == 0) { + nb = 32; + } else if (sname && s_lmp_cmp(c3, (char *)"GST", (ftnlen)3, (ftnlen)3) == 0) { + nb = 64; + } + } else if (cname && s_lmp_cmp(c2, (char *)"HE", (ftnlen)2, (ftnlen)2) == 0) { + if (s_lmp_cmp(c3, (char *)"TRF", (ftnlen)3, (ftnlen)3) == 0) { + if (twostage) { + nb = 192; + } else { + nb = 64; + } + } else if (s_lmp_cmp(c3, (char *)"TRD", (ftnlen)3, (ftnlen)3) == 0) { + nb = 32; + } else if (s_lmp_cmp(c3, (char *)"GST", (ftnlen)3, (ftnlen)3) == 0) { + nb = 64; + } + } else if (sname && s_lmp_cmp(c2, (char *)"OR", (ftnlen)2, (ftnlen)2) == 0) { + if (*(unsigned char *)c3 == 'G') { + if (s_lmp_cmp(c4, (char *)"QR", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"RQ", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"LQ", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"QL", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"HR", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"TR", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"BR", (ftnlen)2, (ftnlen)2) == 0) { + nb = 32; + } + } else if (*(unsigned char *)c3 == 'M') { + if (s_lmp_cmp(c4, (char *)"QR", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"RQ", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"LQ", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"QL", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"HR", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"TR", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"BR", (ftnlen)2, (ftnlen)2) == 0) { + nb = 32; + } + } + } else if (cname && s_lmp_cmp(c2, (char *)"UN", (ftnlen)2, (ftnlen)2) == 0) { + if (*(unsigned char *)c3 == 'G') { + if (s_lmp_cmp(c4, (char *)"QR", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"RQ", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"LQ", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"QL", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"HR", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"TR", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"BR", (ftnlen)2, (ftnlen)2) == 0) { + nb = 32; + } + } else if (*(unsigned char *)c3 == 'M') { + if (s_lmp_cmp(c4, (char *)"QR", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"RQ", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"LQ", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"QL", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"HR", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"TR", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"BR", (ftnlen)2, (ftnlen)2) == 0) { + nb = 32; + } + } + } else if (s_lmp_cmp(c2, (char *)"GB", (ftnlen)2, (ftnlen)2) == 0) { + if (s_lmp_cmp(c3, (char *)"TRF", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + if (*n4 <= 64) { + nb = 1; + } else { + nb = 32; + } + } else { + if (*n4 <= 64) { + nb = 1; + } else { + nb = 32; + } + } + } + } else if (s_lmp_cmp(c2, (char *)"PB", (ftnlen)2, (ftnlen)2) == 0) { + if (s_lmp_cmp(c3, (char *)"TRF", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + if (*n2 <= 64) { + nb = 1; + } else { + nb = 32; + } + } else { + if (*n2 <= 64) { + nb = 1; + } else { + nb = 32; + } + } + } + } else if (s_lmp_cmp(c2, (char *)"TR", (ftnlen)2, (ftnlen)2) == 0) { + if (s_lmp_cmp(c3, (char *)"TRI", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nb = 64; + } else { + nb = 64; + } + } else if (s_lmp_cmp(c3, (char *)"EVC", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nb = 64; + } else { + nb = 64; + } + } else if (s_lmp_cmp(c3, (char *)"SYL", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + i__2 = 48, i__3 = (min(*n1, *n2) << 4) / 100; + i__1 = max(i__2, i__3); + nb = min(i__1, 240); + } else { + i__2 = 24, i__3 = (min(*n1, *n2) << 3) / 100; + i__1 = max(i__2, i__3); + nb = min(i__1, 80); + } + } + } else if (s_lmp_cmp(c2, (char *)"LA", (ftnlen)2, (ftnlen)2) == 0) { + if (s_lmp_cmp(c3, (char *)"UUM", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nb = 64; + } else { + nb = 64; + } + } else if (s_lmp_cmp(c3, (char *)"TRS", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nb = 32; + } else { + nb = 32; + } + } + } else if (sname && s_lmp_cmp(c2, (char *)"ST", (ftnlen)2, (ftnlen)2) == 0) { + if (s_lmp_cmp(c3, (char *)"EBZ", (ftnlen)3, (ftnlen)3) == 0) { + nb = 1; + } + } else if (s_lmp_cmp(c2, (char *)"GG", (ftnlen)2, (ftnlen)2) == 0) { + nb = 32; + if (s_lmp_cmp(c3, (char *)"HD3", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nb = 32; + } else { + nb = 32; + } + } + } + ret_val = nb; + return ret_val; +L60: + nbmin = 2; + if (s_lmp_cmp(c2, (char *)"GE", (ftnlen)2, (ftnlen)2) == 0) { + if (s_lmp_cmp(c3, (char *)"QRF", (ftnlen)3, (ftnlen)3) == 0 || + s_lmp_cmp(c3, (char *)"RQF", (ftnlen)3, (ftnlen)3) == 0 || + s_lmp_cmp(c3, (char *)"LQF", (ftnlen)3, (ftnlen)3) == 0 || + s_lmp_cmp(c3, (char *)"QLF", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nbmin = 2; + } else { + nbmin = 2; + } + } else if (s_lmp_cmp(c3, (char *)"HRD", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nbmin = 2; + } else { + nbmin = 2; + } + } else if (s_lmp_cmp(c3, (char *)"BRD", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nbmin = 2; + } else { + nbmin = 2; + } + } else if (s_lmp_cmp(c3, (char *)"TRI", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nbmin = 2; + } else { + nbmin = 2; + } + } + } else if (s_lmp_cmp(c2, (char *)"SY", (ftnlen)2, (ftnlen)2) == 0) { + if (s_lmp_cmp(c3, (char *)"TRF", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nbmin = 8; + } else { + nbmin = 8; + } + } else if (sname && s_lmp_cmp(c3, (char *)"TRD", (ftnlen)3, (ftnlen)3) == 0) { + nbmin = 2; + } + } else if (cname && s_lmp_cmp(c2, (char *)"HE", (ftnlen)2, (ftnlen)2) == 0) { + if (s_lmp_cmp(c3, (char *)"TRD", (ftnlen)3, (ftnlen)3) == 0) { + nbmin = 2; + } + } else if (sname && s_lmp_cmp(c2, (char *)"OR", (ftnlen)2, (ftnlen)2) == 0) { + if (*(unsigned char *)c3 == 'G') { + if (s_lmp_cmp(c4, (char *)"QR", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"RQ", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"LQ", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"QL", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"HR", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"TR", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"BR", (ftnlen)2, (ftnlen)2) == 0) { + nbmin = 2; + } + } else if (*(unsigned char *)c3 == 'M') { + if (s_lmp_cmp(c4, (char *)"QR", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"RQ", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"LQ", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"QL", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"HR", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"TR", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"BR", (ftnlen)2, (ftnlen)2) == 0) { + nbmin = 2; + } + } + } else if (cname && s_lmp_cmp(c2, (char *)"UN", (ftnlen)2, (ftnlen)2) == 0) { + if (*(unsigned char *)c3 == 'G') { + if (s_lmp_cmp(c4, (char *)"QR", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"RQ", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"LQ", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"QL", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"HR", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"TR", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"BR", (ftnlen)2, (ftnlen)2) == 0) { + nbmin = 2; + } + } else if (*(unsigned char *)c3 == 'M') { + if (s_lmp_cmp(c4, (char *)"QR", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"RQ", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"LQ", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"QL", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"HR", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"TR", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"BR", (ftnlen)2, (ftnlen)2) == 0) { + nbmin = 2; + } + } + } else if (s_lmp_cmp(c2, (char *)"GG", (ftnlen)2, (ftnlen)2) == 0) { + nbmin = 2; + if (s_lmp_cmp(c3, (char *)"HD3", (ftnlen)3, (ftnlen)3) == 0) { + nbmin = 2; + } + } + ret_val = nbmin; + return ret_val; +L70: + nx = 0; + if (s_lmp_cmp(c2, (char *)"GE", (ftnlen)2, (ftnlen)2) == 0) { + if (s_lmp_cmp(c3, (char *)"QRF", (ftnlen)3, (ftnlen)3) == 0 || + s_lmp_cmp(c3, (char *)"RQF", (ftnlen)3, (ftnlen)3) == 0 || + s_lmp_cmp(c3, (char *)"LQF", (ftnlen)3, (ftnlen)3) == 0 || + s_lmp_cmp(c3, (char *)"QLF", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nx = 128; + } else { + nx = 128; + } + } else if (s_lmp_cmp(c3, (char *)"HRD", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nx = 128; + } else { + nx = 128; + } + } else if (s_lmp_cmp(c3, (char *)"BRD", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nx = 128; + } else { + nx = 128; + } + } + } else if (s_lmp_cmp(c2, (char *)"SY", (ftnlen)2, (ftnlen)2) == 0) { + if (sname && s_lmp_cmp(c3, (char *)"TRD", (ftnlen)3, (ftnlen)3) == 0) { + nx = 32; + } + } else if (cname && s_lmp_cmp(c2, (char *)"HE", (ftnlen)2, (ftnlen)2) == 0) { + if (s_lmp_cmp(c3, (char *)"TRD", (ftnlen)3, (ftnlen)3) == 0) { + nx = 32; + } + } else if (sname && s_lmp_cmp(c2, (char *)"OR", (ftnlen)2, (ftnlen)2) == 0) { + if (*(unsigned char *)c3 == 'G') { + if (s_lmp_cmp(c4, (char *)"QR", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"RQ", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"LQ", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"QL", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"HR", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"TR", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"BR", (ftnlen)2, (ftnlen)2) == 0) { + nx = 128; + } + } + } else if (cname && s_lmp_cmp(c2, (char *)"UN", (ftnlen)2, (ftnlen)2) == 0) { + if (*(unsigned char *)c3 == 'G') { + if (s_lmp_cmp(c4, (char *)"QR", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"RQ", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"LQ", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"QL", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"HR", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"TR", (ftnlen)2, (ftnlen)2) == 0 || + s_lmp_cmp(c4, (char *)"BR", (ftnlen)2, (ftnlen)2) == 0) { + nx = 128; + } + } + } else if (s_lmp_cmp(c2, (char *)"GG", (ftnlen)2, (ftnlen)2) == 0) { + nx = 128; + if (s_lmp_cmp(c3, (char *)"HD3", (ftnlen)3, (ftnlen)3) == 0) { + nx = 128; + } + } + ret_val = nx; + return ret_val; +L80: + ret_val = 6; + return ret_val; +L90: + ret_val = 2; + return ret_val; +L100: + ret_val = (integer)((real)min(*n1, *n2) * (float)1.6); + return ret_val; +L110: + ret_val = 1; + return ret_val; +L120: + ret_val = 50; + return ret_val; +L130: + ret_val = 25; + return ret_val; +L140: + ret_val = 1; + if (ret_val == 1) { + ret_val = ieeeck_(&c__1, &c_b176, &c_b177); + } + return ret_val; +L150: + ret_val = 1; + if (ret_val == 1) { + ret_val = ieeeck_(&c__0, &c_b176, &c_b177); + } + return ret_val; +L160: + ret_val = iparmq_(ispec, name__, opts, n1, n2, n3, n4, name_len, opts_len); + return ret_val; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/ilaenv.f b/lib/linalg/ilaenv.f deleted file mode 100644 index 3f0800b95e..0000000000 --- a/lib/linalg/ilaenv.f +++ /dev/null @@ -1,730 +0,0 @@ -*> \brief \b ILAENV -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ILAENV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) -* -* .. Scalar Arguments .. -* CHARACTER*( * ) NAME, OPTS -* INTEGER ISPEC, N1, N2, N3, N4 -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ILAENV is called from the LAPACK routines to choose problem-dependent -*> parameters for the local environment. See ISPEC for a description of -*> the parameters. -*> -*> ILAENV returns an INTEGER -*> if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC -*> if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal value. -*> -*> This version provides a set of parameters which should give good, -*> but not optimal, performance on many of the currently available -*> computers. Users are encouraged to modify this subroutine to set -*> the tuning parameters for their particular machine using the option -*> and problem size information in the arguments. -*> -*> This routine will not function correctly if it is converted to all -*> lower case. Converting it to all upper case is allowed. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] ISPEC -*> \verbatim -*> ISPEC is INTEGER -*> Specifies the parameter to be returned as the value of -*> ILAENV. -*> = 1: the optimal blocksize; if this value is 1, an unblocked -*> algorithm will give the best performance. -*> = 2: the minimum block size for which the block routine -*> should be used; if the usable block size is less than -*> this value, an unblocked routine should be used. -*> = 3: the crossover point (in a block routine, for N less -*> than this value, an unblocked routine should be used) -*> = 4: the number of shifts, used in the nonsymmetric -*> eigenvalue routines (DEPRECATED) -*> = 5: the minimum column dimension for blocking to be used; -*> rectangular blocks must have dimension at least k by m, -*> where k is given by ILAENV(2,...) and m by ILAENV(5,...) -*> = 6: the crossover point for the SVD (when reducing an m by n -*> matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds -*> this value, a QR factorization is used first to reduce -*> the matrix to a triangular form.) -*> = 7: the number of processors -*> = 8: the crossover point for the multishift QR method -*> for nonsymmetric eigenvalue problems (DEPRECATED) -*> = 9: maximum size of the subproblems at the bottom of the -*> computation tree in the divide-and-conquer algorithm -*> (used by xGELSD and xGESDD) -*> =10: ieee infinity and NaN arithmetic can be trusted not to trap -*> =11: infinity arithmetic can be trusted not to trap -*> 12 <= ISPEC <= 17: -*> xHSEQR or related subroutines, -*> see IPARMQ for detailed explanation -*> \endverbatim -*> -*> \param[in] NAME -*> \verbatim -*> NAME is CHARACTER*(*) -*> The name of the calling subroutine, in either upper case or -*> lower case. -*> \endverbatim -*> -*> \param[in] OPTS -*> \verbatim -*> OPTS is CHARACTER*(*) -*> The character options to the subroutine NAME, concatenated -*> into a single character string. For example, UPLO = 'U', -*> TRANS = 'T', and DIAG = 'N' for a triangular routine would -*> be specified as OPTS = 'UTN'. -*> \endverbatim -*> -*> \param[in] N1 -*> \verbatim -*> N1 is INTEGER -*> \endverbatim -*> -*> \param[in] N2 -*> \verbatim -*> N2 is INTEGER -*> \endverbatim -*> -*> \param[in] N3 -*> \verbatim -*> N3 is INTEGER -*> \endverbatim -*> -*> \param[in] N4 -*> \verbatim -*> N4 is INTEGER -*> Problem dimensions for the subroutine NAME; these may not all -*> be required. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The following conventions have been used when calling ILAENV from the -*> LAPACK routines: -*> 1) OPTS is a concatenation of all of the character options to -*> subroutine NAME, in the same order that they appear in the -*> argument list for NAME, even if they are not used in determining -*> the value of the parameter specified by ISPEC. -*> 2) The problem dimensions N1, N2, N3, N4 are specified in the order -*> that they appear in the argument list for NAME. N1 is used -*> first, N2 second, and so on, and unused problem dimensions are -*> passed a value of -1. -*> 3) The parameter value returned by ILAENV is checked for validity in -*> the calling subroutine. For example, ILAENV is used to retrieve -*> the optimal blocksize for STRTRI as follows: -*> -*> NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) -*> IF( NB.LE.1 ) NB = MAX( 1, N ) -*> \endverbatim -*> -* ===================================================================== - INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER*( * ) NAME, OPTS - INTEGER ISPEC, N1, N2, N3, N4 -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, IC, IZ, NB, NBMIN, NX - LOGICAL CNAME, SNAME, TWOSTAGE - CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*16 -* .. -* .. Intrinsic Functions .. - INTRINSIC CHAR, ICHAR, INT, MIN, REAL -* .. -* .. External Functions .. - INTEGER IEEECK, IPARMQ - EXTERNAL IEEECK, IPARMQ -* .. -* .. Executable Statements .. -* - GO TO ( 10, 10, 10, 80, 90, 100, 110, 120, - $ 130, 140, 150, 160, 160, 160, 160, 160, 160)ISPEC -* -* Invalid value for ISPEC -* - ILAENV = -1 - RETURN -* - 10 CONTINUE -* -* Convert NAME to upper case if the first character is lower case. -* - ILAENV = 1 - SUBNAM = NAME - IC = ICHAR( SUBNAM( 1: 1 ) ) - IZ = ICHAR( 'Z' ) - IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN -* -* ASCII character set -* - IF( IC.GE.97 .AND. IC.LE.122 ) THEN - SUBNAM( 1: 1 ) = CHAR( IC-32 ) - DO 20 I = 2, 6 - IC = ICHAR( SUBNAM( I: I ) ) - IF( IC.GE.97 .AND. IC.LE.122 ) - $ SUBNAM( I: I ) = CHAR( IC-32 ) - 20 CONTINUE - END IF -* - ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN -* -* EBCDIC character set -* - IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. - $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. - $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN - SUBNAM( 1: 1 ) = CHAR( IC+64 ) - DO 30 I = 2, 6 - IC = ICHAR( SUBNAM( I: I ) ) - IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. - $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. - $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: - $ I ) = CHAR( IC+64 ) - 30 CONTINUE - END IF -* - ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN -* -* Prime machines: ASCII+128 -* - IF( IC.GE.225 .AND. IC.LE.250 ) THEN - SUBNAM( 1: 1 ) = CHAR( IC-32 ) - DO 40 I = 2, 6 - IC = ICHAR( SUBNAM( I: I ) ) - IF( IC.GE.225 .AND. IC.LE.250 ) - $ SUBNAM( I: I ) = CHAR( IC-32 ) - 40 CONTINUE - END IF - END IF -* - C1 = SUBNAM( 1: 1 ) - SNAME = C1.EQ.'S' .OR. C1.EQ.'D' - CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' - IF( .NOT.( CNAME .OR. SNAME ) ) - $ RETURN - C2 = SUBNAM( 2: 3 ) - C3 = SUBNAM( 4: 6 ) - C4 = C3( 2: 3 ) - TWOSTAGE = LEN( SUBNAM ).GE.11 - $ .AND. SUBNAM( 11: 11 ).EQ.'2' -* - GO TO ( 50, 60, 70 )ISPEC -* - 50 CONTINUE -* -* ISPEC = 1: block size -* -* In these examples, separate code is provided for setting NB for -* real and complex. We assume that NB will take the same value in -* single or double precision. -* - NB = 1 -* - IF( SUBNAM(2:6).EQ.'LAORH' ) THEN -* -* This is for *LAORHR_GETRFNP routine -* - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. - $ C3.EQ.'QLF' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C3.EQ.'QR ') THEN - IF( N3 .EQ. 1) THEN - IF( SNAME ) THEN -* M*N - IF ((N1*N2.LE.131072).OR.(N1.LE.8192)) THEN - NB = N1 - ELSE - NB = 32768/N2 - END IF - ELSE - IF ((N1*N2.LE.131072).OR.(N1.LE.8192)) THEN - NB = N1 - ELSE - NB = 32768/N2 - END IF - END IF - ELSE - IF( SNAME ) THEN - NB = 1 - ELSE - NB = 1 - END IF - END IF - ELSE IF( C3.EQ.'LQ ') THEN - IF( N3 .EQ. 2) THEN - IF( SNAME ) THEN -* M*N - IF ((N1*N2.LE.131072).OR.(N1.LE.8192)) THEN - NB = N1 - ELSE - NB = 32768/N2 - END IF - ELSE - IF ((N1*N2.LE.131072).OR.(N1.LE.8192)) THEN - NB = N1 - ELSE - NB = 32768/N2 - END IF - END IF - ELSE - IF( SNAME ) THEN - NB = 1 - ELSE - NB = 1 - END IF - END IF - ELSE IF( C3.EQ.'HRD' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( C2.EQ.'PO' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - IF( TWOSTAGE ) THEN - NB = 192 - ELSE - NB = 64 - END IF - ELSE - IF( TWOSTAGE ) THEN - NB = 192 - ELSE - NB = 64 - END IF - END IF - ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NB = 32 - ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN - NB = 64 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( TWOSTAGE ) THEN - NB = 192 - ELSE - NB = 64 - END IF - ELSE IF( C3.EQ.'TRD' ) THEN - NB = 32 - ELSE IF( C3.EQ.'GST' ) THEN - NB = 64 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NB = 32 - END IF - ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NB = 32 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NB = 32 - END IF - ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NB = 32 - END IF - END IF - ELSE IF( C2.EQ.'GB' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - IF( N4.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - ELSE - IF( N4.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - END IF - END IF - ELSE IF( C2.EQ.'PB' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - IF( N2.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - ELSE - IF( N2.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - END IF - END IF - ELSE IF( C2.EQ.'TR' ) THEN - IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - ELSE IF ( C3.EQ.'EVC' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - ELSE IF( C3.EQ.'SYL' ) THEN -* The upper bound is to prevent overly aggressive scaling. - IF( SNAME ) THEN - NB = MIN( MAX( 48, INT( ( MIN( N1, N2 ) * 16 ) / 100) ), - $ 240 ) - ELSE - NB = MIN( MAX( 24, INT( ( MIN( N1, N2 ) * 8 ) / 100) ), - $ 80 ) - END IF - END IF - ELSE IF( C2.EQ.'LA' ) THEN - IF( C3.EQ.'UUM' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - ELSE IF( C3.EQ.'TRS' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - END IF - ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN - IF( C3.EQ.'EBZ' ) THEN - NB = 1 - END IF - ELSE IF( C2.EQ.'GG' ) THEN - NB = 32 - IF( C3.EQ.'HD3' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - END IF - END IF - ILAENV = NB - RETURN -* - 60 CONTINUE -* -* ISPEC = 2: minimum block size -* - NBMIN = 2 - IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. - $ 'QLF' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'HRD' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NBMIN = 8 - ELSE - NBMIN = 8 - END IF - ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NBMIN = 2 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRD' ) THEN - NBMIN = 2 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NBMIN = 2 - END IF - ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NBMIN = 2 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NBMIN = 2 - END IF - ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NBMIN = 2 - END IF - END IF - ELSE IF( C2.EQ.'GG' ) THEN - NBMIN = 2 - IF( C3.EQ.'HD3' ) THEN - NBMIN = 2 - END IF - END IF - ILAENV = NBMIN - RETURN -* - 70 CONTINUE -* -* ISPEC = 3: crossover point -* - NX = 0 - IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. - $ 'QLF' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - ELSE IF( C3.EQ.'HRD' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NX = 32 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRD' ) THEN - NX = 32 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NX = 128 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1: 1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. - $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) - $ THEN - NX = 128 - END IF - END IF - ELSE IF( C2.EQ.'GG' ) THEN - NX = 128 - IF( C3.EQ.'HD3' ) THEN - NX = 128 - END IF - END IF - ILAENV = NX - RETURN -* - 80 CONTINUE -* -* ISPEC = 4: number of shifts (used by xHSEQR) -* - ILAENV = 6 - RETURN -* - 90 CONTINUE -* -* ISPEC = 5: minimum column dimension (not used) -* - ILAENV = 2 - RETURN -* - 100 CONTINUE -* -* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) -* - ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) - RETURN -* - 110 CONTINUE -* -* ISPEC = 7: number of processors (not used) -* - ILAENV = 1 - RETURN -* - 120 CONTINUE -* -* ISPEC = 8: crossover point for multishift (used by xHSEQR) -* - ILAENV = 50 - RETURN -* - 130 CONTINUE -* -* ISPEC = 9: maximum size of the subproblems at the bottom of the -* computation tree in the divide-and-conquer algorithm -* (used by xGELSD and xGESDD) -* - ILAENV = 25 - RETURN -* - 140 CONTINUE -* -* ISPEC = 10: ieee and infinity NaN arithmetic can be trusted not to trap -* -* ILAENV = 0 - ILAENV = 1 - IF( ILAENV.EQ.1 ) THEN - ILAENV = IEEECK( 1, 0.0, 1.0 ) - END IF - RETURN -* - 150 CONTINUE -* -* ISPEC = 11: ieee infinity arithmetic can be trusted not to trap -* -* ILAENV = 0 - ILAENV = 1 - IF( ILAENV.EQ.1 ) THEN - ILAENV = IEEECK( 0, 0.0, 1.0 ) - END IF - RETURN -* - 160 CONTINUE -* -* 12 <= ISPEC <= 17: xHSEQR or related subroutines. -* - ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) - RETURN -* -* End of ILAENV -* - END diff --git a/lib/linalg/ilazlc.cpp b/lib/linalg/ilazlc.cpp new file mode 100644 index 0000000000..6832710dac --- /dev/null +++ b/lib/linalg/ilazlc.cpp @@ -0,0 +1,35 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +integer ilazlc_(integer *m, integer *n, doublecomplex *a, integer *lda) +{ + integer a_dim1, a_offset, ret_val, i__1, i__2; + integer i__; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + if (*n == 0) { + ret_val = *n; + } else { + i__1 = *n * a_dim1 + 1; + i__2 = *m + *n * a_dim1; + if (a[i__1].r != 0. || a[i__1].i != 0. || (a[i__2].r != 0. || a[i__2].i != 0.)) { + ret_val = *n; + } else { + for (ret_val = *n; ret_val >= 1; --ret_val) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + ret_val * a_dim1; + if (a[i__2].r != 0. || a[i__2].i != 0.) { + return ret_val; + } + } + } + } + } + return ret_val; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/ilazlc.f b/lib/linalg/ilazlc.f deleted file mode 100644 index 8af3430e61..0000000000 --- a/lib/linalg/ilazlc.f +++ /dev/null @@ -1,115 +0,0 @@ -*> \brief \b ILAZLC scans a matrix for its last non-zero column. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ILAZLC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* INTEGER FUNCTION ILAZLC( M, N, A, LDA ) -* -* .. Scalar Arguments .. -* INTEGER M, N, LDA -* .. -* .. Array Arguments .. -* COMPLEX*16 A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ILAZLC scans A for its last non-zero column. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,N) -*> The m by n matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERauxiliary -* -* ===================================================================== - INTEGER FUNCTION ILAZLC( M, N, A, LDA ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER M, N, LDA -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = (0.0D+0, 0.0D+0) ) -* .. -* .. Local Scalars .. - INTEGER I -* .. -* .. Executable Statements .. -* -* Quick test for the common case where one corner is non-zero. - IF( N.EQ.0 ) THEN - ILAZLC = N - ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN - ILAZLC = N - ELSE -* Now scan each column from the end, returning with the first non-zero. - DO ILAZLC = N, 1, -1 - DO I = 1, M - IF( A(I, ILAZLC).NE.ZERO ) RETURN - END DO - END DO - END IF - RETURN - END diff --git a/lib/linalg/ilazlr.cpp b/lib/linalg/ilazlr.cpp new file mode 100644 index 0000000000..dd741985be --- /dev/null +++ b/lib/linalg/ilazlr.cpp @@ -0,0 +1,37 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +integer ilazlr_(integer *m, integer *n, doublecomplex *a, integer *lda) +{ + integer a_dim1, a_offset, ret_val, i__1, i__2; + integer i__, j; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + if (*m == 0) { + ret_val = *m; + } else { + i__1 = *m + a_dim1; + i__2 = *m + *n * a_dim1; + if (a[i__1].r != 0. || a[i__1].i != 0. || (a[i__2].r != 0. || a[i__2].i != 0.)) { + ret_val = *m; + } else { + ret_val = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__ = *m; + for (;;) { + i__2 = max(i__, 1) + j * a_dim1; + if (!(a[i__2].r == 0. && a[i__2].i == 0. && i__ >= 1)) break; + --i__; + } + ret_val = max(ret_val, i__); + } + } + } + return ret_val; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/ilazlr.f b/lib/linalg/ilazlr.f deleted file mode 100644 index e0134a6a35..0000000000 --- a/lib/linalg/ilazlr.f +++ /dev/null @@ -1,118 +0,0 @@ -*> \brief \b ILAZLR scans a matrix for its last non-zero row. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ILAZLR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* INTEGER FUNCTION ILAZLR( M, N, A, LDA ) -* -* .. Scalar Arguments .. -* INTEGER M, N, LDA -* .. -* .. Array Arguments .. -* COMPLEX*16 A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ILAZLR scans A for its last non-zero row. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,N) -*> The m by n matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERauxiliary -* -* ===================================================================== - INTEGER FUNCTION ILAZLR( M, N, A, LDA ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER M, N, LDA -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = (0.0D+0, 0.0D+0) ) -* .. -* .. Local Scalars .. - INTEGER I, J -* .. -* .. Executable Statements .. -* -* Quick test for the common case where one corner is non-zero. - IF( M.EQ.0 ) THEN - ILAZLR = M - ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN - ILAZLR = M - ELSE -* Scan up each column tracking the last zero row seen. - ILAZLR = 0 - DO J = 1, N - I=M - DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1)) - I=I-1 - ENDDO - ILAZLR = MAX( ILAZLR, I ) - END DO - END IF - RETURN - END diff --git a/lib/linalg/iparmq.cpp b/lib/linalg/iparmq.cpp new file mode 100644 index 0000000000..3ed8cd778a --- /dev/null +++ b/lib/linalg/iparmq.cpp @@ -0,0 +1,122 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +integer iparmq_(integer *ispec, char *name__, char *opts, integer *n, integer *ilo, integer *ihi, + integer *lwork, ftnlen name_len, ftnlen opts_len) +{ + integer ret_val, i__1, i__2; + real r__1; + double log(doublereal); + integer i_lmp_nint(real *); + int s_lmp_copy(char *, char *, ftnlen, ftnlen); + integer s_lmp_cmp(char *, char *, ftnlen, ftnlen); + integer i__, ic, nh, ns, iz; + char subnam[6]; + if (*ispec == 15 || *ispec == 13 || *ispec == 16) { + nh = *ihi - *ilo + 1; + ns = 2; + if (nh >= 30) { + ns = 4; + } + if (nh >= 60) { + ns = 10; + } + if (nh >= 150) { + r__1 = log((real)nh) / log((float)2.); + i__1 = 10, i__2 = nh / i_lmp_nint(&r__1); + ns = max(i__1, i__2); + } + if (nh >= 590) { + ns = 64; + } + if (nh >= 3000) { + ns = 128; + } + if (nh >= 6000) { + ns = 256; + } + i__1 = 2, i__2 = ns - ns % 2; + ns = max(i__1, i__2); + } + if (*ispec == 12) { + ret_val = 75; + } else if (*ispec == 14) { + ret_val = 14; + } else if (*ispec == 15) { + ret_val = ns; + } else if (*ispec == 13) { + if (nh <= 500) { + ret_val = ns; + } else { + ret_val = ns * 3 / 2; + } + } else if (*ispec == 16) { + ret_val = 0; + s_lmp_copy(subnam, name__, (ftnlen)6, name_len); + ic = *(unsigned char *)subnam; + iz = 'Z'; + if (iz == 90 || iz == 122) { + if (ic >= 97 && ic <= 122) { + *(unsigned char *)subnam = (char)(ic - 32); + for (i__ = 2; i__ <= 6; ++i__) { + ic = *(unsigned char *)&subnam[i__ - 1]; + if (ic >= 97 && ic <= 122) { + *(unsigned char *)&subnam[i__ - 1] = (char)(ic - 32); + } + } + } + } else if (iz == 233 || iz == 169) { + if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= 162 && ic <= 169) { + *(unsigned char *)subnam = (char)(ic + 64); + for (i__ = 2; i__ <= 6; ++i__) { + ic = *(unsigned char *)&subnam[i__ - 1]; + if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || + ic >= 162 && ic <= 169) { + *(unsigned char *)&subnam[i__ - 1] = (char)(ic + 64); + } + } + } + } else if (iz == 218 || iz == 250) { + if (ic >= 225 && ic <= 250) { + *(unsigned char *)subnam = (char)(ic - 32); + for (i__ = 2; i__ <= 6; ++i__) { + ic = *(unsigned char *)&subnam[i__ - 1]; + if (ic >= 225 && ic <= 250) { + *(unsigned char *)&subnam[i__ - 1] = (char)(ic - 32); + } + } + } + } + if (s_lmp_cmp(subnam + 1, (char *)"GGHRD", (ftnlen)5, (ftnlen)5) == 0 || + s_lmp_cmp(subnam + 1, (char *)"GGHD3", (ftnlen)5, (ftnlen)5) == 0) { + ret_val = 1; + if (nh >= 14) { + ret_val = 2; + } + } else if (s_lmp_cmp(subnam + 3, (char *)"EXC", (ftnlen)3, (ftnlen)3) == 0) { + if (nh >= 14) { + ret_val = 1; + } + if (nh >= 14) { + ret_val = 2; + } + } else if (s_lmp_cmp(subnam + 1, (char *)"HSEQR", (ftnlen)5, (ftnlen)5) == 0 || + s_lmp_cmp(subnam + 1, (char *)"LAQR", (ftnlen)4, (ftnlen)4) == 0) { + if (ns >= 14) { + ret_val = 1; + } + if (ns >= 14) { + ret_val = 2; + } + } + } else if (*ispec == 17) { + ret_val = 10; + } else { + ret_val = -1; + } + return ret_val; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/iparmq.f b/lib/linalg/iparmq.f deleted file mode 100644 index 54c05471ca..0000000000 --- a/lib/linalg/iparmq.f +++ /dev/null @@ -1,406 +0,0 @@ -*> \brief \b IPARMQ -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download IPARMQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) -* -* .. Scalar Arguments .. -* INTEGER IHI, ILO, ISPEC, LWORK, N -* CHARACTER NAME*( * ), OPTS*( * ) -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> This program sets problem and machine dependent parameters -*> useful for xHSEQR and related subroutines for eigenvalue -*> problems. It is called whenever -*> IPARMQ is called with 12 <= ISPEC <= 16 -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] ISPEC -*> \verbatim -*> ISPEC is INTEGER -*> ISPEC specifies which tunable parameter IPARMQ should -*> return. -*> -*> ISPEC=12: (INMIN) Matrices of order nmin or less -*> are sent directly to xLAHQR, the implicit -*> double shift QR algorithm. NMIN must be -*> at least 11. -*> -*> ISPEC=13: (INWIN) Size of the deflation window. -*> This is best set greater than or equal to -*> the number of simultaneous shifts NS. -*> Larger matrices benefit from larger deflation -*> windows. -*> -*> ISPEC=14: (INIBL) Determines when to stop nibbling and -*> invest in an (expensive) multi-shift QR sweep. -*> If the aggressive early deflation subroutine -*> finds LD converged eigenvalues from an order -*> NW deflation window and LD > (NW*NIBBLE)/100, -*> then the next QR sweep is skipped and early -*> deflation is applied immediately to the -*> remaining active diagonal block. Setting -*> IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a -*> multi-shift QR sweep whenever early deflation -*> finds a converged eigenvalue. Setting -*> IPARMQ(ISPEC=14) greater than or equal to 100 -*> prevents TTQRE from skipping a multi-shift -*> QR sweep. -*> -*> ISPEC=15: (NSHFTS) The number of simultaneous shifts in -*> a multi-shift QR iteration. -*> -*> ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the -*> following meanings. -*> 0: During the multi-shift QR/QZ sweep, -*> blocked eigenvalue reordering, blocked -*> Hessenberg-triangular reduction, -*> reflections and/or rotations are not -*> accumulated when updating the -*> far-from-diagonal matrix entries. -*> 1: During the multi-shift QR/QZ sweep, -*> blocked eigenvalue reordering, blocked -*> Hessenberg-triangular reduction, -*> reflections and/or rotations are -*> accumulated, and matrix-matrix -*> multiplication is used to update the -*> far-from-diagonal matrix entries. -*> 2: During the multi-shift QR/QZ sweep, -*> blocked eigenvalue reordering, blocked -*> Hessenberg-triangular reduction, -*> reflections and/or rotations are -*> accumulated, and 2-by-2 block structure -*> is exploited during matrix-matrix -*> multiplies. -*> (If xTRMM is slower than xGEMM, then -*> IPARMQ(ISPEC=16)=1 may be more efficient than -*> IPARMQ(ISPEC=16)=2 despite the greater level of -*> arithmetic work implied by the latter choice.) -*> -*> ISPEC=17: (ICOST) An estimate of the relative cost of flops -*> within the near-the-diagonal shift chase compared -*> to flops within the BLAS calls of a QZ sweep. -*> \endverbatim -*> -*> \param[in] NAME -*> \verbatim -*> NAME is CHARACTER string -*> Name of the calling subroutine -*> \endverbatim -*> -*> \param[in] OPTS -*> \verbatim -*> OPTS is CHARACTER string -*> This is a concatenation of the string arguments to -*> TTQRE. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> N is the order of the Hessenberg matrix H. -*> \endverbatim -*> -*> \param[in] ILO -*> \verbatim -*> ILO is INTEGER -*> \endverbatim -*> -*> \param[in] IHI -*> \verbatim -*> IHI is INTEGER -*> It is assumed that H is already upper triangular -*> in rows and columns 1:ILO-1 and IHI+1:N. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The amount of workspace available. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Little is known about how best to choose these parameters. -*> It is possible to use different values of the parameters -*> for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR. -*> -*> It is probably best to choose different parameters for -*> different matrices and different parameters at different -*> times during the iteration, but this has not been -*> implemented --- yet. -*> -*> -*> The best choices of most of the parameters depend -*> in an ill-understood way on the relative execution -*> rate of xLAQR3 and xLAQR5 and on the nature of each -*> particular eigenvalue problem. Experiment may be the -*> only practical way to determine which choices are most -*> effective. -*> -*> Following is a list of default values supplied by IPARMQ. -*> These defaults may be adjusted in order to attain better -*> performance in any particular computational environment. -*> -*> IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point. -*> Default: 75. (Must be at least 11.) -*> -*> IPARMQ(ISPEC=13) Recommended deflation window size. -*> This depends on ILO, IHI and NS, the -*> number of simultaneous shifts returned -*> by IPARMQ(ISPEC=15). The default for -*> (IHI-ILO+1) <= 500 is NS. The default -*> for (IHI-ILO+1) > 500 is 3*NS/2. -*> -*> IPARMQ(ISPEC=14) Nibble crossover point. Default: 14. -*> -*> IPARMQ(ISPEC=15) Number of simultaneous shifts, NS. -*> a multi-shift QR iteration. -*> -*> If IHI-ILO+1 is ... -*> -*> greater than ...but less ... the -*> or equal to ... than default is -*> -*> 0 30 NS = 2+ -*> 30 60 NS = 4+ -*> 60 150 NS = 10 -*> 150 590 NS = ** -*> 590 3000 NS = 64 -*> 3000 6000 NS = 128 -*> 6000 infinity NS = 256 -*> -*> (+) By default matrices of this order are -*> passed to the implicit double shift routine -*> xLAHQR. See IPARMQ(ISPEC=12) above. These -*> values of NS are used only in case of a rare -*> xLAHQR failure. -*> -*> (**) The asterisks (**) indicate an ad-hoc -*> function increasing from 10 to 64. -*> -*> IPARMQ(ISPEC=16) Select structured matrix multiply. -*> (See ISPEC=16 above for details.) -*> Default: 3. -*> -*> IPARMQ(ISPEC=17) Relative cost heuristic for blocksize selection. -*> Expressed as a percentage. -*> Default: 10. -*> \endverbatim -*> -* ===================================================================== - INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER IHI, ILO, ISPEC, LWORK, N - CHARACTER NAME*( * ), OPTS*( * ) -* -* ================================================================ -* .. Parameters .. - INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22, ICOST - PARAMETER ( INMIN = 12, INWIN = 13, INIBL = 14, - $ ISHFTS = 15, IACC22 = 16, ICOST = 17 ) - INTEGER NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP, RCOST - PARAMETER ( NMIN = 75, K22MIN = 14, KACMIN = 14, - $ NIBBLE = 14, KNWSWP = 500, RCOST = 10 ) - REAL TWO - PARAMETER ( TWO = 2.0 ) -* .. -* .. Local Scalars .. - INTEGER NH, NS - INTEGER I, IC, IZ - CHARACTER SUBNAM*6 -* .. -* .. Intrinsic Functions .. - INTRINSIC LOG, MAX, MOD, NINT, REAL -* .. -* .. Executable Statements .. - IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR. - $ ( ISPEC.EQ.IACC22 ) ) THEN -* -* ==== Set the number simultaneous shifts ==== -* - NH = IHI - ILO + 1 - NS = 2 - IF( NH.GE.30 ) - $ NS = 4 - IF( NH.GE.60 ) - $ NS = 10 - IF( NH.GE.150 ) - $ NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ) ) - IF( NH.GE.590 ) - $ NS = 64 - IF( NH.GE.3000 ) - $ NS = 128 - IF( NH.GE.6000 ) - $ NS = 256 - NS = MAX( 2, NS-MOD( NS, 2 ) ) - END IF -* - IF( ISPEC.EQ.INMIN ) THEN -* -* -* ===== Matrices of order smaller than NMIN get sent -* . to xLAHQR, the classic double shift algorithm. -* . This must be at least 11. ==== -* - IPARMQ = NMIN -* - ELSE IF( ISPEC.EQ.INIBL ) THEN -* -* ==== INIBL: skip a multi-shift qr iteration and -* . whenever aggressive early deflation finds -* . at least (NIBBLE*(window size)/100) deflations. ==== -* - IPARMQ = NIBBLE -* - ELSE IF( ISPEC.EQ.ISHFTS ) THEN -* -* ==== NSHFTS: The number of simultaneous shifts ===== -* - IPARMQ = NS -* - ELSE IF( ISPEC.EQ.INWIN ) THEN -* -* ==== NW: deflation window size. ==== -* - IF( NH.LE.KNWSWP ) THEN - IPARMQ = NS - ELSE - IPARMQ = 3*NS / 2 - END IF -* - ELSE IF( ISPEC.EQ.IACC22 ) THEN -* -* ==== IACC22: Whether to accumulate reflections -* . before updating the far-from-diagonal elements -* . and whether to use 2-by-2 block structure while -* . doing it. A small amount of work could be saved -* . by making this choice dependent also upon the -* . NH=IHI-ILO+1. -* -* -* Convert NAME to upper case if the first character is lower case. -* - IPARMQ = 0 - SUBNAM = NAME - IC = ICHAR( SUBNAM( 1: 1 ) ) - IZ = ICHAR( 'Z' ) - IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN -* -* ASCII character set -* - IF( IC.GE.97 .AND. IC.LE.122 ) THEN - SUBNAM( 1: 1 ) = CHAR( IC-32 ) - DO I = 2, 6 - IC = ICHAR( SUBNAM( I: I ) ) - IF( IC.GE.97 .AND. IC.LE.122 ) - $ SUBNAM( I: I ) = CHAR( IC-32 ) - END DO - END IF -* - ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN -* -* EBCDIC character set -* - IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. - $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. - $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN - SUBNAM( 1: 1 ) = CHAR( IC+64 ) - DO I = 2, 6 - IC = ICHAR( SUBNAM( I: I ) ) - IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. - $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. - $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: - $ I ) = CHAR( IC+64 ) - END DO - END IF -* - ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN -* -* Prime machines: ASCII+128 -* - IF( IC.GE.225 .AND. IC.LE.250 ) THEN - SUBNAM( 1: 1 ) = CHAR( IC-32 ) - DO I = 2, 6 - IC = ICHAR( SUBNAM( I: I ) ) - IF( IC.GE.225 .AND. IC.LE.250 ) - $ SUBNAM( I: I ) = CHAR( IC-32 ) - END DO - END IF - END IF -* - IF( SUBNAM( 2:6 ).EQ.'GGHRD' .OR. - $ SUBNAM( 2:6 ).EQ.'GGHD3' ) THEN - IPARMQ = 1 - IF( NH.GE.K22MIN ) - $ IPARMQ = 2 - ELSE IF ( SUBNAM( 4:6 ).EQ.'EXC' ) THEN - IF( NH.GE.KACMIN ) - $ IPARMQ = 1 - IF( NH.GE.K22MIN ) - $ IPARMQ = 2 - ELSE IF ( SUBNAM( 2:6 ).EQ.'HSEQR' .OR. - $ SUBNAM( 2:5 ).EQ.'LAQR' ) THEN - IF( NS.GE.KACMIN ) - $ IPARMQ = 1 - IF( NS.GE.K22MIN ) - $ IPARMQ = 2 - END IF -* - ELSE IF( ISPEC.EQ.ICOST ) THEN -* -* === Relative cost of near-the-diagonal chase vs -* BLAS updates === -* - IPARMQ = RCOST - ELSE -* ===== invalid value of ispec ===== - IPARMQ = -1 -* - END IF -* -* ==== End of IPARMQ ==== -* - END diff --git a/lib/linalg/lmp_f2c.h b/lib/linalg/lmp_f2c.h new file mode 100644 index 0000000000..7483a147ea --- /dev/null +++ b/lib/linalg/lmp_f2c.h @@ -0,0 +1,223 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef long int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; +#ifdef INTEGER_STAR_8 /* Adjust for integer*8. */ +typedef long long longint; /* system-dependent */ +typedef unsigned long long ulongint; /* system-dependent */ +#define qbit_clear(a,b) ((a) & ~((ulongint)1 << (b))) +#define qbit_set(a,b) ((a) | ((ulongint)1 << (b))) +#endif + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +#ifdef f2c_i2 +/* for -i2 */ +typedef short flag; +typedef short ftnlen; +typedef short ftnint; +#else +typedef long int flag; +typedef long int ftnlen; +typedef long int ftnint; +#endif + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +/*typedef long int Long;*/ /* No longer used; formerly in Namelist */ + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (doublereal)abs(x) +#define min(a,b) ((a) <= (b) ? (a) : (b)) +#define max(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (doublereal)min(a,b) +#define dmax(a,b) (doublereal)max(a,b) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef int /* Unknown procedure type */ (*U_fp)(...); +typedef shortint (*J_fp)(...); +typedef integer (*I_fp)(...); +typedef real (*R_fp)(...); +typedef doublereal (*D_fp)(...), (*E_fp)(...); +typedef /* Complex */ VOID (*C_fp)(...); +typedef /* Double Complex */ VOID (*Z_fp)(...); +typedef logical (*L_fp)(...); +typedef shortlogical (*K_fp)(...); +typedef /* Character */ VOID (*H_fp)(...); +typedef /* Subroutine */ int (*S_fp)(...); +#else +typedef int /* Unknown procedure type */ (*U_fp)(); +typedef shortint (*J_fp)(); +typedef integer (*I_fp)(); +typedef real (*R_fp)(); +typedef doublereal (*D_fp)(), (*E_fp)(); +typedef /* Complex */ VOID (*C_fp)(); +typedef /* Double Complex */ VOID (*Z_fp)(); +typedef logical (*L_fp)(); +typedef shortlogical (*K_fp)(); +typedef /* Character */ VOID (*H_fp)(); +typedef /* Subroutine */ int (*S_fp)(); +#endif +/* E_fp is for real functions when -R is not specified */ +typedef VOID C_f; /* complex function */ +typedef VOID H_f; /* character function */ +typedef VOID Z_f; /* double complex function */ +typedef doublereal E_f; /* real function with -R not specified */ + +/* undef any lower-case symbols that your C compiler predefines, e.g.: */ + +#ifndef Skip_f2c_Undefs +#undef cray +#undef gcos +#undef mc68010 +#undef mc68020 +#undef mips +#undef pdp11 +#undef sgi +#undef sparc +#undef sun +#undef sun2 +#undef sun3 +#undef sun4 +#undef u370 +#undef u3b +#undef u3b2 +#undef u3b5 +#undef unix +#undef vax +#endif +#endif diff --git a/lib/linalg/lsame.cpp b/lib/linalg/lsame.cpp new file mode 100644 index 0000000000..480ae93bc9 --- /dev/null +++ b/lib/linalg/lsame.cpp @@ -0,0 +1,17 @@ + +#include + +extern "C" { + +#include "lmp_f2c.h" + +logical lsame_(const char *a, const char *b) +{ + char ua, ub; + if (!a || !b) return FALSE_; + + ua = toupper(*a); + ub = toupper(*b); + return (ua == ub) ? TRUE_ : FALSE_; +} +} diff --git a/lib/linalg/lsame.f b/lib/linalg/lsame.f deleted file mode 100644 index 6aa4007065..0000000000 --- a/lib/linalg/lsame.f +++ /dev/null @@ -1,122 +0,0 @@ -*> \brief \b LSAME -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* LOGICAL FUNCTION LSAME(CA,CB) -* -* .. Scalar Arguments .. -* CHARACTER CA,CB -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> LSAME returns .TRUE. if CA is the same letter as CB regardless of -*> case. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] CA -*> \verbatim -*> CA is CHARACTER*1 -*> \endverbatim -*> -*> \param[in] CB -*> \verbatim -*> CB is CHARACTER*1 -*> CA and CB specify the single characters to be compared. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup aux_blas -* -* ===================================================================== - LOGICAL FUNCTION LSAME(CA,CB) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER CA,CB -* .. -* -* ===================================================================== -* -* .. Intrinsic Functions .. - INTRINSIC ICHAR -* .. -* .. Local Scalars .. - INTEGER INTA,INTB,ZCODE -* .. -* -* Test if the characters are equal -* - LSAME = CA .EQ. CB - IF (LSAME) RETURN -* -* Now test for equivalence if both characters are alphabetic. -* - ZCODE = ICHAR('Z') -* -* Use 'Z' rather than 'A' so that ASCII can be detected on Prime -* machines, on which ICHAR returns a value with bit 8 set. -* ICHAR('A') on Prime machines returns 193 which is the same as -* ICHAR('A') on an EBCDIC machine. -* - INTA = ICHAR(CA) - INTB = ICHAR(CB) -* - IF (ZCODE.EQ.90 .OR. ZCODE.EQ.122) THEN -* -* ASCII is assumed - ZCODE is the ASCII code of either lower or -* upper case 'Z'. -* - IF (INTA.GE.97 .AND. INTA.LE.122) INTA = INTA - 32 - IF (INTB.GE.97 .AND. INTB.LE.122) INTB = INTB - 32 -* - ELSE IF (ZCODE.EQ.233 .OR. ZCODE.EQ.169) THEN -* -* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or -* upper case 'Z'. -* - IF (INTA.GE.129 .AND. INTA.LE.137 .OR. - + INTA.GE.145 .AND. INTA.LE.153 .OR. - + INTA.GE.162 .AND. INTA.LE.169) INTA = INTA + 64 - IF (INTB.GE.129 .AND. INTB.LE.137 .OR. - + INTB.GE.145 .AND. INTB.LE.153 .OR. - + INTB.GE.162 .AND. INTB.LE.169) INTB = INTB + 64 -* - ELSE IF (ZCODE.EQ.218 .OR. ZCODE.EQ.250) THEN -* -* ASCII is assumed, on Prime machines - ZCODE is the ASCII code -* plus 128 of either lower or upper case 'Z'. -* - IF (INTA.GE.225 .AND. INTA.LE.250) INTA = INTA - 32 - IF (INTB.GE.225 .AND. INTB.LE.250) INTB = INTB - 32 - END IF - LSAME = INTA .EQ. INTB -* -* RETURN -* -* End of LSAME -* - END diff --git a/lib/linalg/pow_lmp_dd.cpp b/lib/linalg/pow_lmp_dd.cpp new file mode 100644 index 0000000000..4963b04bbc --- /dev/null +++ b/lib/linalg/pow_lmp_dd.cpp @@ -0,0 +1,12 @@ + +#include "lmp_f2c.h" +#undef abs + +#include + +extern "C" { +double pow_lmp_dd(doublereal *ap, doublereal *bp) +{ + return (pow(*ap, *bp)); +} +} diff --git a/lib/linalg/pow_lmp_di.cpp b/lib/linalg/pow_lmp_di.cpp new file mode 100644 index 0000000000..83a0da1a87 --- /dev/null +++ b/lib/linalg/pow_lmp_di.cpp @@ -0,0 +1,31 @@ + +#include "lmp_f2c.h" + +extern "C" { + +double pow_lmp_di(doublereal *ap, integer *bp) +{ + double pow, x; + integer n; + unsigned long u; + + pow = 1; + x = *ap; + n = *bp; + + if (n != 0) { + if (n < 0) { + n = -n; + x = 1 / x; + } + for (u = n;;) { + if (u & 01) pow *= x; + if (u >>= 1) + x *= x; + else + break; + } + } + return (pow); +} +} diff --git a/lib/linalg/pow_lmp_ii.cpp b/lib/linalg/pow_lmp_ii.cpp new file mode 100644 index 0000000000..ff28c8fd5a --- /dev/null +++ b/lib/linalg/pow_lmp_ii.cpp @@ -0,0 +1,29 @@ + +#include "lmp_f2c.h" + +extern "C" { + +integer pow_lmp_ii(integer *ap, integer *bp) +{ + integer pow, x, n; + unsigned long u; + + x = *ap; + n = *bp; + + if (n <= 0) { + if (n == 0 || x == 1) return 1; + if (x != -1) return x == 0 ? 1 / x : 0; + n = -n; + } + u = n; + for (pow = 1;;) { + if (u & 01) pow *= x; + if (u >>= 1) + x *= x; + else + break; + } + return (pow); +} +} diff --git a/lib/linalg/s_lmp_cat.cpp b/lib/linalg/s_lmp_cat.cpp new file mode 100644 index 0000000000..323b0b671d --- /dev/null +++ b/lib/linalg/s_lmp_cat.cpp @@ -0,0 +1,23 @@ + +#include "lmp_f2c.h" + +// concatenate two strings + +extern "C" { +void s_lmp_cat(char *lp, char *rpp[], ftnint rnp[], ftnint *np, ftnlen ll) +{ + ftnlen i, nc; + char *rp; + ftnlen n = *np; + for (i = 0; i < n; ++i) { + nc = ll; + if (rnp[i] < nc) nc = rnp[i]; + ll -= nc; + rp = rpp[i]; + while (--nc >= 0) + *lp++ = *rp++; + } + while (--ll >= 0) + *lp++ = ' '; +} +} diff --git a/lib/linalg/s_lmp_cmp.cpp b/lib/linalg/s_lmp_cmp.cpp new file mode 100644 index 0000000000..51c47167e4 --- /dev/null +++ b/lib/linalg/s_lmp_cmp.cpp @@ -0,0 +1,45 @@ + +#include "lmp_f2c.h" + +extern "C" { + +// compare two strings + +integer s_lmp_cmp(char *a0, char *b0, ftnlen la, ftnlen lb) +{ + unsigned char *a, *aend, *b, *bend; + a = (unsigned char *)a0; + b = (unsigned char *)b0; + aend = a + la; + bend = b + lb; + + if (la <= lb) { + while (a < aend) + if (*a != *b) + return (*a - *b); + else { + ++a; + ++b; + } + + while (b < bend) + if (*b != ' ') + return (' ' - *b); + else + ++b; + } else { + while (b < bend) + if (*a == *b) { + ++a; + ++b; + } else + return (*a - *b); + while (a < aend) + if (*a != ' ') + return (*a - ' '); + else + ++a; + } + return (0); +} +} diff --git a/lib/linalg/s_lmp_copy.cpp b/lib/linalg/s_lmp_copy.cpp new file mode 100644 index 0000000000..5e09459b1b --- /dev/null +++ b/lib/linalg/s_lmp_copy.cpp @@ -0,0 +1,26 @@ + +#include "lmp_f2c.h" + +extern "C" { + +/* assign strings: a = b */ + +void s_lmp_copy(char *a, char *b, ftnlen la, ftnlen lb) +{ + char *aend, *bend; + + aend = a + la; + + if (la <= lb) + while (a < aend) + *a++ = *b++; + + else { + bend = b + lb; + while (b < bend) + *a++ = *b++; + while (a < aend) + *a++ = ' '; + } +} +} diff --git a/lib/linalg/xerbla.cpp b/lib/linalg/xerbla.cpp new file mode 100644 index 0000000000..6346126c67 --- /dev/null +++ b/lib/linalg/xerbla.cpp @@ -0,0 +1,31 @@ + +#include "lmp_f2c.h" + +#undef abs +#include +#include +#include + +extern "C" { + +static constexpr int BUFSZ = 1024; + +integer xerbla_(const char *srname, integer *info) +{ + char buf[BUFSZ]; + buf[0] = '\0'; + + strcat(buf, " ** On entry to "); + for (int i = 0; i < BUFSZ - 16; ++i) { + if ((srname[i] == '\0') || (srname[i] == ' ')) { + buf[i + 16] = '\0'; + break; + } + buf[i + 16] = srname[i]; + } + int len = strlen(buf); + snprintf(buf + len, BUFSZ - len, " parameter number %d had an illegal value\n", *info); + exit(1); + return 0; +} +} diff --git a/lib/linalg/xerbla.f b/lib/linalg/xerbla.f deleted file mode 100644 index 6b141499ee..0000000000 --- a/lib/linalg/xerbla.f +++ /dev/null @@ -1,96 +0,0 @@ -*> \brief \b XERBLA -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download XERBLA + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE XERBLA( SRNAME, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER*(*) SRNAME -* INTEGER INFO -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> XERBLA is an error handler for the LAPACK routines. -*> It is called by an LAPACK routine if an input parameter has an -*> invalid value. A message is printed and execution stops. -*> -*> Installers may consider modifying the STOP statement in order to -*> call system-specific exception-handling facilities. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SRNAME -*> \verbatim -*> SRNAME is CHARACTER*(*) -*> The name of the routine which called XERBLA. -*> \endverbatim -*> -*> \param[in] INFO -*> \verbatim -*> INFO is INTEGER -*> The position of the invalid parameter in the parameter list -*> of the calling routine. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup OTHERauxiliary -* -* ===================================================================== - SUBROUTINE XERBLA( SRNAME, INFO ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER*(*) SRNAME - INTEGER INFO -* .. -* -* ===================================================================== -* -* .. Intrinsic Functions .. - INTRINSIC LEN_TRIM -* .. -* .. Executable Statements .. -* - WRITE( *, FMT = 9999 )SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO -* - STOP -* - 9999 FORMAT( ' ** On entry to ', A, ' parameter number ', I2, ' had ', - $ 'an illegal value' ) -* -* End of XERBLA -* - END diff --git a/lib/linalg/z_lmp_abs.cpp b/lib/linalg/z_lmp_abs.cpp new file mode 100644 index 0000000000..2b79d56457 --- /dev/null +++ b/lib/linalg/z_lmp_abs.cpp @@ -0,0 +1,31 @@ + +#include "lmp_f2c.h" +#undef abs + +#include + +extern "C" { + +static double f__cabs(double real, double imag) +{ + double temp; + + if (real < 0) real = -real; + if (imag < 0) imag = -imag; + if (imag > real) { + temp = real; + real = imag; + imag = temp; + } + if ((real + imag) == real) return (real); + + temp = imag / real; + temp = real * sqrt(1.0 + temp * temp); /*overflow!!*/ + return (temp); +} + +double z_lmp_abs(doublecomplex *z) +{ + return (f__cabs(z->r, z->i)); +} +} diff --git a/lib/linalg/z_lmp_div.cpp b/lib/linalg/z_lmp_div.cpp new file mode 100644 index 0000000000..66218f8fc8 --- /dev/null +++ b/lib/linalg/z_lmp_div.cpp @@ -0,0 +1,31 @@ + +#include "lmp_f2c.h" + +extern "C" { + +void z_lmp_div(doublecomplex *c, doublecomplex *a, doublecomplex *b) +{ + double ratio, den; + double abr, abi, cr; + + if ((abr = b->r) < 0.) abr = -abr; + if ((abi = b->i) < 0.) abi = -abi; + if (abr <= abi) { + if (abi == 0) { + if (a->i != 0 || a->r != 0) abi = 1.; + c->i = c->r = abi / abr; + return; + } + ratio = b->r / b->i; + den = b->i * (1 + ratio * ratio); + cr = (a->r * ratio + a->i) / den; + c->i = (a->i * ratio - a->r) / den; + } else { + ratio = b->i / b->r; + den = b->r * (1 + ratio * ratio); + cr = (a->r + a->i * ratio) / den; + c->i = (a->i - a->r * ratio) / den; + } + c->r = cr; +} +} diff --git a/lib/linalg/zaxpy.cpp b/lib/linalg/zaxpy.cpp new file mode 100644 index 0000000000..13c4e819db --- /dev/null +++ b/lib/linalg/zaxpy.cpp @@ -0,0 +1,57 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int zaxpy_(integer *n, doublecomplex *za, doublecomplex *zx, integer *incx, doublecomplex *zy, + integer *incy) +{ + integer i__1, i__2, i__3, i__4; + doublecomplex z__1, z__2; + integer i__, ix, iy; + extern doublereal dcabs1_(doublecomplex *); + --zy; + --zx; + if (*n <= 0) { + return 0; + } + if (dcabs1_(za) == 0.) { + return 0; + } + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__2.r = za->r * zx[i__4].r - za->i * zx[i__4].i, + z__2.i = za->r * zx[i__4].i + za->i * zx[i__4].r; + z__1.r = zy[i__3].r + z__2.r, z__1.i = zy[i__3].i + z__2.i; + zy[i__2].r = z__1.r, zy[i__2].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 = iy; + i__3 = iy; + i__4 = ix; + z__2.r = za->r * zx[i__4].r - za->i * zx[i__4].i, + z__2.i = za->r * zx[i__4].i + za->i * zx[i__4].r; + z__1.r = zy[i__3].r + z__2.r, z__1.i = zy[i__3].i + z__2.i; + zy[i__2].r = z__1.r, zy[i__2].i = z__1.i; + ix += *incx; + iy += *incy; + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zaxpy.f b/lib/linalg/zaxpy.f deleted file mode 100644 index 35c0e4b892..0000000000 --- a/lib/linalg/zaxpy.f +++ /dev/null @@ -1,139 +0,0 @@ -*> \brief \b ZAXPY -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE ZAXPY(N,ZA,ZX,INCX,ZY,INCY) -* -* .. Scalar Arguments .. -* COMPLEX*16 ZA -* INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. -* COMPLEX*16 ZX(*),ZY(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZAXPY constant times a vector plus a vector. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> number of elements in input vector(s) -*> \endverbatim -*> -*> \param[in] ZA -*> \verbatim -*> ZA is COMPLEX*16 -*> On entry, ZA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] ZX -*> \verbatim -*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> storage spacing between elements of ZX -*> \endverbatim -*> -*> \param[in,out] ZY -*> \verbatim -*> ZY is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> storage spacing between elements of ZY -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16_blas_level1 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> jack dongarra, 3/11/78. -*> modified 12/3/93, array(1) declarations changed to array(*) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZAXPY(N,ZA,ZX,INCX,ZY,INCY) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - COMPLEX*16 ZA - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - COMPLEX*16 ZX(*),ZY(*) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I,IX,IY -* .. -* .. External Functions .. - DOUBLE PRECISION DCABS1 - EXTERNAL DCABS1 -* .. - IF (N.LE.0) RETURN - IF (DCABS1(ZA).EQ.0.0d0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 -* - DO I = 1,N - ZY(I) = ZY(I) + ZA*ZX(I) - END DO - ELSE -* -* code for unequal increments or equal increments -* not equal to 1 -* - IX = 1 - IY = 1 - IF (INCX.LT.0) IX = (-N+1)*INCX + 1 - IF (INCY.LT.0) IY = (-N+1)*INCY + 1 - DO I = 1,N - ZY(IY) = ZY(IY) + ZA*ZX(IX) - IX = IX + INCX - IY = IY + INCY - END DO - END IF -* - RETURN -* -* End of ZAXPY -* - END diff --git a/lib/linalg/zcopy.cpp b/lib/linalg/zcopy.cpp new file mode 100644 index 0000000000..4ec6ae0b78 --- /dev/null +++ b/lib/linalg/zcopy.cpp @@ -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 diff --git a/lib/linalg/zcopy.f b/lib/linalg/zcopy.f deleted file mode 100644 index 1efcdb6b0f..0000000000 --- a/lib/linalg/zcopy.f +++ /dev/null @@ -1,125 +0,0 @@ -*> \brief \b ZCOPY -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE ZCOPY(N,ZX,INCX,ZY,INCY) -* -* .. Scalar Arguments .. -* INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. -* COMPLEX*16 ZX(*),ZY(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZCOPY copies a vector, x, to a vector, y. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> number of elements in input vector(s) -*> \endverbatim -*> -*> \param[in] ZX -*> \verbatim -*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> storage spacing between elements of ZX -*> \endverbatim -*> -*> \param[out] ZY -*> \verbatim -*> ZY is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> storage spacing between elements of ZY -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16_blas_level1 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> jack dongarra, linpack, 4/11/78. -*> modified 12/3/93, array(1) declarations changed to array(*) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZCOPY(N,ZX,INCX,ZY,INCY) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - COMPLEX*16 ZX(*),ZY(*) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I,IX,IY -* .. - IF (N.LE.0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 -* - DO I = 1,N - ZY(I) = ZX(I) - END DO - ELSE -* -* code for unequal increments or equal increments -* not equal to 1 -* - IX = 1 - IY = 1 - IF (INCX.LT.0) IX = (-N+1)*INCX + 1 - IF (INCY.LT.0) IY = (-N+1)*INCY + 1 - DO I = 1,N - ZY(IY) = ZX(IX) - IX = IX + INCX - IY = IY + INCY - END DO - END IF - RETURN -* -* End of ZCOPY -* - END diff --git a/lib/linalg/zdotc.cpp b/lib/linalg/zdotc.cpp new file mode 100644 index 0000000000..0bf457ed45 --- /dev/null +++ b/lib/linalg/zdotc.cpp @@ -0,0 +1,56 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +VOID zdotc_(doublecomplex *ret_val, integer *n, doublecomplex *zx, integer *incx, doublecomplex *zy, + integer *incy) +{ + integer i__1, i__2; + doublecomplex z__1, z__2, z__3; + void d_lmp_cnjg(doublecomplex *, doublecomplex *); + 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__) { + d_lmp_cnjg(&z__3, &zx[i__]); + i__2 = i__; + z__2.r = z__3.r * zy[i__2].r - z__3.i * zy[i__2].i, + z__2.i = z__3.r * zy[i__2].i + z__3.i * zy[i__2].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__) { + d_lmp_cnjg(&z__3, &zx[ix]); + i__2 = iy; + z__2.r = z__3.r * zy[i__2].r - z__3.i * zy[i__2].i, + z__2.i = z__3.r * zy[i__2].i + z__3.i * zy[i__2].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 diff --git a/lib/linalg/zdotc.f b/lib/linalg/zdotc.f deleted file mode 100644 index bcc29e2dad..0000000000 --- a/lib/linalg/zdotc.f +++ /dev/null @@ -1,134 +0,0 @@ -*> \brief \b ZDOTC -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* COMPLEX*16 FUNCTION ZDOTC(N,ZX,INCX,ZY,INCY) -* -* .. Scalar Arguments .. -* INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. -* COMPLEX*16 ZX(*),ZY(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZDOTC forms the dot product of two complex vectors -*> ZDOTC = X^H * Y -*> -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> number of elements in input vector(s) -*> \endverbatim -*> -*> \param[in] ZX -*> \verbatim -*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> storage spacing between elements of ZX -*> \endverbatim -*> -*> \param[in] ZY -*> \verbatim -*> ZY is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> storage spacing between elements of ZY -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16_blas_level1 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> jack dongarra, 3/11/78. -*> modified 12/3/93, array(1) declarations changed to array(*) -*> \endverbatim -*> -* ===================================================================== - COMPLEX*16 FUNCTION ZDOTC(N,ZX,INCX,ZY,INCY) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - COMPLEX*16 ZX(*),ZY(*) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - COMPLEX*16 ZTEMP - INTEGER I,IX,IY -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG -* .. - ZTEMP = (0.0d0,0.0d0) - ZDOTC = (0.0d0,0.0d0) - IF (N.LE.0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 -* - DO I = 1,N - ZTEMP = ZTEMP + DCONJG(ZX(I))*ZY(I) - END DO - ELSE -* -* code for unequal increments or equal increments -* not equal to 1 -* - IX = 1 - IY = 1 - IF (INCX.LT.0) IX = (-N+1)*INCX + 1 - IF (INCY.LT.0) IY = (-N+1)*INCY + 1 - DO I = 1,N - ZTEMP = ZTEMP + DCONJG(ZX(IX))*ZY(IY) - IX = IX + INCX - IY = IY + INCY - END DO - END IF - ZDOTC = ZTEMP - RETURN -* -* End of ZDOTC -* - END diff --git a/lib/linalg/zdrot.cpp b/lib/linalg/zdrot.cpp new file mode 100644 index 0000000000..fb9cc8995f --- /dev/null +++ b/lib/linalg/zdrot.cpp @@ -0,0 +1,70 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int zdrot_(integer *n, doublecomplex *zx, integer *incx, doublecomplex *zy, integer *incy, + doublereal *c__, doublereal *s) +{ + integer i__1, i__2, i__3, i__4; + doublecomplex z__1, z__2, z__3; + integer i__, ix, iy; + doublecomplex ctemp; + --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__; + z__2.r = *c__ * zx[i__2].r, z__2.i = *c__ * zx[i__2].i; + i__3 = i__; + z__3.r = *s * zy[i__3].r, z__3.i = *s * zy[i__3].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + ctemp.r = z__1.r, ctemp.i = z__1.i; + i__2 = i__; + i__3 = i__; + z__2.r = *c__ * zy[i__3].r, z__2.i = *c__ * zy[i__3].i; + i__4 = i__; + z__3.r = *s * zx[i__4].r, z__3.i = *s * zx[i__4].i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; + zy[i__2].r = z__1.r, zy[i__2].i = z__1.i; + i__2 = i__; + zx[i__2].r = ctemp.r, zx[i__2].i = ctemp.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; + z__2.r = *c__ * zx[i__2].r, z__2.i = *c__ * zx[i__2].i; + i__3 = iy; + z__3.r = *s * zy[i__3].r, z__3.i = *s * zy[i__3].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + ctemp.r = z__1.r, ctemp.i = z__1.i; + i__2 = iy; + i__3 = iy; + z__2.r = *c__ * zy[i__3].r, z__2.i = *c__ * zy[i__3].i; + i__4 = ix; + z__3.r = *s * zx[i__4].r, z__3.i = *s * zx[i__4].i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; + zy[i__2].r = z__1.r, zy[i__2].i = z__1.i; + i__2 = ix; + zx[i__2].r = ctemp.r, zx[i__2].i = ctemp.i; + ix += *incx; + iy += *incy; + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zdrot.f b/lib/linalg/zdrot.f deleted file mode 100644 index 3145561d67..0000000000 --- a/lib/linalg/zdrot.f +++ /dev/null @@ -1,153 +0,0 @@ -*> \brief \b ZDROT -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE ZDROT( N, ZX, INCX, ZY, INCY, C, S ) -* -* .. Scalar Arguments .. -* INTEGER INCX, INCY, N -* DOUBLE PRECISION C, S -* .. -* .. Array Arguments .. -* COMPLEX*16 ZX( * ), ZY( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> Applies a plane rotation, where the cos and sin (c and s) are real -*> and the vectors cx and cy are complex. -*> jack dongarra, linpack, 3/11/78. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the order of the vectors cx and cy. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in,out] ZX -*> \verbatim -*> ZX is COMPLEX*16 array, dimension at least -*> ( 1 + ( N - 1 )*abs( INCX ) ). -*> Before entry, the incremented array ZX must contain the n -*> element vector cx. On exit, ZX is overwritten by the updated -*> vector cx. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> On entry, INCX specifies the increment for the elements of -*> ZX. INCX must not be zero. -*> \endverbatim -*> -*> \param[in,out] ZY -*> \verbatim -*> ZY is COMPLEX*16 array, dimension at least -*> ( 1 + ( N - 1 )*abs( INCY ) ). -*> Before entry, the incremented array ZY must contain the n -*> element vector cy. On exit, ZY is overwritten by the updated -*> vector cy. -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> On entry, INCY specifies the increment for the elements of -*> ZY. INCY must not be zero. -*> \endverbatim -*> -*> \param[in] C -*> \verbatim -*> C is DOUBLE PRECISION -*> On entry, C specifies the cosine, cos. -*> \endverbatim -*> -*> \param[in] S -*> \verbatim -*> S is DOUBLE PRECISION -*> On entry, S specifies the sine, sin. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16_blas_level1 -* -* ===================================================================== - SUBROUTINE ZDROT( N, ZX, INCX, ZY, INCY, C, S ) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX, INCY, N - DOUBLE PRECISION C, S -* .. -* .. Array Arguments .. - COMPLEX*16 ZX( * ), ZY( * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, IX, IY - COMPLEX*16 CTEMP -* .. -* .. Executable Statements .. -* - IF( N.LE.0 ) - $ RETURN - IF( INCX.EQ.1 .AND. INCY.EQ.1 ) THEN -* -* code for both increments equal to 1 -* - DO I = 1, N - CTEMP = C*ZX( I ) + S*ZY( I ) - ZY( I ) = C*ZY( I ) - S*ZX( I ) - ZX( I ) = CTEMP - END DO - ELSE -* -* code for unequal increments or equal increments not equal -* to 1 -* - IX = 1 - IY = 1 - IF( INCX.LT.0 ) - $ IX = ( -N+1 )*INCX + 1 - IF( INCY.LT.0 ) - $ IY = ( -N+1 )*INCY + 1 - DO I = 1, N - CTEMP = C*ZX( IX ) + S*ZY( IY ) - ZY( IY ) = C*ZY( IY ) - S*ZX( IX ) - ZX( IX ) = CTEMP - IX = IX + INCX - IY = IY + INCY - END DO - END IF - RETURN -* -* End of ZDROT -* - END diff --git a/lib/linalg/zdscal.cpp b/lib/linalg/zdscal.cpp new file mode 100644 index 0000000000..d9b2773739 --- /dev/null +++ b/lib/linalg/zdscal.cpp @@ -0,0 +1,43 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int zdscal_(integer *n, doublereal *da, doublecomplex *zx, integer *incx) +{ + integer i__1, i__2, i__3, i__4; + doublereal d__1, d__2; + doublecomplex z__1; + double d_lmp_imag(doublecomplex *); + integer i__, nincx; + --zx; + if (*n <= 0 || *incx <= 0 || *da == 1.) { + return 0; + } + if (*incx == 1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + d__1 = *da * zx[i__3].r; + d__2 = *da * d_lmp_imag(&zx[i__]); + z__1.r = d__1, z__1.i = d__2; + zx[i__2].r = z__1.r, zx[i__2].i = z__1.i; + } + } else { + nincx = *n * *incx; + i__1 = nincx; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + i__3 = i__; + i__4 = i__; + d__1 = *da * zx[i__4].r; + d__2 = *da * d_lmp_imag(&zx[i__]); + z__1.r = d__1, z__1.i = d__2; + zx[i__3].r = z__1.r, zx[i__3].i = z__1.i; + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zdscal.f b/lib/linalg/zdscal.f deleted file mode 100644 index 5a16048771..0000000000 --- a/lib/linalg/zdscal.f +++ /dev/null @@ -1,123 +0,0 @@ -*> \brief \b ZDSCAL -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE ZDSCAL(N,DA,ZX,INCX) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION DA -* INTEGER INCX,N -* .. -* .. Array Arguments .. -* COMPLEX*16 ZX(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZDSCAL scales a vector by a constant. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> number of elements in input vector(s) -*> \endverbatim -*> -*> \param[in] DA -*> \verbatim -*> DA is DOUBLE PRECISION -*> On entry, DA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in,out] ZX -*> \verbatim -*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> storage spacing between elements of ZX -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16_blas_level1 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> jack dongarra, 3/11/78. -*> modified 3/93 to return if incx .le. 0. -*> modified 12/3/93, array(1) declarations changed to array(*) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZDSCAL(N,DA,ZX,INCX) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION DA - INTEGER INCX,N -* .. -* .. Array Arguments .. - COMPLEX*16 ZX(*) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I,NINCX -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER (ONE=1.0D+0) -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, DCMPLX, DIMAG -* .. - IF (N.LE.0 .OR. INCX.LE.0 .OR. DA.EQ.ONE) RETURN - IF (INCX.EQ.1) THEN -* -* code for increment equal to 1 -* - DO I = 1,N - ZX(I) = DCMPLX(DA*DBLE(ZX(I)),DA*DIMAG(ZX(I))) - END DO - ELSE -* -* code for increment not equal to 1 -* - NINCX = N*INCX - DO I = 1,NINCX,INCX - ZX(I) = DCMPLX(DA*DBLE(ZX(I)),DA*DIMAG(ZX(I))) - END DO - END IF - RETURN -* -* End of ZDSCAL -* - END diff --git a/lib/linalg/zgemm.cpp b/lib/linalg/zgemm.cpp new file mode 100644 index 0000000000..75c72106ef --- /dev/null +++ b/lib/linalg/zgemm.cpp @@ -0,0 +1,410 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int zgemm_(char *transa, char *transb, integer *m, integer *n, integer *k, doublecomplex *alpha, + doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublecomplex *beta, + doublecomplex *c__, integer *ldc, ftnlen transa_len, ftnlen transb_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; + doublecomplex z__1, z__2, z__3, z__4; + void d_lmp_cnjg(doublecomplex *, doublecomplex *); + integer i__, j, l, info; + logical nota, notb; + doublecomplex temp; + logical conja, conjb; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + integer nrowa, nrowb; + 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; + nota = lsame_(transa, (char *)"N", (ftnlen)1, (ftnlen)1); + notb = lsame_(transb, (char *)"N", (ftnlen)1, (ftnlen)1); + conja = lsame_(transa, (char *)"C", (ftnlen)1, (ftnlen)1); + conjb = lsame_(transb, (char *)"C", (ftnlen)1, (ftnlen)1); + if (nota) { + nrowa = *m; + } else { + nrowa = *k; + } + if (notb) { + nrowb = *k; + } else { + nrowb = *n; + } + info = 0; + if (!nota && !conja && !lsame_(transa, (char *)"T", (ftnlen)1, (ftnlen)1)) { + info = 1; + } else if (!notb && !conjb && !lsame_(transb, (char *)"T", (ftnlen)1, (ftnlen)1)) { + info = 2; + } else if (*m < 0) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*k < 0) { + info = 5; + } else if (*lda < max(1, nrowa)) { + info = 8; + } else if (*ldb < max(1, nrowb)) { + info = 10; + } else if (*ldc < max(1, *m)) { + info = 13; + } + if (info != 0) { + xerbla_((char *)"ZGEMM ", &info, (ftnlen)6); + return 0; + } + if (*m == 0 || *n == 0 || + (alpha->r == 0. && alpha->i == 0. || *k == 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 (notb) { + if (nota) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (beta->r == 0. && beta->i == 0.) { + 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 if (beta->r != 1. || beta->i != 0.) { + 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; + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + i__3 = l + 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; + temp.r = z__1.r, temp.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__ + 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 (conja) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + 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 * b_dim1; + z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4].i, + z__2.i = z__3.r * b[i__4].i + z__3.i * b[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->r == 0. && beta->i == 0.) { + i__3 = i__ + j * c_dim1; + z__1.r = alpha->r * temp.r - alpha->i * temp.i, + z__1.i = alpha->r * temp.i + alpha->i * temp.r; + 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->r * temp.r - alpha->i * temp.i, + z__2.i = alpha->r * temp.i + alpha->i * temp.r; + 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; + 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__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0., temp.i = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + i__4 = l + i__ * a_dim1; + i__5 = l + j * b_dim1; + z__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5].i, + z__2.i = a[i__4].r * b[i__5].i + a[i__4].i * b[i__5].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->r == 0. && beta->i == 0.) { + i__3 = i__ + j * c_dim1; + z__1.r = alpha->r * temp.r - alpha->i * temp.i, + z__1.i = alpha->r * temp.i + alpha->i * temp.r; + 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->r * temp.r - alpha->i * temp.i, + z__2.i = alpha->r * temp.i + alpha->i * temp.r; + 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; + 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 if (nota) { + if (conjb) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (beta->r == 0. && beta->i == 0.) { + 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 if (beta->r != 1. || beta->i != 0.) { + 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; + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + d_lmp_cnjg(&z__2, &b[j + l * b_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; + temp.r = z__1.r, temp.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__ + 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 { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (beta->r == 0. && beta->i == 0.) { + 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 if (beta->r != 1. || beta->i != 0.) { + 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; + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + i__3 = j + l * 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; + temp.r = z__1.r, temp.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__ + 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 (conja) { + if (conjb) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + 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]); + d_lmp_cnjg(&z__4, &b[j + l * b_dim1]); + z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, + z__2.i = z__3.r * z__4.i + z__3.i * z__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->r == 0. && beta->i == 0.) { + i__3 = i__ + j * c_dim1; + z__1.r = alpha->r * temp.r - alpha->i * temp.i, + z__1.i = alpha->r * temp.i + alpha->i * temp.r; + 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->r * temp.r - alpha->i * temp.i, + z__2.i = alpha->r * temp.i + alpha->i * temp.r; + 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; + 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__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + 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 = j + l * b_dim1; + z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4].i, + z__2.i = z__3.r * b[i__4].i + z__3.i * b[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->r == 0. && beta->i == 0.) { + i__3 = i__ + j * c_dim1; + z__1.r = alpha->r * temp.r - alpha->i * temp.i, + z__1.i = alpha->r * temp.i + alpha->i * temp.r; + 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->r * temp.r - alpha->i * temp.i, + z__2.i = alpha->r * temp.i + alpha->i * temp.r; + 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; + 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 { + if (conjb) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0., temp.i = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + i__4 = l + i__ * a_dim1; + d_lmp_cnjg(&z__3, &b[j + l * b_dim1]); + z__2.r = a[i__4].r * z__3.r - a[i__4].i * z__3.i, + z__2.i = a[i__4].r * z__3.i + a[i__4].i * z__3.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->r == 0. && beta->i == 0.) { + i__3 = i__ + j * c_dim1; + z__1.r = alpha->r * temp.r - alpha->i * temp.i, + z__1.i = alpha->r * temp.i + alpha->i * temp.r; + 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->r * temp.r - alpha->i * temp.i, + z__2.i = alpha->r * temp.i + alpha->i * temp.r; + 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; + 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__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp.r = 0., temp.i = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + i__4 = l + i__ * a_dim1; + i__5 = j + l * b_dim1; + z__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5].i, + z__2.i = a[i__4].r * b[i__5].i + a[i__4].i * b[i__5].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->r == 0. && beta->i == 0.) { + i__3 = i__ + j * c_dim1; + z__1.r = alpha->r * temp.r - alpha->i * temp.i, + z__1.i = alpha->r * temp.i + alpha->i * temp.r; + 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->r * temp.r - alpha->i * temp.i, + z__2.i = alpha->r * temp.i + alpha->i * temp.r; + 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; + 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 diff --git a/lib/linalg/zgemm.f b/lib/linalg/zgemm.f deleted file mode 100644 index 0b712f1b73..0000000000 --- a/lib/linalg/zgemm.f +++ /dev/null @@ -1,477 +0,0 @@ -*> \brief \b ZGEMM -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* -* .. Scalar Arguments .. -* COMPLEX*16 ALPHA,BETA -* INTEGER K,LDA,LDB,LDC,M,N -* CHARACTER TRANSA,TRANSB -* .. -* .. Array Arguments .. -* COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZGEMM performs one of the matrix-matrix operations -*> -*> C := alpha*op( A )*op( B ) + beta*C, -*> -*> where op( X ) is one of -*> -*> op( X ) = X or op( X ) = X**T or op( X ) = X**H, -*> -*> alpha and beta are scalars, and A, B and C are matrices, with op( A ) -*> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] TRANSA -*> \verbatim -*> TRANSA is CHARACTER*1 -*> On entry, TRANSA specifies the form of op( A ) to be used in -*> the matrix multiplication as follows: -*> -*> TRANSA = 'N' or 'n', op( A ) = A. -*> -*> TRANSA = 'T' or 't', op( A ) = A**T. -*> -*> TRANSA = 'C' or 'c', op( A ) = A**H. -*> \endverbatim -*> -*> \param[in] TRANSB -*> \verbatim -*> TRANSB is CHARACTER*1 -*> On entry, TRANSB specifies the form of op( B ) to be used in -*> the matrix multiplication as follows: -*> -*> TRANSB = 'N' or 'n', op( B ) = B. -*> -*> TRANSB = 'T' or 't', op( B ) = B**T. -*> -*> TRANSB = 'C' or 'c', op( B ) = B**H. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> On entry, M specifies the number of rows of the matrix -*> op( A ) and of the matrix C. M must be at least zero. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the number of columns of the matrix -*> op( B ) and the number of columns of the matrix C. N must be -*> at least zero. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> On entry, K specifies the number of columns of the matrix -*> op( A ) and the number of rows of the matrix op( B ). K must -*> be at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is COMPLEX*16 -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is COMPLEX*16 array, dimension ( LDA, ka ), where ka is -*> k when TRANSA = 'N' or 'n', and is m otherwise. -*> Before entry with TRANSA = 'N' or 'n', the leading m by k -*> part of the array A must contain the matrix A, otherwise -*> the leading k by m part of the array A must contain the -*> matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. When TRANSA = 'N' or 'n' then -*> LDA must be at least max( 1, m ), otherwise LDA must be at -*> least max( 1, k ). -*> \endverbatim -*> -*> \param[in] B -*> \verbatim -*> B is COMPLEX*16 array, dimension ( LDB, kb ), where kb is -*> n when TRANSB = 'N' or 'n', and is k otherwise. -*> Before entry with TRANSB = 'N' or 'n', the leading k by n -*> part of the array B must contain the matrix B, otherwise -*> the leading n by k part of the array B must contain the -*> matrix B. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> On entry, LDB specifies the first dimension of B as declared -*> in the calling (sub) program. When TRANSB = 'N' or 'n' then -*> LDB must be at least max( 1, k ), otherwise LDB must be at -*> least max( 1, n ). -*> \endverbatim -*> -*> \param[in] BETA -*> \verbatim -*> BETA is COMPLEX*16 -*> On entry, BETA specifies the scalar beta. When BETA is -*> supplied as zero then C need not be set on input. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is COMPLEX*16 array, dimension ( LDC, N ) -*> Before entry, the leading m by n part of the array C must -*> contain the matrix C, except when beta is zero, in which -*> case C need not be set on entry. -*> On exit, the array C is overwritten by the m by n matrix -*> ( alpha*op( A )*op( B ) + beta*C ). -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> On entry, LDC specifies the first dimension of C as declared -*> in the calling (sub) program. LDC must be at least -*> max( 1, m ). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16_blas_level3 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 3 Blas routine. -*> -*> -- Written on 8-February-1989. -*> Jack Dongarra, Argonne National Laboratory. -*> Iain Duff, AERE Harwell. -*> Jeremy Du Croz, Numerical Algorithms Group Ltd. -*> Sven Hammarling, Numerical Algorithms Group Ltd. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* -* -- Reference BLAS level3 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - COMPLEX*16 ALPHA,BETA - INTEGER K,LDA,LDB,LDC,M,N - CHARACTER TRANSA,TRANSB -* .. -* .. Array Arguments .. - COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG,MAX -* .. -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I,INFO,J,L,NROWA,NROWB - LOGICAL CONJA,CONJB,NOTA,NOTB -* .. -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER (ONE= (1.0D+0,0.0D+0)) - COMPLEX*16 ZERO - PARAMETER (ZERO= (0.0D+0,0.0D+0)) -* .. -* -* Set NOTA and NOTB as true if A and B respectively are not -* conjugated or transposed, set CONJA and CONJB as true if A and -* B respectively are to be transposed but not conjugated and set -* NROWA and NROWB as the number of rows of A and B respectively. -* - NOTA = LSAME(TRANSA,'N') - NOTB = LSAME(TRANSB,'N') - CONJA = LSAME(TRANSA,'C') - CONJB = LSAME(TRANSB,'C') - IF (NOTA) THEN - NROWA = M - ELSE - NROWA = K - END IF - IF (NOTB) THEN - NROWB = K - ELSE - NROWB = N - END IF -* -* Test the input parameters. -* - INFO = 0 - IF ((.NOT.NOTA) .AND. (.NOT.CONJA) .AND. - + (.NOT.LSAME(TRANSA,'T'))) THEN - INFO = 1 - ELSE IF ((.NOT.NOTB) .AND. (.NOT.CONJB) .AND. - + (.NOT.LSAME(TRANSB,'T'))) THEN - INFO = 2 - ELSE IF (M.LT.0) THEN - INFO = 3 - ELSE IF (N.LT.0) THEN - INFO = 4 - ELSE IF (K.LT.0) THEN - INFO = 5 - ELSE IF (LDA.LT.MAX(1,NROWA)) THEN - INFO = 8 - ELSE IF (LDB.LT.MAX(1,NROWB)) THEN - INFO = 10 - ELSE IF (LDC.LT.MAX(1,M)) THEN - INFO = 13 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('ZGEMM ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((M.EQ.0) .OR. (N.EQ.0) .OR. - + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN -* -* And when alpha.eq.zero. -* - IF (ALPHA.EQ.ZERO) THEN - IF (BETA.EQ.ZERO) THEN - DO 20 J = 1,N - DO 10 I = 1,M - C(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1,N - DO 30 I = 1,M - C(I,J) = BETA*C(I,J) - 30 CONTINUE - 40 CONTINUE - END IF - RETURN - END IF -* -* Start the operations. -* - IF (NOTB) THEN - IF (NOTA) THEN -* -* Form C := alpha*A*B + beta*C. -* - DO 90 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 50 I = 1,M - C(I,J) = ZERO - 50 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 60 I = 1,M - C(I,J) = BETA*C(I,J) - 60 CONTINUE - END IF - DO 80 L = 1,K - TEMP = ALPHA*B(L,J) - DO 70 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - ELSE IF (CONJA) THEN -* -* Form C := alpha*A**H*B + beta*C. -* - DO 120 J = 1,N - DO 110 I = 1,M - TEMP = ZERO - DO 100 L = 1,K - TEMP = TEMP + DCONJG(A(L,I))*B(L,J) - 100 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 110 CONTINUE - 120 CONTINUE - ELSE -* -* Form C := alpha*A**T*B + beta*C -* - DO 150 J = 1,N - DO 140 I = 1,M - TEMP = ZERO - DO 130 L = 1,K - TEMP = TEMP + A(L,I)*B(L,J) - 130 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 140 CONTINUE - 150 CONTINUE - END IF - ELSE IF (NOTA) THEN - IF (CONJB) THEN -* -* Form C := alpha*A*B**H + beta*C. -* - DO 200 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 160 I = 1,M - C(I,J) = ZERO - 160 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 170 I = 1,M - C(I,J) = BETA*C(I,J) - 170 CONTINUE - END IF - DO 190 L = 1,K - TEMP = ALPHA*DCONJG(B(J,L)) - DO 180 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 180 CONTINUE - 190 CONTINUE - 200 CONTINUE - ELSE -* -* Form C := alpha*A*B**T + beta*C -* - DO 250 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 210 I = 1,M - C(I,J) = ZERO - 210 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 220 I = 1,M - C(I,J) = BETA*C(I,J) - 220 CONTINUE - END IF - DO 240 L = 1,K - TEMP = ALPHA*B(J,L) - DO 230 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 230 CONTINUE - 240 CONTINUE - 250 CONTINUE - END IF - ELSE IF (CONJA) THEN - IF (CONJB) THEN -* -* Form C := alpha*A**H*B**H + beta*C. -* - DO 280 J = 1,N - DO 270 I = 1,M - TEMP = ZERO - DO 260 L = 1,K - TEMP = TEMP + DCONJG(A(L,I))*DCONJG(B(J,L)) - 260 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 270 CONTINUE - 280 CONTINUE - ELSE -* -* Form C := alpha*A**H*B**T + beta*C -* - DO 310 J = 1,N - DO 300 I = 1,M - TEMP = ZERO - DO 290 L = 1,K - TEMP = TEMP + DCONJG(A(L,I))*B(J,L) - 290 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 300 CONTINUE - 310 CONTINUE - END IF - ELSE - IF (CONJB) THEN -* -* Form C := alpha*A**T*B**H + beta*C -* - DO 340 J = 1,N - DO 330 I = 1,M - TEMP = ZERO - DO 320 L = 1,K - TEMP = TEMP + A(L,I)*DCONJG(B(J,L)) - 320 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 330 CONTINUE - 340 CONTINUE - ELSE -* -* Form C := alpha*A**T*B**T + beta*C -* - DO 370 J = 1,N - DO 360 I = 1,M - TEMP = ZERO - DO 350 L = 1,K - TEMP = TEMP + A(L,I)*B(J,L) - 350 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 360 CONTINUE - 370 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZGEMM -* - END diff --git a/lib/linalg/zgemv.cpp b/lib/linalg/zgemv.cpp new file mode 100644 index 0000000000..ddf5377740 --- /dev/null +++ b/lib/linalg/zgemv.cpp @@ -0,0 +1,227 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int zgemv_(char *trans, integer *m, integer *n, doublecomplex *alpha, doublecomplex *a, + integer *lda, doublecomplex *x, integer *incx, doublecomplex *beta, doublecomplex *y, + integer *incy, ftnlen trans_len) +{ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + doublecomplex z__1, z__2, z__3; + void d_lmp_cnjg(doublecomplex *, doublecomplex *); + integer i__, j, ix, iy, jx, jy, kx, ky, info; + doublecomplex temp; + integer lenx, leny; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern int xerbla_(char *, integer *, ftnlen); + logical noconj; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + --y; + info = 0; + 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 = 1; + } else if (*m < 0) { + info = 2; + } else if (*n < 0) { + info = 3; + } else if (*lda < max(1, *m)) { + info = 6; + } else if (*incx == 0) { + info = 8; + } else if (*incy == 0) { + info = 11; + } + if (info != 0) { + xerbla_((char *)"ZGEMV ", &info, (ftnlen)6); + return 0; + } + if (*m == 0 || *n == 0 || + alpha->r == 0. && alpha->i == 0. && (beta->r == 1. && beta->i == 0.)) { + return 0; + } + noconj = lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1); + if (lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1)) { + lenx = *n; + leny = *m; + } else { + lenx = *m; + leny = *n; + } + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (lenx - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (leny - 1) * *incy; + } + if (beta->r != 1. || beta->i != 0.) { + if (*incy == 1) { + if (beta->r == 0. && beta->i == 0.) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + y[i__2].r = 0., y[i__2].i = 0.; + } + } else { + i__1 = leny; + 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 = leny; + 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 = leny; + 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_(trans, (char *)"N", (ftnlen)1, (ftnlen)1)) { + jx = kx; + if (*incy == 1) { + 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; + temp.r = z__1.r, temp.i = z__1.i; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = i__ + j * a_dim1; + z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + z__2.i = temp.r * a[i__5].i + temp.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; + } + jx += *incx; + } + } else { + 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; + temp.r = z__1.r, temp.i = z__1.i; + iy = ky; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = iy; + i__4 = iy; + i__5 = i__ + j * a_dim1; + z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + z__2.i = temp.r * a[i__5].i + temp.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; + iy += *incy; + } + jx += *incx; + } + } + } else { + jy = ky; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp.r = 0., temp.i = 0.; + if (noconj) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++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 = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + } + } else { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + d_lmp_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__3 = i__; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, + z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__3].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; + } + } + i__2 = jy; + i__3 = jy; + z__2.r = alpha->r * temp.r - alpha->i * temp.i, + z__2.i = alpha->r * temp.i + alpha->i * temp.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; + jy += *incy; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp.r = 0., temp.i = 0.; + ix = kx; + if (noconj) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++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 = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + ix += *incx; + } + } else { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + d_lmp_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__3 = ix; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, + z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__3].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; + ix += *incx; + } + } + i__2 = jy; + i__3 = jy; + z__2.r = alpha->r * temp.r - alpha->i * temp.i, + z__2.i = alpha->r * temp.i + alpha->i * temp.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; + jy += *incy; + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zgemv.f b/lib/linalg/zgemv.f deleted file mode 100644 index 2664454b94..0000000000 --- a/lib/linalg/zgemv.f +++ /dev/null @@ -1,347 +0,0 @@ -*> \brief \b ZGEMV -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE ZGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* -* .. Scalar Arguments .. -* COMPLEX*16 ALPHA,BETA -* INTEGER INCX,INCY,LDA,M,N -* CHARACTER TRANS -* .. -* .. Array Arguments .. -* COMPLEX*16 A(LDA,*),X(*),Y(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZGEMV performs one of the matrix-vector operations -*> -*> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, or -*> -*> y := alpha*A**H*x + beta*y, -*> -*> where alpha and beta are scalars, x and y are vectors and A is an -*> m by n matrix. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> On entry, TRANS specifies the operation to be performed as -*> follows: -*> -*> TRANS = 'N' or 'n' y := alpha*A*x + beta*y. -*> -*> TRANS = 'T' or 't' y := alpha*A**T*x + beta*y. -*> -*> TRANS = 'C' or 'c' y := alpha*A**H*x + beta*y. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> On entry, M specifies the number of rows of the matrix A. -*> M must be at least zero. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the number of columns of the matrix A. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is COMPLEX*16 -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is COMPLEX*16 array, dimension ( LDA, N ) -*> Before entry, the leading m by n part of the array A must -*> contain the matrix of coefficients. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. LDA must be at least -*> max( 1, m ). -*> \endverbatim -*> -*> \param[in] X -*> \verbatim -*> X is COMPLEX*16 array, dimension at least -*> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' -*> and at least -*> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. -*> Before entry, the incremented array X must contain the -*> vector x. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> On entry, INCX specifies the increment for the elements of -*> X. INCX must not be zero. -*> \endverbatim -*> -*> \param[in] BETA -*> \verbatim -*> BETA is COMPLEX*16 -*> On entry, BETA specifies the scalar beta. When BETA is -*> supplied as zero then Y need not be set on input. -*> \endverbatim -*> -*> \param[in,out] Y -*> \verbatim -*> Y is COMPLEX*16 array, dimension at least -*> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' -*> and at least -*> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. -*> Before entry with BETA non-zero, the incremented array Y -*> must contain the vector y. On exit, Y is overwritten by the -*> updated vector y. -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> On entry, INCY specifies the increment for the elements of -*> Y. INCY must not be zero. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16_blas_level2 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 2 Blas routine. -*> The vector and matrix arguments are not referenced when N = 0, or M = 0 -*> -*> -- Written on 22-October-1986. -*> Jack Dongarra, Argonne National Lab. -*> Jeremy Du Croz, Nag Central Office. -*> Sven Hammarling, Nag Central Office. -*> Richard Hanson, Sandia National Labs. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* -* -- Reference BLAS level2 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - COMPLEX*16 ALPHA,BETA - INTEGER INCX,INCY,LDA,M,N - CHARACTER TRANS -* .. -* .. Array Arguments .. - COMPLEX*16 A(LDA,*),X(*),Y(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER (ONE= (1.0D+0,0.0D+0)) - COMPLEX*16 ZERO - PARAMETER (ZERO= (0.0D+0,0.0D+0)) -* .. -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY - LOGICAL NOCONJ -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG,MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. - + .NOT.LSAME(TRANS,'C')) THEN - INFO = 1 - ELSE IF (M.LT.0) THEN - INFO = 2 - ELSE IF (N.LT.0) THEN - INFO = 3 - ELSE IF (LDA.LT.MAX(1,M)) THEN - INFO = 6 - ELSE IF (INCX.EQ.0) THEN - INFO = 8 - ELSE IF (INCY.EQ.0) THEN - INFO = 11 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('ZGEMV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((M.EQ.0) .OR. (N.EQ.0) .OR. - + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN -* - NOCONJ = LSAME(TRANS,'T') -* -* Set LENX and LENY, the lengths of the vectors x and y, and set -* up the start points in X and Y. -* - IF (LSAME(TRANS,'N')) THEN - LENX = N - LENY = M - ELSE - LENX = M - LENY = N - END IF - IF (INCX.GT.0) THEN - KX = 1 - ELSE - KX = 1 - (LENX-1)*INCX - END IF - IF (INCY.GT.0) THEN - KY = 1 - ELSE - KY = 1 - (LENY-1)*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* -* First form y := beta*y. -* - IF (BETA.NE.ONE) THEN - IF (INCY.EQ.1) THEN - IF (BETA.EQ.ZERO) THEN - DO 10 I = 1,LENY - Y(I) = ZERO - 10 CONTINUE - ELSE - DO 20 I = 1,LENY - Y(I) = BETA*Y(I) - 20 CONTINUE - END IF - ELSE - IY = KY - IF (BETA.EQ.ZERO) THEN - DO 30 I = 1,LENY - Y(IY) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40 I = 1,LENY - Y(IY) = BETA*Y(IY) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF (ALPHA.EQ.ZERO) RETURN - IF (LSAME(TRANS,'N')) THEN -* -* Form y := alpha*A*x + y. -* - JX = KX - IF (INCY.EQ.1) THEN - DO 60 J = 1,N - TEMP = ALPHA*X(JX) - DO 50 I = 1,M - Y(I) = Y(I) + TEMP*A(I,J) - 50 CONTINUE - JX = JX + INCX - 60 CONTINUE - ELSE - DO 80 J = 1,N - TEMP = ALPHA*X(JX) - IY = KY - DO 70 I = 1,M - Y(IY) = Y(IY) + TEMP*A(I,J) - IY = IY + INCY - 70 CONTINUE - JX = JX + INCX - 80 CONTINUE - END IF - ELSE -* -* Form y := alpha*A**T*x + y or y := alpha*A**H*x + y. -* - JY = KY - IF (INCX.EQ.1) THEN - DO 110 J = 1,N - TEMP = ZERO - IF (NOCONJ) THEN - DO 90 I = 1,M - TEMP = TEMP + A(I,J)*X(I) - 90 CONTINUE - ELSE - DO 100 I = 1,M - TEMP = TEMP + DCONJG(A(I,J))*X(I) - 100 CONTINUE - END IF - Y(JY) = Y(JY) + ALPHA*TEMP - JY = JY + INCY - 110 CONTINUE - ELSE - DO 140 J = 1,N - TEMP = ZERO - IX = KX - IF (NOCONJ) THEN - DO 120 I = 1,M - TEMP = TEMP + A(I,J)*X(IX) - IX = IX + INCX - 120 CONTINUE - ELSE - DO 130 I = 1,M - TEMP = TEMP + DCONJG(A(I,J))*X(IX) - IX = IX + INCX - 130 CONTINUE - END IF - Y(JY) = Y(JY) + ALPHA*TEMP - JY = JY + INCY - 140 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZGEMV -* - END diff --git a/lib/linalg/zgerc.cpp b/lib/linalg/zgerc.cpp new file mode 100644 index 0000000000..b22e3f3e6d --- /dev/null +++ b/lib/linalg/zgerc.cpp @@ -0,0 +1,99 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int zgerc_(integer *m, integer *n, doublecomplex *alpha, doublecomplex *x, integer *incx, + doublecomplex *y, integer *incy, doublecomplex *a, integer *lda) +{ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + doublecomplex z__1, z__2; + void d_lmp_cnjg(doublecomplex *, doublecomplex *); + integer i__, j, ix, jy, kx, info; + doublecomplex temp; + extern int xerbla_(char *, integer *, ftnlen); + --x; + --y; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + info = 0; + if (*m < 0) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 5; + } else if (*incy == 0) { + info = 7; + } else if (*lda < max(1, *m)) { + info = 9; + } + if (info != 0) { + xerbla_((char *)"ZGERC ", &info, (ftnlen)6); + return 0; + } + if (*m == 0 || *n == 0 || alpha->r == 0. && alpha->i == 0.) { + return 0; + } + if (*incy > 0) { + jy = 1; + } else { + jy = 1 - (*n - 1) * *incy; + } + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jy; + if (y[i__2].r != 0. || y[i__2].i != 0.) { + d_lmp_cnjg(&z__2, &y[jy]); + 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; + temp.r = z__1.r, temp.i = z__1.i; + i__2 = *m; + 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; + } + } + jy += *incy; + } + } else { + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*m - 1) * *incx; + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jy; + if (y[i__2].r != 0. || y[i__2].i != 0.) { + d_lmp_cnjg(&z__2, &y[jy]); + 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; + temp.r = z__1.r, temp.i = z__1.i; + ix = kx; + i__2 = *m; + 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; + } + } + jy += *incy; + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zgerc.f b/lib/linalg/zgerc.f deleted file mode 100644 index 2eb4349367..0000000000 --- a/lib/linalg/zgerc.f +++ /dev/null @@ -1,224 +0,0 @@ -*> \brief \b ZGERC -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE ZGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* -* .. Scalar Arguments .. -* COMPLEX*16 ALPHA -* INTEGER INCX,INCY,LDA,M,N -* .. -* .. Array Arguments .. -* COMPLEX*16 A(LDA,*),X(*),Y(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZGERC performs the rank 1 operation -*> -*> A := alpha*x*y**H + A, -*> -*> where alpha is a scalar, x is an m element vector, y is an n element -*> vector and A is an m by n matrix. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> On entry, M specifies the number of rows of the matrix A. -*> M must be at least zero. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the number of columns of the matrix A. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is COMPLEX*16 -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] X -*> \verbatim -*> X is COMPLEX*16 array, dimension at least -*> ( 1 + ( m - 1 )*abs( INCX ) ). -*> Before entry, the incremented array X must contain the m -*> element vector x. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> On entry, INCX specifies the increment for the elements of -*> X. INCX must not be zero. -*> \endverbatim -*> -*> \param[in] Y -*> \verbatim -*> Y is COMPLEX*16 array, dimension at least -*> ( 1 + ( n - 1 )*abs( INCY ) ). -*> Before entry, the incremented array Y must contain the n -*> element vector y. -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> On entry, INCY specifies the increment for the elements of -*> Y. INCY must not be zero. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is COMPLEX*16 array, dimension ( LDA, N ) -*> Before entry, the leading m by n part of the array A must -*> contain the matrix of coefficients. On exit, A is -*> overwritten by the updated matrix. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. LDA must be at least -*> max( 1, m ). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16_blas_level2 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 2 Blas routine. -*> -*> -- Written on 22-October-1986. -*> Jack Dongarra, Argonne National Lab. -*> Jeremy Du Croz, Nag Central Office. -*> Sven Hammarling, Nag Central Office. -*> Richard Hanson, Sandia National Labs. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* -* -- Reference BLAS level2 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - COMPLEX*16 ALPHA - INTEGER INCX,INCY,LDA,M,N -* .. -* .. Array Arguments .. - COMPLEX*16 A(LDA,*),X(*),Y(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER (ZERO= (0.0D+0,0.0D+0)) -* .. -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I,INFO,IX,J,JY,KX -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG,MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (M.LT.0) THEN - INFO = 1 - ELSE IF (N.LT.0) THEN - INFO = 2 - ELSE IF (INCX.EQ.0) THEN - INFO = 5 - ELSE IF (INCY.EQ.0) THEN - INFO = 7 - ELSE IF (LDA.LT.MAX(1,M)) THEN - INFO = 9 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('ZGERC ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF (INCY.GT.0) THEN - JY = 1 - ELSE - JY = 1 - (N-1)*INCY - END IF - IF (INCX.EQ.1) THEN - DO 20 J = 1,N - IF (Y(JY).NE.ZERO) THEN - TEMP = ALPHA*DCONJG(Y(JY)) - DO 10 I = 1,M - A(I,J) = A(I,J) + X(I)*TEMP - 10 CONTINUE - END IF - JY = JY + INCY - 20 CONTINUE - ELSE - IF (INCX.GT.0) THEN - KX = 1 - ELSE - KX = 1 - (M-1)*INCX - END IF - DO 40 J = 1,N - IF (Y(JY).NE.ZERO) THEN - TEMP = ALPHA*DCONJG(Y(JY)) - IX = KX - DO 30 I = 1,M - A(I,J) = A(I,J) + X(IX)*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JY = JY + INCY - 40 CONTINUE - END IF -* - RETURN -* -* End of ZGERC -* - END diff --git a/lib/linalg/zheev.cpp b/lib/linalg/zheev.cpp new file mode 100644 index 0000000000..1238239431 --- /dev/null +++ b/lib/linalg/zheev.cpp @@ -0,0 +1,146 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +static integer c_n1 = -1; +static integer c__0 = 0; +static doublereal c_b18 = 1.; +int zheev_(char *jobz, char *uplo, integer *n, doublecomplex *a, integer *lda, doublereal *w, + doublecomplex *work, integer *lwork, doublereal *rwork, integer *info, ftnlen jobz_len, + ftnlen uplo_len) +{ + integer a_dim1, a_offset, i__1, i__2; + doublereal d__1; + double sqrt(doublereal); + integer nb; + doublereal eps; + integer inde; + doublereal anrm; + integer imax; + doublereal rmin, rmax; + extern int dscal_(integer *, doublereal *, doublereal *, integer *); + doublereal sigma; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + integer iinfo; + logical lower, wantz; + extern doublereal dlamch_(char *, ftnlen); + integer iscale; + doublereal safmin; + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, + ftnlen, ftnlen); + extern int xerbla_(char *, integer *, ftnlen); + doublereal bignum; + extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *, integer *, doublereal *, + ftnlen, ftnlen); + integer indtau; + extern int dsterf_(integer *, doublereal *, doublereal *, integer *), + zlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, integer *, + doublecomplex *, integer *, integer *, ftnlen); + integer indwrk; + extern int zhetrd_(char *, integer *, doublecomplex *, integer *, doublereal *, doublereal *, + doublecomplex *, doublecomplex *, integer *, integer *, ftnlen); + integer llwork; + doublereal smlnum; + integer lwkopt; + logical lquery; + extern int zsteqr_(char *, integer *, doublereal *, doublereal *, doublecomplex *, integer *, + doublereal *, integer *, ftnlen), + zungtr_(char *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, integer *, ftnlen); + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --w; + --work; + --rwork; + wantz = lsame_(jobz, (char *)"V", (ftnlen)1, (ftnlen)1); + lower = lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1); + lquery = *lwork == -1; + *info = 0; + if (!(wantz || lsame_(jobz, (char *)"N", (ftnlen)1, (ftnlen)1))) { + *info = -1; + } else if (!(lower || lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1))) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < max(1, *n)) { + *info = -5; + } + 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 = -8; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"ZHEEV ", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + if (*n == 0) { + return 0; + } + if (*n == 1) { + i__1 = a_dim1 + 1; + w[1] = a[i__1].r; + work[1].r = 1., work[1].i = 0.; + if (wantz) { + i__1 = a_dim1 + 1; + a[i__1].r = 1., a[i__1].i = 0.; + } + return 0; + } + safmin = dlamch_((char *)"Safe minimum", (ftnlen)12); + eps = dlamch_((char *)"Precision", (ftnlen)9); + smlnum = safmin / eps; + bignum = 1. / smlnum; + rmin = sqrt(smlnum); + rmax = sqrt(bignum); + anrm = zlanhe_((char *)"M", uplo, n, &a[a_offset], lda, &rwork[1], (ftnlen)1, (ftnlen)1); + iscale = 0; + if (anrm > 0. && anrm < rmin) { + iscale = 1; + sigma = rmin / anrm; + } else if (anrm > rmax) { + iscale = 1; + sigma = rmax / anrm; + } + if (iscale == 1) { + zlascl_(uplo, &c__0, &c__0, &c_b18, &sigma, n, n, &a[a_offset], lda, info, (ftnlen)1); + } + inde = 1; + indtau = 1; + indwrk = indtau + *n; + llwork = *lwork - indwrk + 1; + zhetrd_(uplo, n, &a[a_offset], lda, &w[1], &rwork[inde], &work[indtau], &work[indwrk], &llwork, + &iinfo, (ftnlen)1); + if (!wantz) { + dsterf_(n, &w[1], &rwork[inde], info); + } else { + zungtr_(uplo, n, &a[a_offset], lda, &work[indtau], &work[indwrk], &llwork, &iinfo, + (ftnlen)1); + indwrk = inde + *n; + zsteqr_(jobz, n, &w[1], &rwork[inde], &a[a_offset], lda, &rwork[indwrk], info, (ftnlen)1); + } + if (iscale == 1) { + if (*info == 0) { + imax = *n; + } else { + imax = *info - 1; + } + d__1 = 1. / sigma; + dscal_(&imax, &d__1, &w[1], &c__1); + } + work[1].r = (doublereal)lwkopt, work[1].i = 0.; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zheev.f b/lib/linalg/zheev.f deleted file mode 100644 index 59af34a742..0000000000 --- a/lib/linalg/zheev.f +++ /dev/null @@ -1,295 +0,0 @@ -*> \brief ZHEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE matrices -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZHEEV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, -* INFO ) -* -* .. Scalar Arguments .. -* CHARACTER JOBZ, UPLO -* INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION RWORK( * ), W( * ) -* COMPLEX*16 A( LDA, * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZHEEV computes all eigenvalues and, optionally, eigenvectors of a -*> complex Hermitian matrix A. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] JOBZ -*> \verbatim -*> JOBZ is CHARACTER*1 -*> = 'N': Compute eigenvalues only; -*> = 'V': Compute eigenvalues and eigenvectors. -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A is stored; -*> = 'L': Lower triangle of A is stored. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA, N) -*> On entry, the Hermitian matrix A. If UPLO = 'U', the -*> leading N-by-N upper triangular part of A contains the -*> upper triangular part of the matrix A. If UPLO = 'L', -*> the leading N-by-N lower triangular part of A contains -*> the lower triangular part of the matrix A. -*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the -*> orthonormal eigenvectors of the matrix A. -*> If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') -*> or the upper triangle (if UPLO='U') of A, including the -*> diagonal, is destroyed. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[out] W -*> \verbatim -*> W is DOUBLE PRECISION array, dimension (N) -*> If INFO = 0, the eigenvalues in ascending order. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The length of the array WORK. LWORK >= max(1,2*N-1). -*> For optimal efficiency, LWORK >= (NB+1)*N, -*> where NB is the blocksize for ZHETRD returned by ILAENV. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal size of the WORK array, returns -*> this value as the first entry of the WORK array, and no error -*> message related to LWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] RWORK -*> \verbatim -*> RWORK is DOUBLE PRECISION array, dimension (max(1, 3*N-2)) -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> > 0: if INFO = i, the algorithm failed to converge; i -*> off-diagonal elements of an intermediate tridiagonal -*> form did not converge to zero. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16HEeigen -* -* ===================================================================== - SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, - $ INFO ) -* -* -- LAPACK driver routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER JOBZ, UPLO - INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION RWORK( * ), W( * ) - COMPLEX*16 A( LDA, * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) - COMPLEX*16 CONE - PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LOWER, LQUERY, WANTZ - INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, - $ LLWORK, LWKOPT, NB - DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, - $ SMLNUM -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, ZLANHE - EXTERNAL LSAME, ILAENV, DLAMCH, ZLANHE -* .. -* .. External Subroutines .. - EXTERNAL DSCAL, DSTERF, XERBLA, ZHETRD, ZLASCL, ZSTEQR, - $ ZUNGTR -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - WANTZ = LSAME( JOBZ, 'V' ) - LOWER = LSAME( UPLO, 'L' ) - LQUERY = ( LWORK.EQ.-1 ) -* - INFO = 0 - IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF -* - IF( INFO.EQ.0 ) THEN - NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) - LWKOPT = MAX( 1, ( NB+1 )*N ) - WORK( 1 ) = LWKOPT -* - IF( LWORK.LT.MAX( 1, 2*N-1 ) .AND. .NOT.LQUERY ) - $ INFO = -8 - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZHEEV ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) THEN - RETURN - END IF -* - IF( N.EQ.1 ) THEN - W( 1 ) = DBLE( A( 1, 1 ) ) - WORK( 1 ) = 1 - IF( WANTZ ) - $ A( 1, 1 ) = CONE - RETURN - END IF -* -* Get machine constants. -* - SAFMIN = DLAMCH( 'Safe minimum' ) - EPS = DLAMCH( 'Precision' ) - SMLNUM = SAFMIN / EPS - BIGNUM = ONE / SMLNUM - RMIN = SQRT( SMLNUM ) - RMAX = SQRT( BIGNUM ) -* -* Scale matrix to allowable range, if necessary. -* - ANRM = ZLANHE( 'M', UPLO, N, A, LDA, RWORK ) - ISCALE = 0 - IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN - ISCALE = 1 - SIGMA = RMIN / ANRM - ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 - SIGMA = RMAX / ANRM - END IF - IF( ISCALE.EQ.1 ) - $ CALL ZLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) -* -* Call ZHETRD to reduce Hermitian matrix to tridiagonal form. -* - INDE = 1 - INDTAU = 1 - INDWRK = INDTAU + N - LLWORK = LWORK - INDWRK + 1 - CALL ZHETRD( UPLO, N, A, LDA, W, RWORK( INDE ), WORK( INDTAU ), - $ WORK( INDWRK ), LLWORK, IINFO ) -* -* For eigenvalues only, call DSTERF. For eigenvectors, first call -* ZUNGTR to generate the unitary matrix, then call ZSTEQR. -* - IF( .NOT.WANTZ ) THEN - CALL DSTERF( N, W, RWORK( INDE ), INFO ) - ELSE - CALL ZUNGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ), - $ LLWORK, IINFO ) - INDWRK = INDE + N - CALL ZSTEQR( JOBZ, N, W, RWORK( INDE ), A, LDA, - $ RWORK( INDWRK ), INFO ) - END IF -* -* If matrix was scaled, then rescale eigenvalues appropriately. -* - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = N - ELSE - IMAX = INFO - 1 - END IF - CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF -* -* Set WORK(1) to optimal complex workspace size. -* - WORK( 1 ) = LWKOPT -* - RETURN -* -* End of ZHEEV -* - END diff --git a/lib/linalg/zheevd.cpp b/lib/linalg/zheevd.cpp new file mode 100644 index 0000000000..094bf2216d --- /dev/null +++ b/lib/linalg/zheevd.cpp @@ -0,0 +1,185 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +static integer c_n1 = -1; +static integer c__0 = 0; +static doublereal c_b18 = 1.; +int zheevd_(char *jobz, char *uplo, integer *n, doublecomplex *a, integer *lda, doublereal *w, + doublecomplex *work, integer *lwork, doublereal *rwork, integer *lrwork, integer *iwork, + integer *liwork, integer *info, ftnlen jobz_len, ftnlen uplo_len) +{ + integer a_dim1, a_offset, i__1, i__2; + doublereal d__1; + double sqrt(doublereal); + doublereal eps; + integer inde; + doublereal anrm; + integer imax; + doublereal rmin, rmax; + integer lopt; + extern int dscal_(integer *, doublereal *, doublereal *, integer *); + doublereal sigma; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + integer iinfo, lwmin, liopt; + logical lower; + integer llrwk, lropt; + logical wantz; + integer indwk2, llwrk2; + extern doublereal dlamch_(char *, ftnlen); + integer iscale; + doublereal safmin; + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, + ftnlen, ftnlen); + extern int xerbla_(char *, integer *, ftnlen); + doublereal bignum; + extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *, integer *, doublereal *, + ftnlen, ftnlen); + integer indtau; + extern int dsterf_(integer *, doublereal *, doublereal *, integer *), + zlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, integer *, + doublecomplex *, integer *, integer *, ftnlen), + zstedc_(char *, integer *, doublereal *, doublereal *, doublecomplex *, integer *, + doublecomplex *, integer *, doublereal *, integer *, integer *, integer *, + integer *, ftnlen); + integer indrwk, indwrk, liwmin; + extern int zhetrd_(char *, integer *, doublecomplex *, integer *, doublereal *, doublereal *, + doublecomplex *, doublecomplex *, integer *, integer *, ftnlen), + zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, + integer *, ftnlen); + integer lrwmin, llwork; + doublereal smlnum; + logical lquery; + extern int zunmtr_(char *, char *, char *, integer *, integer *, doublecomplex *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, + integer *, ftnlen, ftnlen, ftnlen); + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --w; + --work; + --rwork; + --iwork; + wantz = lsame_(jobz, (char *)"V", (ftnlen)1, (ftnlen)1); + lower = lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1); + lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1; + *info = 0; + if (!(wantz || lsame_(jobz, (char *)"N", (ftnlen)1, (ftnlen)1))) { + *info = -1; + } else if (!(lower || lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1))) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < max(1, *n)) { + *info = -5; + } + if (*info == 0) { + if (*n <= 1) { + lwmin = 1; + lrwmin = 1; + liwmin = 1; + lopt = lwmin; + lropt = lrwmin; + liopt = liwmin; + } else { + if (wantz) { + lwmin = (*n << 1) + *n * *n; + i__1 = *n; + lrwmin = *n * 5 + 1 + (i__1 * i__1 << 1); + liwmin = *n * 5 + 3; + } else { + lwmin = *n + 1; + lrwmin = *n; + liwmin = 1; + } + i__1 = lwmin, i__2 = *n + *n * ilaenv_(&c__1, (char *)"ZHETRD", uplo, n, &c_n1, &c_n1, &c_n1, + (ftnlen)6, (ftnlen)1); + lopt = max(i__1, i__2); + lropt = lrwmin; + liopt = liwmin; + } + work[1].r = (doublereal)lopt, work[1].i = 0.; + rwork[1] = (doublereal)lropt; + iwork[1] = liopt; + if (*lwork < lwmin && !lquery) { + *info = -8; + } else if (*lrwork < lrwmin && !lquery) { + *info = -10; + } else if (*liwork < liwmin && !lquery) { + *info = -12; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"ZHEEVD", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + if (*n == 0) { + return 0; + } + if (*n == 1) { + i__1 = a_dim1 + 1; + w[1] = a[i__1].r; + if (wantz) { + i__1 = a_dim1 + 1; + a[i__1].r = 1., a[i__1].i = 0.; + } + return 0; + } + safmin = dlamch_((char *)"Safe minimum", (ftnlen)12); + eps = dlamch_((char *)"Precision", (ftnlen)9); + smlnum = safmin / eps; + bignum = 1. / smlnum; + rmin = sqrt(smlnum); + rmax = sqrt(bignum); + anrm = zlanhe_((char *)"M", uplo, n, &a[a_offset], lda, &rwork[1], (ftnlen)1, (ftnlen)1); + iscale = 0; + if (anrm > 0. && anrm < rmin) { + iscale = 1; + sigma = rmin / anrm; + } else if (anrm > rmax) { + iscale = 1; + sigma = rmax / anrm; + } + if (iscale == 1) { + zlascl_(uplo, &c__0, &c__0, &c_b18, &sigma, n, n, &a[a_offset], lda, info, (ftnlen)1); + } + inde = 1; + indtau = 1; + indwrk = indtau + *n; + indrwk = inde + *n; + indwk2 = indwrk + *n * *n; + llwork = *lwork - indwrk + 1; + llwrk2 = *lwork - indwk2 + 1; + llrwk = *lrwork - indrwk + 1; + zhetrd_(uplo, n, &a[a_offset], lda, &w[1], &rwork[inde], &work[indtau], &work[indwrk], &llwork, + &iinfo, (ftnlen)1); + if (!wantz) { + dsterf_(n, &w[1], &rwork[inde], info); + } else { + zstedc_((char *)"I", n, &w[1], &rwork[inde], &work[indwrk], n, &work[indwk2], &llwrk2, + &rwork[indrwk], &llrwk, &iwork[1], liwork, info, (ftnlen)1); + zunmtr_((char *)"L", uplo, (char *)"N", n, n, &a[a_offset], lda, &work[indtau], &work[indwrk], n, + &work[indwk2], &llwrk2, &iinfo, (ftnlen)1, (ftnlen)1, (ftnlen)1); + zlacpy_((char *)"A", n, n, &work[indwrk], n, &a[a_offset], lda, (ftnlen)1); + } + if (iscale == 1) { + if (*info == 0) { + imax = *n; + } else { + imax = *info - 1; + } + d__1 = 1. / sigma; + dscal_(&imax, &d__1, &w[1], &c__1); + } + work[1].r = (doublereal)lopt, work[1].i = 0.; + rwork[1] = (doublereal)lropt; + iwork[1] = liopt; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zheevd.f b/lib/linalg/zheevd.f deleted file mode 100644 index 7f58c7f726..0000000000 --- a/lib/linalg/zheevd.f +++ /dev/null @@ -1,395 +0,0 @@ -*> \brief ZHEEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE matrices -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZHEEVD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, -* LRWORK, IWORK, LIWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER JOBZ, UPLO -* INTEGER INFO, LDA, LIWORK, LRWORK, LWORK, N -* .. -* .. Array Arguments .. -* INTEGER IWORK( * ) -* DOUBLE PRECISION RWORK( * ), W( * ) -* COMPLEX*16 A( LDA, * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZHEEVD computes all eigenvalues and, optionally, eigenvectors of a -*> complex Hermitian matrix A. If eigenvectors are desired, it uses a -*> divide and conquer algorithm. -*> -*> The divide and conquer algorithm makes very mild assumptions about -*> floating point arithmetic. It will work on machines with a guard -*> digit in add/subtract, or on those binary machines without guard -*> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or -*> Cray-2. It could conceivably fail on hexadecimal or decimal machines -*> without guard digits, but we know of none. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] JOBZ -*> \verbatim -*> JOBZ is CHARACTER*1 -*> = 'N': Compute eigenvalues only; -*> = 'V': Compute eigenvalues and eigenvectors. -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A is stored; -*> = 'L': Lower triangle of A is stored. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA, N) -*> On entry, the Hermitian matrix A. If UPLO = 'U', the -*> leading N-by-N upper triangular part of A contains the -*> upper triangular part of the matrix A. If UPLO = 'L', -*> the leading N-by-N lower triangular part of A contains -*> the lower triangular part of the matrix A. -*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the -*> orthonormal eigenvectors of the matrix A. -*> If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') -*> or the upper triangle (if UPLO='U') of A, including the -*> diagonal, is destroyed. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[out] W -*> \verbatim -*> W is DOUBLE PRECISION array, dimension (N) -*> If INFO = 0, the eigenvalues in ascending order. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The length of the array WORK. -*> If N <= 1, LWORK must be at least 1. -*> If JOBZ = 'N' and N > 1, LWORK must be at least N + 1. -*> If JOBZ = 'V' and N > 1, LWORK must be at least 2*N + N**2. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal sizes of the WORK, RWORK and -*> IWORK arrays, returns these values as the first entries of -*> the WORK, RWORK and IWORK arrays, and no error message -*> related to LWORK or LRWORK or LIWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] RWORK -*> \verbatim -*> RWORK is DOUBLE PRECISION array, -*> dimension (LRWORK) -*> On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK. -*> \endverbatim -*> -*> \param[in] LRWORK -*> \verbatim -*> LRWORK is INTEGER -*> The dimension of the array RWORK. -*> If N <= 1, LRWORK must be at least 1. -*> If JOBZ = 'N' and N > 1, LRWORK must be at least N. -*> If JOBZ = 'V' and N > 1, LRWORK must be at least -*> 1 + 5*N + 2*N**2. -*> -*> If LRWORK = -1, then a workspace query is assumed; the -*> routine only calculates the optimal sizes of the WORK, RWORK -*> and IWORK arrays, returns these values as the first entries -*> of the WORK, RWORK and IWORK arrays, and no error message -*> related to LWORK or LRWORK or LIWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) -*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. -*> \endverbatim -*> -*> \param[in] LIWORK -*> \verbatim -*> LIWORK is INTEGER -*> The dimension of the array IWORK. -*> If N <= 1, LIWORK must be at least 1. -*> If JOBZ = 'N' and N > 1, LIWORK must be at least 1. -*> If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. -*> -*> If LIWORK = -1, then a workspace query is assumed; the -*> routine only calculates the optimal sizes of the WORK, RWORK -*> and IWORK arrays, returns these values as the first entries -*> of the WORK, RWORK and IWORK arrays, and no error message -*> related to LWORK or LRWORK or LIWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> > 0: if INFO = i and JOBZ = 'N', then the algorithm failed -*> to converge; i off-diagonal elements of an intermediate -*> tridiagonal form did not converge to zero; -*> if INFO = i and JOBZ = 'V', then the algorithm failed -*> to compute an eigenvalue while working on the submatrix -*> lying in rows and columns INFO/(N+1) through -*> mod(INFO,N+1). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16HEeigen -* -*> \par Further Details: -* ===================== -*> -*> Modified description of INFO. Sven, 16 Feb 05. -* -*> \par Contributors: -* ================== -*> -*> Jeff Rutter, Computer Science Division, University of California -*> at Berkeley, USA -*> -* ===================================================================== - SUBROUTINE ZHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, - $ LRWORK, IWORK, LIWORK, INFO ) -* -* -- LAPACK driver routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER JOBZ, UPLO - INTEGER INFO, LDA, LIWORK, LRWORK, LWORK, N -* .. -* .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION RWORK( * ), W( * ) - COMPLEX*16 A( LDA, * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) - COMPLEX*16 CONE - PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LOWER, LQUERY, WANTZ - INTEGER IINFO, IMAX, INDE, INDRWK, INDTAU, INDWK2, - $ INDWRK, ISCALE, LIOPT, LIWMIN, LLRWK, LLWORK, - $ LLWRK2, LOPT, LROPT, LRWMIN, LWMIN - DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, - $ SMLNUM -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, ZLANHE - EXTERNAL LSAME, ILAENV, DLAMCH, ZLANHE -* .. -* .. External Subroutines .. - EXTERNAL DSCAL, DSTERF, XERBLA, ZHETRD, ZLACPY, ZLASCL, - $ ZSTEDC, ZUNMTR -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - WANTZ = LSAME( JOBZ, 'V' ) - LOWER = LSAME( UPLO, 'L' ) - LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) -* - INFO = 0 - IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF -* - IF( INFO.EQ.0 ) THEN - IF( N.LE.1 ) THEN - LWMIN = 1 - LRWMIN = 1 - LIWMIN = 1 - LOPT = LWMIN - LROPT = LRWMIN - LIOPT = LIWMIN - ELSE - IF( WANTZ ) THEN - LWMIN = 2*N + N*N - LRWMIN = 1 + 5*N + 2*N**2 - LIWMIN = 3 + 5*N - ELSE - LWMIN = N + 1 - LRWMIN = N - LIWMIN = 1 - END IF - LOPT = MAX( LWMIN, N + - $ N*ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) ) - LROPT = LRWMIN - LIOPT = LIWMIN - END IF - WORK( 1 ) = LOPT - RWORK( 1 ) = LROPT - IWORK( 1 ) = LIOPT -* - IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN - INFO = -8 - ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN - INFO = -10 - ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZHEEVD', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( N.EQ.1 ) THEN - W( 1 ) = DBLE( A( 1, 1 ) ) - IF( WANTZ ) - $ A( 1, 1 ) = CONE - RETURN - END IF -* -* Get machine constants. -* - SAFMIN = DLAMCH( 'Safe minimum' ) - EPS = DLAMCH( 'Precision' ) - SMLNUM = SAFMIN / EPS - BIGNUM = ONE / SMLNUM - RMIN = SQRT( SMLNUM ) - RMAX = SQRT( BIGNUM ) -* -* Scale matrix to allowable range, if necessary. -* - ANRM = ZLANHE( 'M', UPLO, N, A, LDA, RWORK ) - ISCALE = 0 - IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN - ISCALE = 1 - SIGMA = RMIN / ANRM - ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 - SIGMA = RMAX / ANRM - END IF - IF( ISCALE.EQ.1 ) - $ CALL ZLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) -* -* Call ZHETRD to reduce Hermitian matrix to tridiagonal form. -* - INDE = 1 - INDTAU = 1 - INDWRK = INDTAU + N - INDRWK = INDE + N - INDWK2 = INDWRK + N*N - LLWORK = LWORK - INDWRK + 1 - LLWRK2 = LWORK - INDWK2 + 1 - LLRWK = LRWORK - INDRWK + 1 - CALL ZHETRD( UPLO, N, A, LDA, W, RWORK( INDE ), WORK( INDTAU ), - $ WORK( INDWRK ), LLWORK, IINFO ) -* -* For eigenvalues only, call DSTERF. For eigenvectors, first call -* ZSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the -* tridiagonal matrix, then call ZUNMTR to multiply it to the -* Householder transformations represented as Householder vectors in -* A. -* - IF( .NOT.WANTZ ) THEN - CALL DSTERF( N, W, RWORK( INDE ), INFO ) - ELSE - CALL ZSTEDC( 'I', N, W, RWORK( INDE ), WORK( INDWRK ), N, - $ WORK( INDWK2 ), LLWRK2, RWORK( INDRWK ), LLRWK, - $ IWORK, LIWORK, INFO ) - CALL ZUNMTR( 'L', UPLO, 'N', N, N, A, LDA, WORK( INDTAU ), - $ WORK( INDWRK ), N, WORK( INDWK2 ), LLWRK2, IINFO ) - CALL ZLACPY( 'A', N, N, WORK( INDWRK ), N, A, LDA ) - END IF -* -* If matrix was scaled, then rescale eigenvalues appropriately. -* - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = N - ELSE - IMAX = INFO - 1 - END IF - CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF -* - WORK( 1 ) = LOPT - RWORK( 1 ) = LROPT - IWORK( 1 ) = LIOPT -* - RETURN -* -* End of ZHEEVD -* - END diff --git a/lib/linalg/zhemv.cpp b/lib/linalg/zhemv.cpp new file mode 100644 index 0000000000..566e74fab6 --- /dev/null +++ b/lib/linalg/zhemv.cpp @@ -0,0 +1,265 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int zhemv_(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; + doublereal d__1; + doublecomplex z__1, z__2, z__3, z__4; + void d_lmp_cnjg(doublecomplex *, doublecomplex *); + 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 *)"ZHEMV ", &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; + d_lmp_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__3 = i__; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, + z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__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; + } + i__2 = j; + i__3 = j; + i__4 = j + j * a_dim1; + d__1 = a[i__4].r; + z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i; + 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; + d_lmp_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__3 = ix; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, + z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__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; + ix += *incx; + iy += *incy; + } + i__2 = jy; + i__3 = jy; + i__4 = j + j * a_dim1; + d__1 = a[i__4].r; + z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i; + 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; + d__1 = a[i__4].r; + z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i; + 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; + d_lmp_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__3 = i__; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, + z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__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; + } + 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; + d__1 = a[i__4].r; + z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i; + 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; + d_lmp_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__3 = ix; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, + z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__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; + } + 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 diff --git a/lib/linalg/zhemv.f b/lib/linalg/zhemv.f deleted file mode 100644 index dad68bf25b..0000000000 --- a/lib/linalg/zhemv.f +++ /dev/null @@ -1,334 +0,0 @@ -*> \brief \b ZHEMV -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE ZHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* -* .. Scalar Arguments .. -* COMPLEX*16 ALPHA,BETA -* INTEGER INCX,INCY,LDA,N -* CHARACTER UPLO -* .. -* .. Array Arguments .. -* COMPLEX*16 A(LDA,*),X(*),Y(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZHEMV performs the matrix-vector operation -*> -*> y := alpha*A*x + beta*y, -*> -*> where alpha and beta are scalars, x and y are n element vectors and -*> A is an n by n hermitian matrix. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the upper or lower -*> triangular part of the array A is to be referenced as -*> follows: -*> -*> UPLO = 'U' or 'u' Only the upper triangular part of A -*> is to be referenced. -*> -*> UPLO = 'L' or 'l' Only the lower triangular part of A -*> is to be referenced. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the order of the matrix A. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is COMPLEX*16 -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is COMPLEX*16 array, dimension ( LDA, N ) -*> Before entry with UPLO = 'U' or 'u', the leading n by n -*> upper triangular part of the array A must contain the upper -*> triangular part of the hermitian matrix and the strictly -*> lower triangular part of A is not referenced. -*> Before entry with UPLO = 'L' or 'l', the leading n by n -*> lower triangular part of the array A must contain the lower -*> triangular part of the hermitian matrix and the strictly -*> upper triangular part of A is not referenced. -*> Note that the imaginary parts of the diagonal elements need -*> not be set and are assumed to be zero. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. LDA must be at least -*> max( 1, n ). -*> \endverbatim -*> -*> \param[in] X -*> \verbatim -*> X is COMPLEX*16 array, dimension at least -*> ( 1 + ( n - 1 )*abs( INCX ) ). -*> Before entry, the incremented array X must contain the n -*> element vector x. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> On entry, INCX specifies the increment for the elements of -*> X. INCX must not be zero. -*> \endverbatim -*> -*> \param[in] BETA -*> \verbatim -*> BETA is COMPLEX*16 -*> On entry, BETA specifies the scalar beta. When BETA is -*> supplied as zero then Y need not be set on input. -*> \endverbatim -*> -*> \param[in,out] Y -*> \verbatim -*> Y is COMPLEX*16 array, dimension at least -*> ( 1 + ( n - 1 )*abs( INCY ) ). -*> Before entry, the incremented array Y must contain the n -*> element vector y. On exit, Y is overwritten by the updated -*> vector y. -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> On entry, INCY specifies the increment for the elements of -*> Y. INCY must not be zero. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16_blas_level2 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 2 Blas routine. -*> The vector and matrix arguments are not referenced when N = 0, or M = 0 -*> -*> -- Written on 22-October-1986. -*> Jack Dongarra, Argonne National Lab. -*> Jeremy Du Croz, Nag Central Office. -*> Sven Hammarling, Nag Central Office. -*> Richard Hanson, Sandia National Labs. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) -* -* -- Reference BLAS level2 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - COMPLEX*16 ALPHA,BETA - INTEGER INCX,INCY,LDA,N - CHARACTER UPLO -* .. -* .. Array Arguments .. - COMPLEX*16 A(LDA,*),X(*),Y(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER (ONE= (1.0D+0,0.0D+0)) - COMPLEX*16 ZERO - PARAMETER (ZERO= (0.0D+0,0.0D+0)) -* .. -* .. Local Scalars .. - COMPLEX*16 TEMP1,TEMP2 - INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE,DCONJG,MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN - INFO = 1 - ELSE IF (N.LT.0) THEN - INFO = 2 - ELSE IF (LDA.LT.MAX(1,N)) THEN - INFO = 5 - ELSE IF (INCX.EQ.0) THEN - INFO = 7 - ELSE IF (INCY.EQ.0) THEN - INFO = 10 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('ZHEMV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN -* -* Set up the start points in X and Y. -* - IF (INCX.GT.0) THEN - KX = 1 - ELSE - KX = 1 - (N-1)*INCX - END IF - IF (INCY.GT.0) THEN - KY = 1 - ELSE - KY = 1 - (N-1)*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* -* First form y := beta*y. -* - IF (BETA.NE.ONE) THEN - IF (INCY.EQ.1) THEN - IF (BETA.EQ.ZERO) THEN - DO 10 I = 1,N - Y(I) = ZERO - 10 CONTINUE - ELSE - DO 20 I = 1,N - Y(I) = BETA*Y(I) - 20 CONTINUE - END IF - ELSE - IY = KY - IF (BETA.EQ.ZERO) THEN - DO 30 I = 1,N - Y(IY) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40 I = 1,N - Y(IY) = BETA*Y(IY) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF (ALPHA.EQ.ZERO) RETURN - IF (LSAME(UPLO,'U')) THEN -* -* Form y when A is stored in upper triangle. -* - IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN - DO 60 J = 1,N - TEMP1 = ALPHA*X(J) - TEMP2 = ZERO - DO 50 I = 1,J - 1 - Y(I) = Y(I) + TEMP1*A(I,J) - TEMP2 = TEMP2 + DCONJG(A(I,J))*X(I) - 50 CONTINUE - Y(J) = Y(J) + TEMP1*DBLE(A(J,J)) + ALPHA*TEMP2 - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80 J = 1,N - TEMP1 = ALPHA*X(JX) - TEMP2 = ZERO - IX = KX - IY = KY - DO 70 I = 1,J - 1 - Y(IY) = Y(IY) + TEMP1*A(I,J) - TEMP2 = TEMP2 + DCONJG(A(I,J))*X(IX) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y(JY) = Y(JY) + TEMP1*DBLE(A(J,J)) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - ELSE -* -* Form y when A is stored in lower triangle. -* - IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN - DO 100 J = 1,N - TEMP1 = ALPHA*X(J) - TEMP2 = ZERO - Y(J) = Y(J) + TEMP1*DBLE(A(J,J)) - DO 90 I = J + 1,N - Y(I) = Y(I) + TEMP1*A(I,J) - TEMP2 = TEMP2 + DCONJG(A(I,J))*X(I) - 90 CONTINUE - Y(J) = Y(J) + ALPHA*TEMP2 - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120 J = 1,N - TEMP1 = ALPHA*X(JX) - TEMP2 = ZERO - Y(JY) = Y(JY) + TEMP1*DBLE(A(J,J)) - IX = JX - IY = JY - DO 110 I = J + 1,N - IX = IX + INCX - IY = IY + INCY - Y(IY) = Y(IY) + TEMP1*A(I,J) - TEMP2 = TEMP2 + DCONJG(A(I,J))*X(IX) - 110 CONTINUE - Y(JY) = Y(JY) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZHEMV -* - END diff --git a/lib/linalg/zher2.cpp b/lib/linalg/zher2.cpp new file mode 100644 index 0000000000..d70b5f04e2 --- /dev/null +++ b/lib/linalg/zher2.cpp @@ -0,0 +1,263 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int zher2_(char *uplo, integer *n, doublecomplex *alpha, doublecomplex *x, integer *incx, + doublecomplex *y, integer *incy, doublecomplex *a, integer *lda, ftnlen uplo_len) +{ + integer a_dim1, a_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; + void d_lmp_cnjg(doublecomplex *, doublecomplex *); + 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); + --x; + --y; + 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 (*incy == 0) { + info = 7; + } else if (*lda < max(1, *n)) { + info = 9; + } + if (info != 0) { + xerbla_((char *)"ZHER2 ", &info, (ftnlen)6); + return 0; + } + if (*n == 0 || alpha->r == 0. && alpha->i == 0.) { + return 0; + } + if (*incx != 1 || *incy != 1) { + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + jx = kx; + jy = ky; + } + 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; + i__3 = j; + if (x[i__2].r != 0. || x[i__2].i != 0. || (y[i__3].r != 0. || y[i__3].i != 0.)) { + d_lmp_cnjg(&z__2, &y[j]); + 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__2 = j; + z__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + z__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2].r; + d_lmp_cnjg(&z__1, &z__2); + temp2.r = z__1.r, temp2.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__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i, + z__3.i = x[i__5].r * temp1.i + x[i__5].i * temp1.r; + z__2.r = a[i__4].r + z__3.r, z__2.i = a[i__4].i + z__3.i; + i__6 = i__; + z__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i, + z__4.i = y[i__6].r * temp2.i + y[i__6].i * temp2.r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.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__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i, + z__2.i = x[i__4].r * temp1.i + x[i__4].i * temp1.r; + i__5 = j; + z__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i, + z__3.i = y[i__5].r * temp2.i + y[i__5].i * temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + 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 { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + i__3 = jy; + if (x[i__2].r != 0. || x[i__2].i != 0. || (y[i__3].r != 0. || y[i__3].i != 0.)) { + d_lmp_cnjg(&z__2, &y[jy]); + 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__2 = jx; + z__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + z__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2].r; + d_lmp_cnjg(&z__1, &z__2); + temp2.r = z__1.r, temp2.i = z__1.i; + ix = kx; + iy = ky; + 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__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i, + z__3.i = x[i__5].r * temp1.i + x[i__5].i * temp1.r; + z__2.r = a[i__4].r + z__3.r, z__2.i = a[i__4].i + z__3.i; + i__6 = iy; + z__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i, + z__4.i = y[i__6].r * temp2.i + y[i__6].i * temp2.r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + ix += *incx; + iy += *incy; + } + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + i__4 = jx; + z__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i, + z__2.i = x[i__4].r * temp1.i + x[i__4].i * temp1.r; + i__5 = jy; + z__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i, + z__3.i = y[i__5].r * temp2.i + y[i__5].i * temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + 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; + jy += *incy; + } + } + } else { + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + i__3 = j; + if (x[i__2].r != 0. || x[i__2].i != 0. || (y[i__3].r != 0. || y[i__3].i != 0.)) { + d_lmp_cnjg(&z__2, &y[j]); + 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__2 = j; + z__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + z__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2].r; + d_lmp_cnjg(&z__1, &z__2); + temp2.r = z__1.r, temp2.i = z__1.i; + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + i__4 = j; + z__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i, + z__2.i = x[i__4].r * temp1.i + x[i__4].i * temp1.r; + i__5 = j; + z__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i, + z__3.i = y[i__5].r * temp2.i + y[i__5].i * temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + 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__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i, + z__3.i = x[i__5].r * temp1.i + x[i__5].i * temp1.r; + z__2.r = a[i__4].r + z__3.r, z__2.i = a[i__4].i + z__3.i; + i__6 = i__; + z__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i, + z__4.i = y[i__6].r * temp2.i + y[i__6].i * temp2.r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.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 { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + i__3 = jy; + if (x[i__2].r != 0. || x[i__2].i != 0. || (y[i__3].r != 0. || y[i__3].i != 0.)) { + d_lmp_cnjg(&z__2, &y[jy]); + 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__2 = jx; + z__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, + z__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2].r; + d_lmp_cnjg(&z__1, &z__2); + temp2.r = z__1.r, temp2.i = z__1.i; + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + i__4 = jx; + z__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i, + z__2.i = x[i__4].r * temp1.i + x[i__4].i * temp1.r; + i__5 = jy; + z__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i, + z__3.i = y[i__5].r * temp2.i + y[i__5].i * temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + d__1 = a[i__3].r + z__1.r; + a[i__2].r = d__1, a[i__2].i = 0.; + ix = jx; + iy = jy; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + iy += *incy; + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = ix; + z__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i, + z__3.i = x[i__5].r * temp1.i + x[i__5].i * temp1.r; + z__2.r = a[i__4].r + z__3.r, z__2.i = a[i__4].i + z__3.i; + i__6 = iy; + z__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i, + z__4.i = y[i__6].r * temp2.i + y[i__6].i * temp2.r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.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; + jy += *incy; + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zher2.f b/lib/linalg/zher2.f deleted file mode 100644 index d1f2b57ec4..0000000000 --- a/lib/linalg/zher2.f +++ /dev/null @@ -1,314 +0,0 @@ -*> \brief \b ZHER2 -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE ZHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* -* .. Scalar Arguments .. -* COMPLEX*16 ALPHA -* INTEGER INCX,INCY,LDA,N -* CHARACTER UPLO -* .. -* .. Array Arguments .. -* COMPLEX*16 A(LDA,*),X(*),Y(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZHER2 performs the hermitian rank 2 operation -*> -*> A := alpha*x*y**H + conjg( alpha )*y*x**H + A, -*> -*> where alpha is a scalar, x and y are n element vectors and A is an n -*> by n hermitian matrix. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the upper or lower -*> triangular part of the array A is to be referenced as -*> follows: -*> -*> UPLO = 'U' or 'u' Only the upper triangular part of A -*> is to be referenced. -*> -*> UPLO = 'L' or 'l' Only the lower triangular part of A -*> is to be referenced. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the order of the matrix A. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is COMPLEX*16 -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] X -*> \verbatim -*> X is COMPLEX*16 array, dimension at least -*> ( 1 + ( n - 1 )*abs( INCX ) ). -*> Before entry, the incremented array X must contain the n -*> element vector x. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> On entry, INCX specifies the increment for the elements of -*> X. INCX must not be zero. -*> \endverbatim -*> -*> \param[in] Y -*> \verbatim -*> Y is COMPLEX*16 array, dimension at least -*> ( 1 + ( n - 1 )*abs( INCY ) ). -*> Before entry, the incremented array Y must contain the n -*> element vector y. -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> On entry, INCY specifies the increment for the elements of -*> Y. INCY must not be zero. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is COMPLEX*16 array, dimension ( LDA, N ) -*> Before entry with UPLO = 'U' or 'u', the leading n by n -*> upper triangular part of the array A must contain the upper -*> triangular part of the hermitian matrix and the strictly -*> lower triangular part of A is not referenced. On exit, the -*> upper triangular part of the array A is overwritten by the -*> upper triangular part of the updated matrix. -*> Before entry with UPLO = 'L' or 'l', the leading n by n -*> lower triangular part of the array A must contain the lower -*> triangular part of the hermitian matrix and the strictly -*> upper triangular part of A is not referenced. On exit, the -*> lower triangular part of the array A is overwritten by the -*> lower triangular part of the updated matrix. -*> Note that the imaginary parts of the diagonal elements need -*> not be set, they are assumed to be zero, and on exit they -*> are set to zero. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. LDA must be at least -*> max( 1, n ). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16_blas_level2 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 2 Blas routine. -*> -*> -- Written on 22-October-1986. -*> Jack Dongarra, Argonne National Lab. -*> Jeremy Du Croz, Nag Central Office. -*> Sven Hammarling, Nag Central Office. -*> Richard Hanson, Sandia National Labs. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) -* -* -- Reference BLAS level2 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - COMPLEX*16 ALPHA - INTEGER INCX,INCY,LDA,N - CHARACTER UPLO -* .. -* .. Array Arguments .. - COMPLEX*16 A(LDA,*),X(*),Y(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER (ZERO= (0.0D+0,0.0D+0)) -* .. -* .. Local Scalars .. - COMPLEX*16 TEMP1,TEMP2 - INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE,DCONJG,MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN - INFO = 1 - ELSE IF (N.LT.0) THEN - INFO = 2 - ELSE IF (INCX.EQ.0) THEN - INFO = 5 - ELSE IF (INCY.EQ.0) THEN - INFO = 7 - ELSE IF (LDA.LT.MAX(1,N)) THEN - INFO = 9 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('ZHER2 ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN -* -* Set up the start points in X and Y if the increments are not both -* unity. -* - IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN - IF (INCX.GT.0) THEN - KX = 1 - ELSE - KX = 1 - (N-1)*INCX - END IF - IF (INCY.GT.0) THEN - KY = 1 - ELSE - KY = 1 - (N-1)*INCY - END IF - JX = KX - JY = KY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* - IF (LSAME(UPLO,'U')) THEN -* -* Form A when A is stored in the upper triangle. -* - IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN - DO 20 J = 1,N - IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN - TEMP1 = ALPHA*DCONJG(Y(J)) - TEMP2 = DCONJG(ALPHA*X(J)) - DO 10 I = 1,J - 1 - A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2 - 10 CONTINUE - A(J,J) = DBLE(A(J,J)) + - + DBLE(X(J)*TEMP1+Y(J)*TEMP2) - ELSE - A(J,J) = DBLE(A(J,J)) - END IF - 20 CONTINUE - ELSE - DO 40 J = 1,N - IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN - TEMP1 = ALPHA*DCONJG(Y(JY)) - TEMP2 = DCONJG(ALPHA*X(JX)) - IX = KX - IY = KY - DO 30 I = 1,J - 1 - A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2 - IX = IX + INCX - IY = IY + INCY - 30 CONTINUE - A(J,J) = DBLE(A(J,J)) + - + DBLE(X(JX)*TEMP1+Y(JY)*TEMP2) - ELSE - A(J,J) = DBLE(A(J,J)) - END IF - JX = JX + INCX - JY = JY + INCY - 40 CONTINUE - END IF - ELSE -* -* Form A when A is stored in the lower triangle. -* - IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN - DO 60 J = 1,N - IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN - TEMP1 = ALPHA*DCONJG(Y(J)) - TEMP2 = DCONJG(ALPHA*X(J)) - A(J,J) = DBLE(A(J,J)) + - + DBLE(X(J)*TEMP1+Y(J)*TEMP2) - DO 50 I = J + 1,N - A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2 - 50 CONTINUE - ELSE - A(J,J) = DBLE(A(J,J)) - END IF - 60 CONTINUE - ELSE - DO 80 J = 1,N - IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN - TEMP1 = ALPHA*DCONJG(Y(JY)) - TEMP2 = DCONJG(ALPHA*X(JX)) - A(J,J) = DBLE(A(J,J)) + - + DBLE(X(JX)*TEMP1+Y(JY)*TEMP2) - IX = JX - IY = JY - DO 70 I = J + 1,N - IX = IX + INCX - IY = IY + INCY - A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2 - 70 CONTINUE - ELSE - A(J,J) = DBLE(A(J,J)) - END IF - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZHER2 -* - END diff --git a/lib/linalg/zher2k.cpp b/lib/linalg/zher2k.cpp new file mode 100644 index 0000000000..c98e401dd3 --- /dev/null +++ b/lib/linalg/zher2k.cpp @@ -0,0 +1,406 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int zher2k_(char *uplo, char *trans, integer *n, integer *k, doublecomplex *alpha, doublecomplex *a, + integer *lda, doublecomplex *b, integer *ldb, doublereal *beta, doublecomplex *c__, + integer *ldc, ftnlen uplo_len, ftnlen trans_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, i__7; + doublereal d__1; + doublecomplex z__1, z__2, z__3, z__4, z__5, z__6; + void d_lmp_cnjg(doublecomplex *, doublecomplex *); + integer i__, j, l, 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_(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 (*ldb < max(1, nrowa)) { + info = 9; + } else if (*ldc < max(1, *n)) { + info = 12; + } + if (info != 0) { + xerbla_((char *)"ZHER2K", &info, (ftnlen)6); + return 0; + } + if (*n == 0 || (alpha->r == 0. && alpha->i == 0. || *k == 0) && *beta == 1.) { + return 0; + } + if (alpha->r == 0. && alpha->i == 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; + i__4 = j + l * b_dim1; + if (a[i__3].r != 0. || a[i__3].i != 0. || + (b[i__4].r != 0. || b[i__4].i != 0.)) { + d_lmp_cnjg(&z__2, &b[j + l * b_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 = j + l * a_dim1; + z__2.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, + z__2.i = alpha->r * a[i__3].i + alpha->i * a[i__3].r; + d_lmp_cnjg(&z__1, &z__2); + temp2.r = z__1.r, temp2.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__3.r = a[i__6].r * temp1.r - a[i__6].i * temp1.i, + z__3.i = a[i__6].r * temp1.i + a[i__6].i * temp1.r; + z__2.r = c__[i__5].r + z__3.r, z__2.i = c__[i__5].i + z__3.i; + i__7 = i__ + l * b_dim1; + z__4.r = b[i__7].r * temp2.r - b[i__7].i * temp2.i, + z__4.i = b[i__7].r * temp2.i + b[i__7].i * temp2.r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.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 = j + l * a_dim1; + z__2.r = a[i__5].r * temp1.r - a[i__5].i * temp1.i, + z__2.i = a[i__5].r * temp1.i + a[i__5].i * temp1.r; + i__6 = j + l * b_dim1; + z__3.r = b[i__6].r * temp2.r - b[i__6].i * temp2.i, + z__3.i = b[i__6].r * temp2.i + b[i__6].i * temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + 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 = *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; + } + 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; + i__4 = j + l * b_dim1; + if (a[i__3].r != 0. || a[i__3].i != 0. || + (b[i__4].r != 0. || b[i__4].i != 0.)) { + d_lmp_cnjg(&z__2, &b[j + l * b_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 = j + l * a_dim1; + z__2.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, + z__2.i = alpha->r * a[i__3].i + alpha->i * a[i__3].r; + d_lmp_cnjg(&z__1, &z__2); + temp2.r = z__1.r, temp2.i = z__1.i; + 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__3.r = a[i__6].r * temp1.r - a[i__6].i * temp1.i, + z__3.i = a[i__6].r * temp1.i + a[i__6].i * temp1.r; + z__2.r = c__[i__5].r + z__3.r, z__2.i = c__[i__5].i + z__3.i; + i__7 = i__ + l * b_dim1; + z__4.r = b[i__7].r * temp2.r - b[i__7].i * temp2.i, + z__4.i = b[i__7].r * temp2.i + b[i__7].i * temp2.r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.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 = j + l * a_dim1; + z__2.r = a[i__5].r * temp1.r - a[i__5].i * temp1.i, + z__2.i = a[i__5].r * temp1.i + a[i__5].i * temp1.r; + i__6 = j + l * b_dim1; + z__3.r = b[i__6].r * temp2.r - b[i__6].i * temp2.i, + z__3.i = b[i__6].r * temp2.i + b[i__6].i * temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + d__1 = c__[i__4].r + z__1.r; + c__[i__3].r = d__1, c__[i__3].i = 0.; + } + } + } + } + } else { + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + temp1.r = 0., temp1.i = 0.; + temp2.r = 0., temp2.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 * b_dim1; + z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4].i, + z__2.i = z__3.r * b[i__4].i + z__3.i * b[i__4].r; + z__1.r = temp1.r + z__2.r, z__1.i = temp1.i + z__2.i; + temp1.r = z__1.r, temp1.i = z__1.i; + d_lmp_cnjg(&z__3, &b[l + i__ * b_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 = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; + temp2.r = z__1.r, temp2.i = z__1.i; + } + if (i__ == j) { + if (*beta == 0.) { + i__3 = j + j * c_dim1; + z__2.r = alpha->r * temp1.r - alpha->i * temp1.i, + z__2.i = alpha->r * temp1.i + alpha->i * temp1.r; + d_lmp_cnjg(&z__4, alpha); + z__3.r = z__4.r * temp2.r - z__4.i * temp2.i, + z__3.i = z__4.r * temp2.i + z__4.i * temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + d__1 = z__1.r; + c__[i__3].r = d__1, c__[i__3].i = 0.; + } else { + i__3 = j + j * c_dim1; + i__4 = j + j * c_dim1; + z__2.r = alpha->r * temp1.r - alpha->i * temp1.i, + z__2.i = alpha->r * temp1.i + alpha->i * temp1.r; + d_lmp_cnjg(&z__4, alpha); + z__3.r = z__4.r * temp2.r - z__4.i * temp2.i, + z__3.i = z__4.r * temp2.i + z__4.i * temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + d__1 = *beta * c__[i__4].r + z__1.r; + c__[i__3].r = d__1, c__[i__3].i = 0.; + } + } else { + if (*beta == 0.) { + i__3 = i__ + j * c_dim1; + z__2.r = alpha->r * temp1.r - alpha->i * temp1.i, + z__2.i = alpha->r * temp1.i + alpha->i * temp1.r; + d_lmp_cnjg(&z__4, alpha); + z__3.r = z__4.r * temp2.r - z__4.i * temp2.i, + z__3.i = z__4.r * temp2.i + z__4.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 * c__[i__4].r, z__3.i = *beta * c__[i__4].i; + z__4.r = alpha->r * temp1.r - alpha->i * temp1.i, + z__4.i = alpha->r * temp1.i + alpha->i * temp1.r; + z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i; + d_lmp_cnjg(&z__6, alpha); + z__5.r = z__6.r * temp2.r - z__6.i * temp2.i, + z__5.i = z__6.r * temp2.i + z__6.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) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + temp1.r = 0., temp1.i = 0.; + temp2.r = 0., temp2.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 * b_dim1; + z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4].i, + z__2.i = z__3.r * b[i__4].i + z__3.i * b[i__4].r; + z__1.r = temp1.r + z__2.r, z__1.i = temp1.i + z__2.i; + temp1.r = z__1.r, temp1.i = z__1.i; + d_lmp_cnjg(&z__3, &b[l + i__ * b_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 = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i; + temp2.r = z__1.r, temp2.i = z__1.i; + } + if (i__ == j) { + if (*beta == 0.) { + i__3 = j + j * c_dim1; + z__2.r = alpha->r * temp1.r - alpha->i * temp1.i, + z__2.i = alpha->r * temp1.i + alpha->i * temp1.r; + d_lmp_cnjg(&z__4, alpha); + z__3.r = z__4.r * temp2.r - z__4.i * temp2.i, + z__3.i = z__4.r * temp2.i + z__4.i * temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + d__1 = z__1.r; + c__[i__3].r = d__1, c__[i__3].i = 0.; + } else { + i__3 = j + j * c_dim1; + i__4 = j + j * c_dim1; + z__2.r = alpha->r * temp1.r - alpha->i * temp1.i, + z__2.i = alpha->r * temp1.i + alpha->i * temp1.r; + d_lmp_cnjg(&z__4, alpha); + z__3.r = z__4.r * temp2.r - z__4.i * temp2.i, + z__3.i = z__4.r * temp2.i + z__4.i * temp2.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + d__1 = *beta * c__[i__4].r + z__1.r; + c__[i__3].r = d__1, c__[i__3].i = 0.; + } + } else { + if (*beta == 0.) { + i__3 = i__ + j * c_dim1; + z__2.r = alpha->r * temp1.r - alpha->i * temp1.i, + z__2.i = alpha->r * temp1.i + alpha->i * temp1.r; + d_lmp_cnjg(&z__4, alpha); + z__3.r = z__4.r * temp2.r - z__4.i * temp2.i, + z__3.i = z__4.r * temp2.i + z__4.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 * c__[i__4].r, z__3.i = *beta * c__[i__4].i; + z__4.r = alpha->r * temp1.r - alpha->i * temp1.i, + z__4.i = alpha->r * temp1.i + alpha->i * temp1.r; + z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i; + d_lmp_cnjg(&z__6, alpha); + z__5.r = z__6.r * temp2.r - z__6.i * temp2.i, + z__5.i = z__6.r * temp2.i + z__6.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; + } + } + } + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zher2k.f b/lib/linalg/zher2k.f deleted file mode 100644 index 5c75083cd5..0000000000 --- a/lib/linalg/zher2k.f +++ /dev/null @@ -1,440 +0,0 @@ -*> \brief \b ZHER2K -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE ZHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* -* .. Scalar Arguments .. -* COMPLEX*16 ALPHA -* DOUBLE PRECISION BETA -* INTEGER K,LDA,LDB,LDC,N -* CHARACTER TRANS,UPLO -* .. -* .. Array Arguments .. -* COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZHER2K performs one of the hermitian rank 2k operations -*> -*> C := alpha*A*B**H + conjg( alpha )*B*A**H + beta*C, -*> -*> or -*> -*> C := alpha*A**H*B + conjg( alpha )*B**H*A + beta*C, -*> -*> where alpha and beta are scalars with beta real, C is an n by n -*> hermitian matrix and A and B are n by k matrices in the first case -*> and k by n matrices in the second case. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the upper or lower -*> triangular part of the array C is to be referenced as -*> follows: -*> -*> UPLO = 'U' or 'u' Only the upper triangular part of C -*> is to be referenced. -*> -*> UPLO = 'L' or 'l' Only the lower triangular part of C -*> is to be referenced. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> On entry, TRANS specifies the operation to be performed as -*> follows: -*> -*> TRANS = 'N' or 'n' C := alpha*A*B**H + -*> conjg( alpha )*B*A**H + -*> beta*C. -*> -*> TRANS = 'C' or 'c' C := alpha*A**H*B + -*> conjg( alpha )*B**H*A + -*> beta*C. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the order of the matrix C. N must be -*> at least zero. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> On entry with TRANS = 'N' or 'n', K specifies the number -*> of columns of the matrices A and B, and on entry with -*> TRANS = 'C' or 'c', K specifies the number of rows of the -*> matrices A and B. K must be at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is COMPLEX*16 . -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is COMPLEX*16 array, dimension ( LDA, ka ), where ka is -*> k when TRANS = 'N' or 'n', and is n otherwise. -*> Before entry with TRANS = 'N' or 'n', the leading n by k -*> part of the array A must contain the matrix A, otherwise -*> the leading k by n part of the array A must contain the -*> matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. When TRANS = 'N' or 'n' -*> then LDA must be at least max( 1, n ), otherwise LDA must -*> be at least max( 1, k ). -*> \endverbatim -*> -*> \param[in] B -*> \verbatim -*> B is COMPLEX*16 array, dimension ( LDB, kb ), where kb is -*> k when TRANS = 'N' or 'n', and is n otherwise. -*> Before entry with TRANS = 'N' or 'n', the leading n by k -*> part of the array B must contain the matrix B, otherwise -*> the leading k by n part of the array B must contain the -*> matrix B. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> On entry, LDB specifies the first dimension of B as declared -*> in the calling (sub) program. When TRANS = 'N' or 'n' -*> then LDB must be at least max( 1, n ), otherwise LDB must -*> be at least max( 1, k ). -*> Unchanged on exit. -*> \endverbatim -*> -*> \param[in] BETA -*> \verbatim -*> BETA is DOUBLE PRECISION . -*> On entry, BETA specifies the scalar beta. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is COMPLEX*16 array, dimension ( LDC, N ) -*> Before entry with UPLO = 'U' or 'u', the leading n by n -*> upper triangular part of the array C must contain the upper -*> triangular part of the hermitian matrix and the strictly -*> lower triangular part of C is not referenced. On exit, the -*> upper triangular part of the array C is overwritten by the -*> upper triangular part of the updated matrix. -*> Before entry with UPLO = 'L' or 'l', the leading n by n -*> lower triangular part of the array C must contain the lower -*> triangular part of the hermitian matrix and the strictly -*> upper triangular part of C is not referenced. On exit, the -*> lower triangular part of the array C is overwritten by the -*> lower triangular part of the updated matrix. -*> Note that the imaginary parts of the diagonal elements need -*> not be set, they are assumed to be zero, and on exit they -*> are set to zero. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> On entry, LDC specifies the first dimension of C as declared -*> in the calling (sub) program. LDC must be at least -*> max( 1, n ). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16_blas_level3 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 3 Blas routine. -*> -*> -- Written on 8-February-1989. -*> Jack Dongarra, Argonne National Laboratory. -*> Iain Duff, AERE Harwell. -*> Jeremy Du Croz, Numerical Algorithms Group Ltd. -*> Sven Hammarling, Numerical Algorithms Group Ltd. -*> -*> -- Modified 8-Nov-93 to set C(J,J) to DBLE( C(J,J) ) when BETA = 1. -*> Ed Anderson, Cray Research Inc. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* -* -- Reference BLAS level3 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - COMPLEX*16 ALPHA - DOUBLE PRECISION BETA - INTEGER K,LDA,LDB,LDC,N - CHARACTER TRANS,UPLO -* .. -* .. Array Arguments .. - COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE,DCONJG,MAX -* .. -* .. Local Scalars .. - COMPLEX*16 TEMP1,TEMP2 - INTEGER I,INFO,J,L,NROWA - LOGICAL UPPER -* .. -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER (ONE=1.0D+0) - COMPLEX*16 ZERO - PARAMETER (ZERO= (0.0D+0,0.0D+0)) -* .. -* -* Test the input parameters. -* - IF (LSAME(TRANS,'N')) THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME(UPLO,'U') -* - INFO = 0 - IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN - INFO = 1 - ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND. - + (.NOT.LSAME(TRANS,'C'))) THEN - INFO = 2 - ELSE IF (N.LT.0) THEN - INFO = 3 - ELSE IF (K.LT.0) THEN - INFO = 4 - ELSE IF (LDA.LT.MAX(1,NROWA)) THEN - INFO = 7 - ELSE IF (LDB.LT.MAX(1,NROWA)) THEN - INFO = 9 - ELSE IF (LDC.LT.MAX(1,N)) THEN - INFO = 12 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('ZHER2K',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR. - + (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN -* -* And when alpha.eq.zero. -* - IF (ALPHA.EQ.ZERO) THEN - IF (UPPER) THEN - IF (BETA.EQ.DBLE(ZERO)) THEN - DO 20 J = 1,N - DO 10 I = 1,J - C(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1,N - DO 30 I = 1,J - 1 - C(I,J) = BETA*C(I,J) - 30 CONTINUE - C(J,J) = BETA*DBLE(C(J,J)) - 40 CONTINUE - END IF - ELSE - IF (BETA.EQ.DBLE(ZERO)) THEN - DO 60 J = 1,N - DO 50 I = J,N - C(I,J) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80 J = 1,N - C(J,J) = BETA*DBLE(C(J,J)) - DO 70 I = J + 1,N - C(I,J) = BETA*C(I,J) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF (LSAME(TRANS,'N')) THEN -* -* Form C := alpha*A*B**H + conjg( alpha )*B*A**H + -* C. -* - IF (UPPER) THEN - DO 130 J = 1,N - IF (BETA.EQ.DBLE(ZERO)) THEN - DO 90 I = 1,J - C(I,J) = ZERO - 90 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 100 I = 1,J - 1 - C(I,J) = BETA*C(I,J) - 100 CONTINUE - C(J,J) = BETA*DBLE(C(J,J)) - ELSE - C(J,J) = DBLE(C(J,J)) - END IF - DO 120 L = 1,K - IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN - TEMP1 = ALPHA*DCONJG(B(J,L)) - TEMP2 = DCONJG(ALPHA*A(J,L)) - DO 110 I = 1,J - 1 - C(I,J) = C(I,J) + A(I,L)*TEMP1 + - + B(I,L)*TEMP2 - 110 CONTINUE - C(J,J) = DBLE(C(J,J)) + - + DBLE(A(J,L)*TEMP1+B(J,L)*TEMP2) - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180 J = 1,N - IF (BETA.EQ.DBLE(ZERO)) THEN - DO 140 I = J,N - C(I,J) = ZERO - 140 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 150 I = J + 1,N - C(I,J) = BETA*C(I,J) - 150 CONTINUE - C(J,J) = BETA*DBLE(C(J,J)) - ELSE - C(J,J) = DBLE(C(J,J)) - END IF - DO 170 L = 1,K - IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN - TEMP1 = ALPHA*DCONJG(B(J,L)) - TEMP2 = DCONJG(ALPHA*A(J,L)) - DO 160 I = J + 1,N - C(I,J) = C(I,J) + A(I,L)*TEMP1 + - + B(I,L)*TEMP2 - 160 CONTINUE - C(J,J) = DBLE(C(J,J)) + - + DBLE(A(J,L)*TEMP1+B(J,L)*TEMP2) - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*A**H*B + conjg( alpha )*B**H*A + -* C. -* - IF (UPPER) THEN - DO 210 J = 1,N - DO 200 I = 1,J - TEMP1 = ZERO - TEMP2 = ZERO - DO 190 L = 1,K - TEMP1 = TEMP1 + DCONJG(A(L,I))*B(L,J) - TEMP2 = TEMP2 + DCONJG(B(L,I))*A(L,J) - 190 CONTINUE - IF (I.EQ.J) THEN - IF (BETA.EQ.DBLE(ZERO)) THEN - C(J,J) = DBLE(ALPHA*TEMP1+ - + DCONJG(ALPHA)*TEMP2) - ELSE - C(J,J) = BETA*DBLE(C(J,J)) + - + DBLE(ALPHA*TEMP1+ - + DCONJG(ALPHA)*TEMP2) - END IF - ELSE - IF (BETA.EQ.DBLE(ZERO)) THEN - C(I,J) = ALPHA*TEMP1 + DCONJG(ALPHA)*TEMP2 - ELSE - C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 + - + DCONJG(ALPHA)*TEMP2 - END IF - END IF - 200 CONTINUE - 210 CONTINUE - ELSE - DO 240 J = 1,N - DO 230 I = J,N - TEMP1 = ZERO - TEMP2 = ZERO - DO 220 L = 1,K - TEMP1 = TEMP1 + DCONJG(A(L,I))*B(L,J) - TEMP2 = TEMP2 + DCONJG(B(L,I))*A(L,J) - 220 CONTINUE - IF (I.EQ.J) THEN - IF (BETA.EQ.DBLE(ZERO)) THEN - C(J,J) = DBLE(ALPHA*TEMP1+ - + DCONJG(ALPHA)*TEMP2) - ELSE - C(J,J) = BETA*DBLE(C(J,J)) + - + DBLE(ALPHA*TEMP1+ - + DCONJG(ALPHA)*TEMP2) - END IF - ELSE - IF (BETA.EQ.DBLE(ZERO)) THEN - C(I,J) = ALPHA*TEMP1 + DCONJG(ALPHA)*TEMP2 - ELSE - C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 + - + DCONJG(ALPHA)*TEMP2 - END IF - END IF - 230 CONTINUE - 240 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZHER2K -* - END diff --git a/lib/linalg/zhetd2.cpp b/lib/linalg/zhetd2.cpp new file mode 100644 index 0000000000..46ec1316e0 --- /dev/null +++ b/lib/linalg/zhetd2.cpp @@ -0,0 +1,148 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static doublecomplex c_b2 = {0., 0.}; +static integer c__1 = 1; +int zhetd2_(char *uplo, integer *n, doublecomplex *a, integer *lda, doublereal *d__, doublereal *e, + doublecomplex *tau, integer *info, ftnlen uplo_len) +{ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublereal d__1; + doublecomplex z__1, z__2, z__3, z__4; + integer i__; + doublecomplex taui; + extern int zher2_(char *, integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, ftnlen); + doublecomplex alpha; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern VOID zdotc_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, + integer *); + extern int zhemv_(char *, integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, + ftnlen); + logical upper; + extern int zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *), + xerbla_(char *, integer *, ftnlen), + zlarfg_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *); + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --d__; + --e; + --tau; + *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 *)"ZHETD2", &i__1, (ftnlen)6); + return 0; + } + if (*n <= 0) { + return 0; + } + if (upper) { + i__1 = *n + *n * a_dim1; + i__2 = *n + *n * a_dim1; + d__1 = a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + for (i__ = *n - 1; i__ >= 1; --i__) { + i__1 = i__ + (i__ + 1) * a_dim1; + alpha.r = a[i__1].r, alpha.i = a[i__1].i; + zlarfg_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &taui); + e[i__] = alpha.r; + if (taui.r != 0. || taui.i != 0.) { + i__1 = i__ + (i__ + 1) * a_dim1; + a[i__1].r = 1., a[i__1].i = 0.; + zhemv_(uplo, &i__, &taui, &a[a_offset], lda, &a[(i__ + 1) * a_dim1 + 1], &c__1, + &c_b2, &tau[1], &c__1, (ftnlen)1); + z__3.r = -.5, z__3.i = -0.; + z__2.r = z__3.r * taui.r - z__3.i * taui.i, + z__2.i = z__3.r * taui.i + z__3.i * taui.r; + zdotc_(&z__4, &i__, &tau[1], &c__1, &a[(i__ + 1) * a_dim1 + 1], &c__1); + z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, + z__1.i = z__2.r * z__4.i + z__2.i * z__4.r; + alpha.r = z__1.r, alpha.i = z__1.i; + zaxpy_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &tau[1], &c__1); + z__1.r = -1., z__1.i = -0.; + zher2_(uplo, &i__, &z__1, &a[(i__ + 1) * a_dim1 + 1], &c__1, &tau[1], &c__1, + &a[a_offset], lda, (ftnlen)1); + } else { + i__1 = i__ + i__ * a_dim1; + i__2 = i__ + i__ * a_dim1; + d__1 = a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + } + i__1 = i__ + (i__ + 1) * a_dim1; + i__2 = i__; + a[i__1].r = e[i__2], a[i__1].i = 0.; + i__1 = i__ + 1 + (i__ + 1) * a_dim1; + d__[i__ + 1] = a[i__1].r; + i__1 = i__; + tau[i__1].r = taui.r, tau[i__1].i = taui.i; + } + i__1 = a_dim1 + 1; + d__[1] = a[i__1].r; + } else { + i__1 = a_dim1 + 1; + i__2 = a_dim1 + 1; + d__1 = a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + 1 + i__ * a_dim1; + alpha.r = a[i__2].r, alpha.i = a[i__2].i; + i__2 = *n - i__; + i__3 = i__ + 2; + zlarfg_(&i__2, &alpha, &a[min(i__3, *n) + i__ * a_dim1], &c__1, &taui); + e[i__] = alpha.r; + if (taui.r != 0. || taui.i != 0.) { + i__2 = i__ + 1 + i__ * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + i__2 = *n - i__; + zhemv_(uplo, &i__2, &taui, &a[i__ + 1 + (i__ + 1) * a_dim1], lda, + &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b2, &tau[i__], &c__1, (ftnlen)1); + z__3.r = -.5, z__3.i = -0.; + z__2.r = z__3.r * taui.r - z__3.i * taui.i, + z__2.i = z__3.r * taui.i + z__3.i * taui.r; + i__2 = *n - i__; + zdotc_(&z__4, &i__2, &tau[i__], &c__1, &a[i__ + 1 + i__ * a_dim1], &c__1); + z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, + z__1.i = z__2.r * z__4.i + z__2.i * z__4.r; + alpha.r = z__1.r, alpha.i = z__1.i; + i__2 = *n - i__; + zaxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[i__], &c__1); + i__2 = *n - i__; + z__1.r = -1., z__1.i = -0.; + zher2_(uplo, &i__2, &z__1, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[i__], &c__1, + &a[i__ + 1 + (i__ + 1) * a_dim1], lda, (ftnlen)1); + } else { + i__2 = i__ + 1 + (i__ + 1) * a_dim1; + i__3 = i__ + 1 + (i__ + 1) * a_dim1; + d__1 = a[i__3].r; + a[i__2].r = d__1, a[i__2].i = 0.; + } + i__2 = i__ + 1 + i__ * a_dim1; + i__3 = i__; + a[i__2].r = e[i__3], a[i__2].i = 0.; + i__2 = i__ + i__ * a_dim1; + d__[i__] = a[i__2].r; + i__2 = i__; + tau[i__2].r = taui.r, tau[i__2].i = taui.i; + } + i__1 = *n + *n * a_dim1; + d__[*n] = a[i__1].r; + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zhetd2.f b/lib/linalg/zhetd2.f deleted file mode 100644 index a6d900b7c7..0000000000 --- a/lib/linalg/zhetd2.f +++ /dev/null @@ -1,331 +0,0 @@ -*> \brief \b ZHETD2 reduces a Hermitian matrix to real symmetric tridiagonal form by an unitary similarity transformation (unblocked algorithm). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZHETD2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION D( * ), E( * ) -* COMPLEX*16 A( LDA, * ), TAU( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZHETD2 reduces a complex Hermitian matrix A to real symmetric -*> tridiagonal form T by a unitary similarity transformation: -*> Q**H * A * Q = T. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> Specifies whether the upper or lower triangular part of the -*> Hermitian matrix A is stored: -*> = 'U': Upper triangular -*> = 'L': Lower triangular -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,N) -*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading -*> n-by-n upper triangular part of A contains the upper -*> triangular part of the matrix A, and the strictly lower -*> triangular part of A is not referenced. If UPLO = 'L', the -*> leading n-by-n lower triangular part of A contains the lower -*> triangular part of the matrix A, and the strictly upper -*> triangular part of A is not referenced. -*> On exit, if UPLO = 'U', the diagonal and first superdiagonal -*> of A are overwritten by the corresponding elements of the -*> tridiagonal matrix T, and the elements above the first -*> superdiagonal, with the array TAU, represent the unitary -*> matrix Q as a product of elementary reflectors; if UPLO -*> = 'L', the diagonal and first subdiagonal of A are over- -*> written by the corresponding elements of the tridiagonal -*> matrix T, and the elements below the first subdiagonal, with -*> the array TAU, represent the unitary matrix Q as a product -*> of elementary reflectors. See Further Details. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> The diagonal elements of the tridiagonal matrix T: -*> D(i) = A(i,i). -*> \endverbatim -*> -*> \param[out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N-1) -*> The off-diagonal elements of the tridiagonal matrix T: -*> E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. -*> \endverbatim -*> -*> \param[out] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension (N-1) -*> The scalar factors of the elementary reflectors (see Further -*> Details). -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16HEcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> If UPLO = 'U', the matrix Q is represented as a product of elementary -*> reflectors -*> -*> Q = H(n-1) . . . H(2) H(1). -*> -*> Each H(i) has the form -*> -*> H(i) = I - tau * v * v**H -*> -*> where tau is a complex scalar, and v is a complex vector with -*> v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in -*> A(1:i-1,i+1), and tau in TAU(i). -*> -*> If UPLO = 'L', the matrix Q is represented as a product of elementary -*> reflectors -*> -*> Q = H(1) H(2) . . . H(n-1). -*> -*> Each H(i) has the form -*> -*> H(i) = I - tau * v * v**H -*> -*> where tau is a complex scalar, and v is a complex vector with -*> v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), -*> and tau in TAU(i). -*> -*> The contents of A on exit are illustrated by the following examples -*> with n = 5: -*> -*> if UPLO = 'U': if UPLO = 'L': -*> -*> ( d e v2 v3 v4 ) ( d ) -*> ( d e v3 v4 ) ( e d ) -*> ( d e v4 ) ( v1 e d ) -*> ( d e ) ( v1 v2 e d ) -*> ( d ) ( v1 v2 v3 e d ) -*> -*> where d and e denote diagonal and off-diagonal elements of T, and vi -*> denotes an element of the vector defining H(i). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), E( * ) - COMPLEX*16 A( LDA, * ), TAU( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE, ZERO, HALF - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ), - $ HALF = ( 0.5D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I - COMPLEX*16 ALPHA, TAUI -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZAXPY, ZHEMV, ZHER2, ZLARFG -* .. -* .. External Functions .. - LOGICAL LSAME - COMPLEX*16 ZDOTC - EXTERNAL LSAME, ZDOTC -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - UPPER = LSAME( UPLO, 'U') - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZHETD2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Reduce the upper triangle of A -* - A( N, N ) = DBLE( A( N, N ) ) - DO 10 I = N - 1, 1, -1 -* -* Generate elementary reflector H(i) = I - tau * v * v**H -* to annihilate A(1:i-1,i+1) -* - ALPHA = A( I, I+1 ) - CALL ZLARFG( I, ALPHA, A( 1, I+1 ), 1, TAUI ) - E( I ) = DBLE( ALPHA ) -* - IF( TAUI.NE.ZERO ) THEN -* -* Apply H(i) from both sides to A(1:i,1:i) -* - A( I, I+1 ) = ONE -* -* Compute x := tau * A * v storing x in TAU(1:i) -* - CALL ZHEMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO, - $ TAU, 1 ) -* -* Compute w := x - 1/2 * tau * (x**H * v) * v -* - ALPHA = -HALF*TAUI*ZDOTC( I, TAU, 1, A( 1, I+1 ), 1 ) - CALL ZAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 ) -* -* Apply the transformation as a rank-2 update: -* A := A - v * w**H - w * v**H -* - CALL ZHER2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A, - $ LDA ) -* - ELSE - A( I, I ) = DBLE( A( I, I ) ) - END IF - A( I, I+1 ) = E( I ) - D( I+1 ) = DBLE( A( I+1, I+1 ) ) - TAU( I ) = TAUI - 10 CONTINUE - D( 1 ) = DBLE( A( 1, 1 ) ) - ELSE -* -* Reduce the lower triangle of A -* - A( 1, 1 ) = DBLE( A( 1, 1 ) ) - DO 20 I = 1, N - 1 -* -* Generate elementary reflector H(i) = I - tau * v * v**H -* to annihilate A(i+2:n,i) -* - ALPHA = A( I+1, I ) - CALL ZLARFG( N-I, ALPHA, A( MIN( I+2, N ), I ), 1, TAUI ) - E( I ) = DBLE( ALPHA ) -* - IF( TAUI.NE.ZERO ) THEN -* -* Apply H(i) from both sides to A(i+1:n,i+1:n) -* - A( I+1, I ) = ONE -* -* Compute x := tau * A * v storing y in TAU(i:n-1) -* - CALL ZHEMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA, - $ A( I+1, I ), 1, ZERO, TAU( I ), 1 ) -* -* Compute w := x - 1/2 * tau * (x**H * v) * v -* - ALPHA = -HALF*TAUI*ZDOTC( N-I, TAU( I ), 1, A( I+1, I ), - $ 1 ) - CALL ZAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 ) -* -* Apply the transformation as a rank-2 update: -* A := A - v * w**H - w * v**H -* - CALL ZHER2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1, - $ A( I+1, I+1 ), LDA ) -* - ELSE - A( I+1, I+1 ) = DBLE( A( I+1, I+1 ) ) - END IF - A( I+1, I ) = E( I ) - D( I ) = DBLE( A( I, I ) ) - TAU( I ) = TAUI - 20 CONTINUE - D( N ) = DBLE( A( N, N ) ) - END IF -* - RETURN -* -* End of ZHETD2 -* - END diff --git a/lib/linalg/zhetrd.cpp b/lib/linalg/zhetrd.cpp new file mode 100644 index 0000000000..94df1e8159 --- /dev/null +++ b/lib/linalg/zhetrd.cpp @@ -0,0 +1,142 @@ +#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 doublereal c_b23 = 1.; +int zhetrd_(char *uplo, integer *n, doublecomplex *a, integer *lda, doublereal *d__, doublereal *e, + doublecomplex *tau, doublecomplex *work, integer *lwork, integer *info, ftnlen uplo_len) +{ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + doublecomplex z__1; + integer i__, j, nb, kk, nx, iws; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + integer nbmin, iinfo; + logical upper; + extern int zhetd2_(char *, integer *, doublecomplex *, integer *, doublereal *, doublereal *, + doublecomplex *, 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); + extern int zlatrd_(char *, integer *, integer *, doublecomplex *, integer *, doublereal *, + doublecomplex *, doublecomplex *, integer *, ftnlen); + integer ldwork, lwkopt; + logical lquery; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --d__; + --e; + --tau; + --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 = -9; + } + if (*info == 0) { + nb = ilaenv_(&c__1, (char *)"ZHETRD", 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 *)"ZHETRD", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + if (*n == 0) { + work[1].r = 1., work[1].i = 0.; + return 0; + } + nx = *n; + iws = 1; + if (nb > 1 && nb < *n) { + i__1 = nb, + i__2 = ilaenv_(&c__3, (char *)"ZHETRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); + nx = max(i__1, i__2); + if (nx < *n) { + ldwork = *n; + iws = ldwork * nb; + if (*lwork < iws) { + i__1 = *lwork / ldwork; + nb = max(i__1, 1); + nbmin = + ilaenv_(&c__2, (char *)"ZHETRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); + if (nb < nbmin) { + nx = *n; + } + } + } else { + nx = *n; + } + } else { + nb = 1; + } + if (upper) { + kk = *n - (*n - nx + nb - 1) / nb * nb; + i__1 = kk + 1; + i__2 = -nb; + for (i__ = *n - nb + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + i__3 = i__ + nb - 1; + zlatrd_(uplo, &i__3, &nb, &a[a_offset], lda, &e[1], &tau[1], &work[1], &ldwork, + (ftnlen)1); + i__3 = i__ - 1; + z__1.r = -1., z__1.i = -0.; + zher2k_(uplo, (char *)"No transpose", &i__3, &nb, &z__1, &a[i__ * a_dim1 + 1], lda, &work[1], + &ldwork, &c_b23, &a[a_offset], lda, (ftnlen)1, (ftnlen)12); + i__3 = i__ + nb - 1; + for (j = i__; j <= i__3; ++j) { + i__4 = j - 1 + j * a_dim1; + i__5 = j - 1; + a[i__4].r = e[i__5], a[i__4].i = 0.; + i__4 = j + j * a_dim1; + d__[j] = a[i__4].r; + } + } + zhetd2_(uplo, &kk, &a[a_offset], lda, &d__[1], &e[1], &tau[1], &iinfo, (ftnlen)1); + } else { + i__2 = *n - nx; + i__1 = nb; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { + i__3 = *n - i__ + 1; + zlatrd_(uplo, &i__3, &nb, &a[i__ + i__ * a_dim1], lda, &e[i__], &tau[i__], &work[1], + &ldwork, (ftnlen)1); + i__3 = *n - i__ - nb + 1; + z__1.r = -1., z__1.i = -0.; + zher2k_(uplo, (char *)"No transpose", &i__3, &nb, &z__1, &a[i__ + nb + i__ * a_dim1], lda, + &work[nb + 1], &ldwork, &c_b23, &a[i__ + nb + (i__ + nb) * a_dim1], lda, + (ftnlen)1, (ftnlen)12); + i__3 = i__ + nb - 1; + for (j = i__; j <= i__3; ++j) { + i__4 = j + 1 + j * a_dim1; + i__5 = j; + a[i__4].r = e[i__5], a[i__4].i = 0.; + i__4 = j + j * a_dim1; + d__[j] = a[i__4].r; + } + } + i__1 = *n - i__ + 1; + zhetd2_(uplo, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], &tau[i__], &iinfo, + (ftnlen)1); + } + work[1].r = (doublereal)lwkopt, work[1].i = 0.; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zhetrd.f b/lib/linalg/zhetrd.f deleted file mode 100644 index 5b7d6546cc..0000000000 --- a/lib/linalg/zhetrd.f +++ /dev/null @@ -1,375 +0,0 @@ -*> \brief \b ZHETRD -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZHETRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION D( * ), E( * ) -* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZHETRD reduces a complex Hermitian matrix A to real symmetric -*> tridiagonal form T by a unitary similarity transformation: -*> Q**H * A * Q = T. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A is stored; -*> = 'L': Lower triangle of A is stored. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,N) -*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading -*> N-by-N upper triangular part of A contains the upper -*> triangular part of the matrix A, and the strictly lower -*> triangular part of A is not referenced. If UPLO = 'L', the -*> leading N-by-N lower triangular part of A contains the lower -*> triangular part of the matrix A, and the strictly upper -*> triangular part of A is not referenced. -*> On exit, if UPLO = 'U', the diagonal and first superdiagonal -*> of A are overwritten by the corresponding elements of the -*> tridiagonal matrix T, and the elements above the first -*> superdiagonal, with the array TAU, represent the unitary -*> matrix Q as a product of elementary reflectors; if UPLO -*> = 'L', the diagonal and first subdiagonal of A are over- -*> written by the corresponding elements of the tridiagonal -*> matrix T, and the elements below the first subdiagonal, with -*> the array TAU, represent the unitary matrix Q as a product -*> of elementary reflectors. See Further Details. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> The diagonal elements of the tridiagonal matrix T: -*> D(i) = A(i,i). -*> \endverbatim -*> -*> \param[out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N-1) -*> The off-diagonal elements of the tridiagonal matrix T: -*> E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. -*> \endverbatim -*> -*> \param[out] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension (N-1) -*> The scalar factors of the elementary reflectors (see Further -*> Details). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. LWORK >= 1. -*> For optimum performance LWORK >= N*NB, where NB is the -*> optimal blocksize. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal size of the WORK array, returns -*> this value as the first entry of the WORK array, and no error -*> message related to LWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16HEcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> If UPLO = 'U', the matrix Q is represented as a product of elementary -*> reflectors -*> -*> Q = H(n-1) . . . H(2) H(1). -*> -*> Each H(i) has the form -*> -*> H(i) = I - tau * v * v**H -*> -*> where tau is a complex scalar, and v is a complex vector with -*> v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in -*> A(1:i-1,i+1), and tau in TAU(i). -*> -*> If UPLO = 'L', the matrix Q is represented as a product of elementary -*> reflectors -*> -*> Q = H(1) H(2) . . . H(n-1). -*> -*> Each H(i) has the form -*> -*> H(i) = I - tau * v * v**H -*> -*> where tau is a complex scalar, and v is a complex vector with -*> v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), -*> and tau in TAU(i). -*> -*> The contents of A on exit are illustrated by the following examples -*> with n = 5: -*> -*> if UPLO = 'U': if UPLO = 'L': -*> -*> ( d e v2 v3 v4 ) ( d ) -*> ( d e v3 v4 ) ( e d ) -*> ( d e v4 ) ( v1 e d ) -*> ( d e ) ( v1 v2 e d ) -*> ( d ) ( v1 v2 v3 e d ) -*> -*> where d and e denote diagonal and off-diagonal elements of T, and vi -*> denotes an element of the vector defining H(i). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), E( * ) - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) - COMPLEX*16 CONE - PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY, UPPER - INTEGER I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB, - $ NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZHER2K, ZHETD2, ZLATRD -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - LQUERY = ( LWORK.EQ.-1 ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN - INFO = -9 - END IF -* - IF( INFO.EQ.0 ) THEN -* -* Determine the block size. -* - NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) - LWKOPT = N*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZHETRD', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NX = N - IWS = 1 - IF( NB.GT.1 .AND. NB.LT.N ) THEN -* -* Determine when to cross over from blocked to unblocked code -* (last block is always handled by unblocked code). -* - NX = MAX( NB, ILAENV( 3, 'ZHETRD', UPLO, N, -1, -1, -1 ) ) - IF( NX.LT.N ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: determine the -* minimum value of NB, and reduce NB or force use of -* unblocked code by setting NX = N. -* - NB = MAX( LWORK / LDWORK, 1 ) - NBMIN = ILAENV( 2, 'ZHETRD', UPLO, N, -1, -1, -1 ) - IF( NB.LT.NBMIN ) - $ NX = N - END IF - ELSE - NX = N - END IF - ELSE - NB = 1 - END IF -* - IF( UPPER ) THEN -* -* Reduce the upper triangle of A. -* Columns 1:kk are handled by the unblocked method. -* - KK = N - ( ( N-NX+NB-1 ) / NB )*NB - DO 20 I = N - NB + 1, KK + 1, -NB -* -* Reduce columns i:i+nb-1 to tridiagonal form and form the -* matrix W which is needed to update the unreduced part of -* the matrix -* - CALL ZLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK, - $ LDWORK ) -* -* Update the unreduced submatrix A(1:i-1,1:i-1), using an -* update of the form: A := A - V*W**H - W*V**H -* - CALL ZHER2K( UPLO, 'No transpose', I-1, NB, -CONE, - $ A( 1, I ), LDA, WORK, LDWORK, ONE, A, LDA ) -* -* Copy superdiagonal elements back into A, and diagonal -* elements into D -* - DO 10 J = I, I + NB - 1 - A( J-1, J ) = E( J-1 ) - D( J ) = DBLE( A( J, J ) ) - 10 CONTINUE - 20 CONTINUE -* -* Use unblocked code to reduce the last or only block -* - CALL ZHETD2( UPLO, KK, A, LDA, D, E, TAU, IINFO ) - ELSE -* -* Reduce the lower triangle of A -* - DO 40 I = 1, N - NX, NB -* -* Reduce columns i:i+nb-1 to tridiagonal form and form the -* matrix W which is needed to update the unreduced part of -* the matrix -* - CALL ZLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ), - $ TAU( I ), WORK, LDWORK ) -* -* Update the unreduced submatrix A(i+nb:n,i+nb:n), using -* an update of the form: A := A - V*W**H - W*V**H -* - CALL ZHER2K( UPLO, 'No transpose', N-I-NB+1, NB, -CONE, - $ A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE, - $ A( I+NB, I+NB ), LDA ) -* -* Copy subdiagonal elements back into A, and diagonal -* elements into D -* - DO 30 J = I, I + NB - 1 - A( J+1, J ) = E( J ) - D( J ) = DBLE( A( J, J ) ) - 30 CONTINUE - 40 CONTINUE -* -* Use unblocked code to reduce the last or only block -* - CALL ZHETD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ), - $ TAU( I ), IINFO ) - END IF -* - WORK( 1 ) = LWKOPT - RETURN -* -* End of ZHETRD -* - END diff --git a/lib/linalg/zhpr.cpp b/lib/linalg/zhpr.cpp new file mode 100644 index 0000000000..9e1e441830 --- /dev/null +++ b/lib/linalg/zhpr.cpp @@ -0,0 +1,192 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int zhpr_(char *uplo, integer *n, doublereal *alpha, doublecomplex *x, integer *incx, + doublecomplex *ap, ftnlen uplo_len) +{ + integer 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, k, kk, ix, jx, kx, info; + doublecomplex temp; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern int xerbla_(char *, integer *, ftnlen); + --ap; + --x; + 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; + } + if (info != 0) { + xerbla_((char *)"ZHPR ", &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; + } + kk = 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; + k = kk; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = k; + i__4 = k; + 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 = ap[i__4].r + z__2.r, z__1.i = ap[i__4].i + z__2.i; + ap[i__3].r = z__1.r, ap[i__3].i = z__1.i; + ++k; + } + i__2 = kk + j - 1; + i__3 = kk + j - 1; + 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 = ap[i__3].r + z__1.r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + } else { + i__2 = kk + j - 1; + i__3 = kk + j - 1; + d__1 = ap[i__3].r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + } + kk += j; + } + } 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 = kk + j - 2; + for (k = kk; k <= i__2; ++k) { + i__3 = k; + i__4 = k; + 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 = ap[i__4].r + z__2.r, z__1.i = ap[i__4].i + z__2.i; + ap[i__3].r = z__1.r, ap[i__3].i = z__1.i; + ix += *incx; + } + i__2 = kk + j - 1; + i__3 = kk + j - 1; + 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 = ap[i__3].r + z__1.r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + } else { + i__2 = kk + j - 1; + i__3 = kk + j - 1; + d__1 = ap[i__3].r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + } + jx += *incx; + kk += j; + } + } + } 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 = kk; + i__3 = kk; + 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 = ap[i__3].r + z__1.r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + k = kk + 1; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = k; + i__4 = k; + 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 = ap[i__4].r + z__2.r, z__1.i = ap[i__4].i + z__2.i; + ap[i__3].r = z__1.r, ap[i__3].i = z__1.i; + ++k; + } + } else { + i__2 = kk; + i__3 = kk; + d__1 = ap[i__3].r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + } + kk = kk + *n - j + 1; + } + } 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 = kk; + i__3 = kk; + 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 = ap[i__3].r + z__1.r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + ix = jx; + i__2 = kk + *n - j; + for (k = kk + 1; k <= i__2; ++k) { + ix += *incx; + i__3 = k; + i__4 = k; + 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 = ap[i__4].r + z__2.r, z__1.i = ap[i__4].i + z__2.i; + ap[i__3].r = z__1.r, ap[i__3].i = z__1.i; + } + } else { + i__2 = kk; + i__3 = kk; + d__1 = ap[i__3].r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + } + jx += *incx; + kk = kk + *n - j + 1; + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zhpr.f b/lib/linalg/zhpr.f deleted file mode 100644 index 2ba5774a21..0000000000 --- a/lib/linalg/zhpr.f +++ /dev/null @@ -1,276 +0,0 @@ -*> \brief \b ZHPR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE ZHPR(UPLO,N,ALPHA,X,INCX,AP) -* -* .. Scalar Arguments .. -* DOUBLE PRECISION ALPHA -* INTEGER INCX,N -* CHARACTER UPLO -* .. -* .. Array Arguments .. -* COMPLEX*16 AP(*),X(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZHPR performs the hermitian rank 1 operation -*> -*> A := alpha*x*x**H + A, -*> -*> where alpha is a real scalar, x is an n element vector and A is an -*> n by n hermitian matrix, supplied in packed form. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the upper or lower -*> triangular part of the matrix A is supplied in the packed -*> array AP as follows: -*> -*> UPLO = 'U' or 'u' The upper triangular part of A is -*> supplied in AP. -*> -*> UPLO = 'L' or 'l' The lower triangular part of A is -*> supplied in AP. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the order of the matrix A. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is DOUBLE PRECISION. -*> On entry, ALPHA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in] X -*> \verbatim -*> X is COMPLEX*16 array, dimension at least -*> ( 1 + ( n - 1 )*abs( INCX ) ). -*> Before entry, the incremented array X must contain the n -*> element vector x. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> On entry, INCX specifies the increment for the elements of -*> X. INCX must not be zero. -*> \endverbatim -*> -*> \param[in,out] AP -*> \verbatim -*> AP is COMPLEX*16 array, dimension at least -*> ( ( n*( n + 1 ) )/2 ). -*> Before entry with UPLO = 'U' or 'u', the array AP must -*> contain the upper triangular part of the hermitian matrix -*> packed sequentially, column by column, so that AP( 1 ) -*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -*> and a( 2, 2 ) respectively, and so on. On exit, the array -*> AP is overwritten by the upper triangular part of the -*> updated matrix. -*> Before entry with UPLO = 'L' or 'l', the array AP must -*> contain the lower triangular part of the hermitian matrix -*> packed sequentially, column by column, so that AP( 1 ) -*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -*> and a( 3, 1 ) respectively, and so on. On exit, the array -*> AP is overwritten by the lower triangular part of the -*> updated matrix. -*> Note that the imaginary parts of the diagonal elements need -*> not be set, they are assumed to be zero, and on exit they -*> are set to zero. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16_blas_level2 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 2 Blas routine. -*> -*> -- Written on 22-October-1986. -*> Jack Dongarra, Argonne National Lab. -*> Jeremy Du Croz, Nag Central Office. -*> Sven Hammarling, Nag Central Office. -*> Richard Hanson, Sandia National Labs. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZHPR(UPLO,N,ALPHA,X,INCX,AP) -* -* -- Reference BLAS level2 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX,N - CHARACTER UPLO -* .. -* .. Array Arguments .. - COMPLEX*16 AP(*),X(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER (ZERO= (0.0D+0,0.0D+0)) -* .. -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I,INFO,IX,J,JX,K,KK,KX -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE,DCONJG -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN - INFO = 1 - ELSE IF (N.LT.0) THEN - INFO = 2 - ELSE IF (INCX.EQ.0) THEN - INFO = 5 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('ZHPR ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF ((N.EQ.0) .OR. (ALPHA.EQ.DBLE(ZERO))) RETURN -* -* Set the start point in X if the increment is not unity. -* - IF (INCX.LE.0) THEN - KX = 1 - (N-1)*INCX - ELSE IF (INCX.NE.1) THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of the array AP -* are accessed sequentially with one pass through AP. -* - KK = 1 - IF (LSAME(UPLO,'U')) THEN -* -* Form A when upper triangle is stored in AP. -* - IF (INCX.EQ.1) THEN - DO 20 J = 1,N - IF (X(J).NE.ZERO) THEN - TEMP = ALPHA*DCONJG(X(J)) - K = KK - DO 10 I = 1,J - 1 - AP(K) = AP(K) + X(I)*TEMP - K = K + 1 - 10 CONTINUE - AP(KK+J-1) = DBLE(AP(KK+J-1)) + DBLE(X(J)*TEMP) - ELSE - AP(KK+J-1) = DBLE(AP(KK+J-1)) - END IF - KK = KK + J - 20 CONTINUE - ELSE - JX = KX - DO 40 J = 1,N - IF (X(JX).NE.ZERO) THEN - TEMP = ALPHA*DCONJG(X(JX)) - IX = KX - DO 30 K = KK,KK + J - 2 - AP(K) = AP(K) + X(IX)*TEMP - IX = IX + INCX - 30 CONTINUE - AP(KK+J-1) = DBLE(AP(KK+J-1)) + DBLE(X(JX)*TEMP) - ELSE - AP(KK+J-1) = DBLE(AP(KK+J-1)) - END IF - JX = JX + INCX - KK = KK + J - 40 CONTINUE - END IF - ELSE -* -* Form A when lower triangle is stored in AP. -* - IF (INCX.EQ.1) THEN - DO 60 J = 1,N - IF (X(J).NE.ZERO) THEN - TEMP = ALPHA*DCONJG(X(J)) - AP(KK) = DBLE(AP(KK)) + DBLE(TEMP*X(J)) - K = KK + 1 - DO 50 I = J + 1,N - AP(K) = AP(K) + X(I)*TEMP - K = K + 1 - 50 CONTINUE - ELSE - AP(KK) = DBLE(AP(KK)) - END IF - KK = KK + N - J + 1 - 60 CONTINUE - ELSE - JX = KX - DO 80 J = 1,N - IF (X(JX).NE.ZERO) THEN - TEMP = ALPHA*DCONJG(X(JX)) - AP(KK) = DBLE(AP(KK)) + DBLE(TEMP*X(JX)) - IX = JX - DO 70 K = KK + 1,KK + N - J - IX = IX + INCX - AP(K) = AP(K) + X(IX)*TEMP - 70 CONTINUE - ELSE - AP(KK) = DBLE(AP(KK)) - END IF - JX = JX + INCX - KK = KK + N - J + 1 - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZHPR -* - END diff --git a/lib/linalg/zlacgv.cpp b/lib/linalg/zlacgv.cpp new file mode 100644 index 0000000000..bf6a1e8a42 --- /dev/null +++ b/lib/linalg/zlacgv.cpp @@ -0,0 +1,36 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int zlacgv_(integer *n, doublecomplex *x, integer *incx) +{ + integer i__1, i__2; + doublecomplex z__1; + void d_lmp_cnjg(doublecomplex *, doublecomplex *); + integer i__, ioff; + --x; + if (*incx == 1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + d_lmp_cnjg(&z__1, &x[i__]); + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + } + } else { + ioff = 1; + if (*incx < 0) { + ioff = 1 - (*n - 1) * *incx; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = ioff; + d_lmp_cnjg(&z__1, &x[ioff]); + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + ioff += *incx; + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zlacgv.f b/lib/linalg/zlacgv.f deleted file mode 100644 index dc935e08f4..0000000000 --- a/lib/linalg/zlacgv.f +++ /dev/null @@ -1,113 +0,0 @@ -*> \brief \b ZLACGV conjugates a complex vector. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLACGV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZLACGV( N, X, INCX ) -* -* .. Scalar Arguments .. -* INTEGER INCX, N -* .. -* .. Array Arguments .. -* COMPLEX*16 X( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLACGV conjugates a complex vector of length N. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The length of the vector X. N >= 0. -*> \endverbatim -*> -*> \param[in,out] X -*> \verbatim -*> X is COMPLEX*16 array, dimension -*> (1+(N-1)*abs(INCX)) -*> On entry, the vector of length N to be conjugated. -*> On exit, X is overwritten with conjg(X). -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> The spacing between successive elements of X. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERauxiliary -* -* ===================================================================== - SUBROUTINE ZLACGV( N, X, INCX ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX, N -* .. -* .. Array Arguments .. - COMPLEX*16 X( * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, IOFF -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG -* .. -* .. Executable Statements .. -* - IF( INCX.EQ.1 ) THEN - DO 10 I = 1, N - X( I ) = DCONJG( X( I ) ) - 10 CONTINUE - ELSE - IOFF = 1 - IF( INCX.LT.0 ) - $ IOFF = 1 - ( N-1 )*INCX - DO 20 I = 1, N - X( IOFF ) = DCONJG( X( IOFF ) ) - IOFF = IOFF + INCX - 20 CONTINUE - END IF - RETURN -* -* End of ZLACGV -* - END diff --git a/lib/linalg/zlacpy.cpp b/lib/linalg/zlacpy.cpp new file mode 100644 index 0000000000..18db0fac60 --- /dev/null +++ b/lib/linalg/zlacpy.cpp @@ -0,0 +1,52 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int zlacpy_(char *uplo, integer *m, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, + integer *ldb, ftnlen uplo_len) +{ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4; + integer i__, j; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = min(j, *m); + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * a_dim1; + b[i__3].r = a[i__4].r, b[i__3].i = a[i__4].i; + } + } + } else if (lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * a_dim1; + b[i__3].r = a[i__4].r, b[i__3].i = a[i__4].i; + } + } + } 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 * b_dim1; + i__4 = i__ + j * a_dim1; + b[i__3].r = a[i__4].r, b[i__3].i = a[i__4].i; + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zlacpy.f b/lib/linalg/zlacpy.f deleted file mode 100644 index 06017509e0..0000000000 --- a/lib/linalg/zlacpy.f +++ /dev/null @@ -1,156 +0,0 @@ -*> \brief \b ZLACPY copies all or part of one two-dimensional array to another. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLACPY + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER LDA, LDB, M, N -* .. -* .. Array Arguments .. -* COMPLEX*16 A( LDA, * ), B( LDB, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLACPY copies all or part of a two-dimensional matrix A to another -*> matrix B. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> Specifies the part of the matrix A to be copied to B. -*> = 'U': Upper triangular part -*> = 'L': Lower triangular part -*> Otherwise: All of the matrix A -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,N) -*> The m by n matrix A. If UPLO = 'U', only the upper trapezium -*> is accessed; if UPLO = 'L', only the lower trapezium is -*> accessed. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[out] B -*> \verbatim -*> B is COMPLEX*16 array, dimension (LDB,N) -*> On exit, B = A in the locations specified by UPLO. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >= max(1,M). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERauxiliary -* -* ===================================================================== - SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, LDB, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, J -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* - IF( LSAME( UPLO, 'U' ) ) THEN - DO 20 J = 1, N - DO 10 I = 1, MIN( J, M ) - B( I, J ) = A( I, J ) - 10 CONTINUE - 20 CONTINUE -* - ELSE IF( LSAME( UPLO, 'L' ) ) THEN - DO 40 J = 1, N - DO 30 I = J, M - B( I, J ) = A( I, J ) - 30 CONTINUE - 40 CONTINUE -* - ELSE - DO 60 J = 1, N - DO 50 I = 1, M - B( I, J ) = A( I, J ) - 50 CONTINUE - 60 CONTINUE - END IF -* - RETURN -* -* End of ZLACPY -* - END diff --git a/lib/linalg/zlacrm.cpp b/lib/linalg/zlacrm.cpp new file mode 100644 index 0000000000..4d736ac15f --- /dev/null +++ b/lib/linalg/zlacrm.cpp @@ -0,0 +1,76 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static doublereal c_b6 = 1.; +static doublereal c_b7 = 0.; +int zlacrm_(integer *m, integer *n, doublecomplex *a, integer *lda, doublereal *b, integer *ldb, + doublecomplex *c__, integer *ldc, doublereal *rwork) +{ + integer b_dim1, b_offset, a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5; + doublereal d__1; + doublecomplex z__1; + double d_lmp_imag(doublecomplex *); + integer i__, j, l; + extern int dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, doublereal *, doublereal *, 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; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --rwork; + if (*m == 0 || *n == 0) { + return 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 * a_dim1; + rwork[(j - 1) * *m + i__] = a[i__3].r; + } + } + l = *m * *n + 1; + dgemm_((char *)"N", (char *)"N", m, n, n, &c_b6, &rwork[1], m, &b[b_offset], ldb, &c_b7, &rwork[l], m, + (ftnlen)1, (ftnlen)1); + 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 = l + (j - 1) * *m + i__ - 1; + c__[i__3].r = rwork[i__4], c__[i__3].i = 0.; + } + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + rwork[(j - 1) * *m + i__] = d_lmp_imag(&a[i__ + j * a_dim1]); + } + } + dgemm_((char *)"N", (char *)"N", m, n, n, &c_b6, &rwork[1], m, &b[b_offset], ldb, &c_b7, &rwork[l], m, + (ftnlen)1, (ftnlen)1); + 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; + d__1 = c__[i__4].r; + i__5 = l + (j - 1) * *m + i__ - 1; + z__1.r = d__1, z__1.i = rwork[i__5]; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zlacrm.f b/lib/linalg/zlacrm.f deleted file mode 100644 index ce8b9b02c5..0000000000 --- a/lib/linalg/zlacrm.f +++ /dev/null @@ -1,182 +0,0 @@ -*> \brief \b ZLACRM multiplies a complex matrix by a square real matrix. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLACRM + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZLACRM( M, N, A, LDA, B, LDB, C, LDC, RWORK ) -* -* .. Scalar Arguments .. -* INTEGER LDA, LDB, LDC, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION B( LDB, * ), RWORK( * ) -* COMPLEX*16 A( LDA, * ), C( LDC, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLACRM performs a very simple matrix-matrix multiplication: -*> C := A * B, -*> where A is M by N and complex; B is N by N and real; -*> C is M by N and complex. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A and of the matrix C. -*> M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns and rows of the matrix B and -*> the number of columns of the matrix C. -*> N >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA, N) -*> On entry, A contains the M by N matrix A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >=max(1,M). -*> \endverbatim -*> -*> \param[in] B -*> \verbatim -*> B is DOUBLE PRECISION array, dimension (LDB, N) -*> On entry, B contains the N by N matrix B. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> The leading dimension of the array B. LDB >=max(1,N). -*> \endverbatim -*> -*> \param[out] C -*> \verbatim -*> C is COMPLEX*16 array, dimension (LDC, N) -*> On exit, C contains the M by N matrix C. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >=max(1,N). -*> \endverbatim -*> -*> \param[out] RWORK -*> \verbatim -*> RWORK is DOUBLE PRECISION array, dimension (2*M*N) -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERauxiliary -* -* ===================================================================== - SUBROUTINE ZLACRM( M, N, A, LDA, B, LDB, C, LDC, RWORK ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER LDA, LDB, LDC, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION B( LDB, * ), RWORK( * ) - COMPLEX*16 A( LDA, * ), C( LDC, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -* .. -* .. Local Scalars .. - INTEGER I, J, L -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, DCMPLX, DIMAG -* .. -* .. External Subroutines .. - EXTERNAL DGEMM -* .. -* .. Executable Statements .. -* -* Quick return if possible. -* - IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) - $ RETURN -* - DO 20 J = 1, N - DO 10 I = 1, M - RWORK( ( J-1 )*M+I ) = DBLE( A( I, J ) ) - 10 CONTINUE - 20 CONTINUE -* - L = M*N + 1 - CALL DGEMM( 'N', 'N', M, N, N, ONE, RWORK, M, B, LDB, ZERO, - $ RWORK( L ), M ) - DO 40 J = 1, N - DO 30 I = 1, M - C( I, J ) = RWORK( L+( J-1 )*M+I-1 ) - 30 CONTINUE - 40 CONTINUE -* - DO 60 J = 1, N - DO 50 I = 1, M - RWORK( ( J-1 )*M+I ) = DIMAG( A( I, J ) ) - 50 CONTINUE - 60 CONTINUE - CALL DGEMM( 'N', 'N', M, N, N, ONE, RWORK, M, B, LDB, ZERO, - $ RWORK( L ), M ) - DO 80 J = 1, N - DO 70 I = 1, M - C( I, J ) = DCMPLX( DBLE( C( I, J ) ), - $ RWORK( L+( J-1 )*M+I-1 ) ) - 70 CONTINUE - 80 CONTINUE -* - RETURN -* -* End of ZLACRM -* - END diff --git a/lib/linalg/zladiv.cpp b/lib/linalg/zladiv.cpp new file mode 100644 index 0000000000..ec130d40d9 --- /dev/null +++ b/lib/linalg/zladiv.cpp @@ -0,0 +1,24 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +VOID zladiv_(doublecomplex *ret_val, doublecomplex *x, doublecomplex *y) +{ + doublereal d__1, d__2, d__3, d__4; + doublecomplex z__1; + double d_lmp_imag(doublecomplex *); + doublereal zi, zr; + extern int dladiv_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *); + d__1 = x->r; + d__2 = d_lmp_imag(x); + d__3 = y->r; + d__4 = d_lmp_imag(y); + dladiv_(&d__1, &d__2, &d__3, &d__4, &zr, &zi); + z__1.r = zr, z__1.i = zi; + ret_val->r = z__1.r, ret_val->i = z__1.i; + return; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zladiv.f b/lib/linalg/zladiv.f deleted file mode 100644 index ae111d73d6..0000000000 --- a/lib/linalg/zladiv.f +++ /dev/null @@ -1,94 +0,0 @@ -*> \brief \b ZLADIV performs complex division in real arithmetic, avoiding unnecessary overflow. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLADIV + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* COMPLEX*16 FUNCTION ZLADIV( X, Y ) -* -* .. Scalar Arguments .. -* COMPLEX*16 X, Y -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLADIV := X / Y, where X and Y are complex. The computation of X / Y -*> will not overflow on an intermediary step unless the results -*> overflows. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] X -*> \verbatim -*> X is COMPLEX*16 -*> \endverbatim -*> -*> \param[in] Y -*> \verbatim -*> Y is COMPLEX*16 -*> The complex scalars X and Y. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERauxiliary -* -* ===================================================================== - COMPLEX*16 FUNCTION ZLADIV( X, Y ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - COMPLEX*16 X, Y -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - DOUBLE PRECISION ZI, ZR -* .. -* .. External Subroutines .. - EXTERNAL DLADIV -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, DCMPLX, DIMAG -* .. -* .. Executable Statements .. -* - CALL DLADIV( DBLE( X ), DIMAG( X ), DBLE( Y ), DIMAG( Y ), ZR, - $ ZI ) - ZLADIV = DCMPLX( ZR, ZI ) -* - RETURN -* -* End of ZLADIV -* - END diff --git a/lib/linalg/zlaed0.cpp b/lib/linalg/zlaed0.cpp new file mode 100644 index 0000000000..6729b532c9 --- /dev/null +++ b/lib/linalg/zlaed0.cpp @@ -0,0 +1,187 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__9 = 9; +static integer c__0 = 0; +static integer c__2 = 2; +static integer c__1 = 1; +int zlaed0_(integer *qsiz, integer *n, doublereal *d__, doublereal *e, doublecomplex *q, + integer *ldq, doublecomplex *qstore, integer *ldqs, doublereal *rwork, integer *iwork, + integer *info) +{ + integer q_dim1, q_offset, qstore_dim1, qstore_offset, i__1, i__2; + doublereal d__1; + double log(doublereal); + integer pow_lmp_ii(integer *, integer *); + integer i__, j, k, ll, iq, lgn, msd2, smm1, spm1, spm2; + doublereal temp; + integer curr, iperm; + extern int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *); + integer indxq, iwrem, iqptr, tlvls; + extern int zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), + zlaed7_(integer *, integer *, integer *, integer *, integer *, integer *, doublereal *, + doublecomplex *, integer *, doublereal *, integer *, doublereal *, integer *, + integer *, integer *, integer *, integer *, doublereal *, doublecomplex *, + doublereal *, integer *, integer *); + integer igivcl; + extern int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, + ftnlen, ftnlen); + extern int zlacrm_(integer *, integer *, doublecomplex *, integer *, doublereal *, integer *, + doublecomplex *, integer *, doublereal *); + integer igivnm, submat, curprb, subpbs, igivpt; + extern int dsteqr_(char *, integer *, doublereal *, doublereal *, doublereal *, integer *, + doublereal *, integer *, ftnlen); + integer curlvl, matsiz, iprmpt, smlsiz; + --d__; + --e; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + qstore_dim1 = *ldqs; + qstore_offset = 1 + qstore_dim1; + qstore -= qstore_offset; + --rwork; + --iwork; + *info = 0; + if (*qsiz < max(0, *n)) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*ldq < max(1, *n)) { + *info = -6; + } else if (*ldqs < max(1, *n)) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"ZLAED0", &i__1, (ftnlen)6); + return 0; + } + if (*n == 0) { + return 0; + } + smlsiz = ilaenv_(&c__9, (char *)"ZLAED0", (char *)" ", &c__0, &c__0, &c__0, &c__0, (ftnlen)6, (ftnlen)1); + iwork[1] = *n; + subpbs = 1; + tlvls = 0; +L10: + if (iwork[subpbs] > smlsiz) { + for (j = subpbs; j >= 1; --j) { + iwork[j * 2] = (iwork[j] + 1) / 2; + iwork[(j << 1) - 1] = iwork[j] / 2; + } + ++tlvls; + subpbs <<= 1; + goto L10; + } + i__1 = subpbs; + for (j = 2; j <= i__1; ++j) { + iwork[j] += iwork[j - 1]; + } + spm1 = subpbs - 1; + i__1 = spm1; + for (i__ = 1; i__ <= i__1; ++i__) { + submat = iwork[i__] + 1; + smm1 = submat - 1; + d__[smm1] -= (d__1 = e[smm1], abs(d__1)); + d__[submat] -= (d__1 = e[smm1], abs(d__1)); + } + indxq = (*n << 2) + 3; + temp = log((doublereal)(*n)) / log(2.); + lgn = (integer)temp; + if (pow_lmp_ii(&c__2, &lgn) < *n) { + ++lgn; + } + if (pow_lmp_ii(&c__2, &lgn) < *n) { + ++lgn; + } + iprmpt = indxq + *n + 1; + iperm = iprmpt + *n * lgn; + iqptr = iperm + *n * lgn; + igivpt = iqptr + *n + 2; + igivcl = igivpt + *n * lgn; + igivnm = 1; + iq = igivnm + (*n << 1) * lgn; + i__1 = *n; + iwrem = iq + i__1 * i__1 + 1; + i__1 = subpbs; + for (i__ = 0; i__ <= i__1; ++i__) { + iwork[iprmpt + i__] = 1; + iwork[igivpt + i__] = 1; + } + iwork[iqptr] = 1; + curr = 0; + i__1 = spm1; + for (i__ = 0; i__ <= i__1; ++i__) { + if (i__ == 0) { + submat = 1; + matsiz = iwork[1]; + } else { + submat = iwork[i__] + 1; + matsiz = iwork[i__ + 1] - iwork[i__]; + } + ll = iq - 1 + iwork[iqptr + curr]; + dsteqr_((char *)"I", &matsiz, &d__[submat], &e[submat], &rwork[ll], &matsiz, &rwork[1], info, + (ftnlen)1); + zlacrm_(qsiz, &matsiz, &q[submat * q_dim1 + 1], ldq, &rwork[ll], &matsiz, + &qstore[submat * qstore_dim1 + 1], ldqs, &rwork[iwrem]); + i__2 = matsiz; + iwork[iqptr + curr + 1] = iwork[iqptr + curr] + i__2 * i__2; + ++curr; + if (*info > 0) { + *info = submat * (*n + 1) + submat + matsiz - 1; + return 0; + } + k = 1; + i__2 = iwork[i__ + 1]; + for (j = submat; j <= i__2; ++j) { + iwork[indxq + j] = k; + ++k; + } + } + curlvl = 1; +L80: + if (subpbs > 1) { + spm2 = subpbs - 2; + i__1 = spm2; + for (i__ = 0; i__ <= i__1; i__ += 2) { + if (i__ == 0) { + submat = 1; + matsiz = iwork[2]; + msd2 = iwork[1]; + curprb = 0; + } else { + submat = iwork[i__] + 1; + matsiz = iwork[i__ + 2] - iwork[i__]; + msd2 = matsiz / 2; + ++curprb; + } + zlaed7_(&matsiz, &msd2, qsiz, &tlvls, &curlvl, &curprb, &d__[submat], + &qstore[submat * qstore_dim1 + 1], ldqs, &e[submat + msd2 - 1], + &iwork[indxq + submat], &rwork[iq], &iwork[iqptr], &iwork[iprmpt], + &iwork[iperm], &iwork[igivpt], &iwork[igivcl], &rwork[igivnm], + &q[submat * q_dim1 + 1], &rwork[iwrem], &iwork[subpbs + 1], info); + if (*info > 0) { + *info = submat * (*n + 1) + submat + matsiz - 1; + return 0; + } + iwork[i__ / 2 + 1] = iwork[i__ + 2]; + } + subpbs /= 2; + ++curlvl; + goto L80; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + j = iwork[indxq + i__]; + rwork[i__] = d__[j]; + zcopy_(qsiz, &qstore[j * qstore_dim1 + 1], &c__1, &q[i__ * q_dim1 + 1], &c__1); + } + dcopy_(n, &rwork[1], &c__1, &d__[1], &c__1); + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zlaed0.f b/lib/linalg/zlaed0.f deleted file mode 100644 index c4deac037a..0000000000 --- a/lib/linalg/zlaed0.f +++ /dev/null @@ -1,368 +0,0 @@ -*> \brief \b ZLAED0 used by ZSTEDC. Computes all eigenvalues and corresponding eigenvectors of an unreduced symmetric tridiagonal matrix using the divide and conquer method. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLAED0 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZLAED0( QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, RWORK, -* IWORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, LDQ, LDQS, N, QSIZ -* .. -* .. Array Arguments .. -* INTEGER IWORK( * ) -* DOUBLE PRECISION D( * ), E( * ), RWORK( * ) -* COMPLEX*16 Q( LDQ, * ), QSTORE( LDQS, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> Using the divide and conquer method, ZLAED0 computes all eigenvalues -*> of a symmetric tridiagonal matrix which is one diagonal block of -*> those from reducing a dense or band Hermitian matrix and -*> corresponding eigenvectors of the dense or band matrix. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] QSIZ -*> \verbatim -*> QSIZ is INTEGER -*> The dimension of the unitary matrix used to reduce -*> the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The dimension of the symmetric tridiagonal matrix. N >= 0. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, the diagonal elements of the tridiagonal matrix. -*> On exit, the eigenvalues in ascending order. -*> \endverbatim -*> -*> \param[in,out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N-1) -*> On entry, the off-diagonal elements of the tridiagonal matrix. -*> On exit, E has been destroyed. -*> \endverbatim -*> -*> \param[in,out] Q -*> \verbatim -*> Q is COMPLEX*16 array, dimension (LDQ,N) -*> On entry, Q must contain an QSIZ x N matrix whose columns -*> unitarily orthonormal. It is a part of the unitary matrix -*> that reduces the full dense Hermitian matrix to a -*> (reducible) symmetric tridiagonal matrix. -*> \endverbatim -*> -*> \param[in] LDQ -*> \verbatim -*> LDQ is INTEGER -*> The leading dimension of the array Q. LDQ >= max(1,N). -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, -*> the dimension of IWORK must be at least -*> 6 + 6*N + 5*N*lg N -*> ( lg( N ) = smallest integer k -*> such that 2^k >= N ) -*> \endverbatim -*> -*> \param[out] RWORK -*> \verbatim -*> RWORK is DOUBLE PRECISION array, -*> dimension (1 + 3*N + 2*N*lg N + 3*N**2) -*> ( lg( N ) = smallest integer k -*> such that 2^k >= N ) -*> \endverbatim -*> -*> \param[out] QSTORE -*> \verbatim -*> QSTORE is COMPLEX*16 array, dimension (LDQS, N) -*> Used to store parts of -*> the eigenvector matrix when the updating matrix multiplies -*> take place. -*> \endverbatim -*> -*> \param[in] LDQS -*> \verbatim -*> LDQS is INTEGER -*> The leading dimension of the array QSTORE. -*> LDQS >= max(1,N). -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit. -*> < 0: if INFO = -i, the i-th argument had an illegal value. -*> > 0: The algorithm failed to compute an eigenvalue while -*> working on the submatrix lying in rows and columns -*> INFO/(N+1) through mod(INFO,N+1). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZLAED0( QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, RWORK, - $ IWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, LDQ, LDQS, N, QSIZ -* .. -* .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION D( * ), E( * ), RWORK( * ) - COMPLEX*16 Q( LDQ, * ), QSTORE( LDQS, * ) -* .. -* -* ===================================================================== -* -* Warning: N could be as big as QSIZ! -* -* .. Parameters .. - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.D+0 ) -* .. -* .. Local Scalars .. - INTEGER CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM, - $ IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM, - $ J, K, LGN, LL, MATSIZ, MSD2, SMLSIZ, SMM1, - $ SPM1, SPM2, SUBMAT, SUBPBS, TLVLS - DOUBLE PRECISION TEMP -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DSTEQR, XERBLA, ZCOPY, ZLACRM, ZLAED7 -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, LOG, MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* -* IF( ICOMPQ .LT. 0 .OR. ICOMPQ .GT. 2 ) THEN -* INFO = -1 -* ELSE IF( ( ICOMPQ .EQ. 1 ) .AND. ( QSIZ .LT. MAX( 0, N ) ) ) -* $ THEN - IF( QSIZ.LT.MAX( 0, N ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDQS.LT.MAX( 1, N ) ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZLAED0', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - SMLSIZ = ILAENV( 9, 'ZLAED0', ' ', 0, 0, 0, 0 ) -* -* Determine the size and placement of the submatrices, and save in -* the leading elements of IWORK. -* - IWORK( 1 ) = N - SUBPBS = 1 - TLVLS = 0 - 10 CONTINUE - IF( IWORK( SUBPBS ).GT.SMLSIZ ) THEN - DO 20 J = SUBPBS, 1, -1 - IWORK( 2*J ) = ( IWORK( J )+1 ) / 2 - IWORK( 2*J-1 ) = IWORK( J ) / 2 - 20 CONTINUE - TLVLS = TLVLS + 1 - SUBPBS = 2*SUBPBS - GO TO 10 - END IF - DO 30 J = 2, SUBPBS - IWORK( J ) = IWORK( J ) + IWORK( J-1 ) - 30 CONTINUE -* -* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1 -* using rank-1 modifications (cuts). -* - SPM1 = SUBPBS - 1 - DO 40 I = 1, SPM1 - SUBMAT = IWORK( I ) + 1 - SMM1 = SUBMAT - 1 - D( SMM1 ) = D( SMM1 ) - ABS( E( SMM1 ) ) - D( SUBMAT ) = D( SUBMAT ) - ABS( E( SMM1 ) ) - 40 CONTINUE -* - INDXQ = 4*N + 3 -* -* Set up workspaces for eigenvalues only/accumulate new vectors -* routine -* - TEMP = LOG( DBLE( N ) ) / LOG( TWO ) - LGN = INT( TEMP ) - IF( 2**LGN.LT.N ) - $ LGN = LGN + 1 - IF( 2**LGN.LT.N ) - $ LGN = LGN + 1 - IPRMPT = INDXQ + N + 1 - IPERM = IPRMPT + N*LGN - IQPTR = IPERM + N*LGN - IGIVPT = IQPTR + N + 2 - IGIVCL = IGIVPT + N*LGN -* - IGIVNM = 1 - IQ = IGIVNM + 2*N*LGN - IWREM = IQ + N**2 + 1 -* Initialize pointers - DO 50 I = 0, SUBPBS - IWORK( IPRMPT+I ) = 1 - IWORK( IGIVPT+I ) = 1 - 50 CONTINUE - IWORK( IQPTR ) = 1 -* -* Solve each submatrix eigenproblem at the bottom of the divide and -* conquer tree. -* - CURR = 0 - DO 70 I = 0, SPM1 - IF( I.EQ.0 ) THEN - SUBMAT = 1 - MATSIZ = IWORK( 1 ) - ELSE - SUBMAT = IWORK( I ) + 1 - MATSIZ = IWORK( I+1 ) - IWORK( I ) - END IF - LL = IQ - 1 + IWORK( IQPTR+CURR ) - CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ), - $ RWORK( LL ), MATSIZ, RWORK, INFO ) - CALL ZLACRM( QSIZ, MATSIZ, Q( 1, SUBMAT ), LDQ, RWORK( LL ), - $ MATSIZ, QSTORE( 1, SUBMAT ), LDQS, - $ RWORK( IWREM ) ) - IWORK( IQPTR+CURR+1 ) = IWORK( IQPTR+CURR ) + MATSIZ**2 - CURR = CURR + 1 - IF( INFO.GT.0 ) THEN - INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1 - RETURN - END IF - K = 1 - DO 60 J = SUBMAT, IWORK( I+1 ) - IWORK( INDXQ+J ) = K - K = K + 1 - 60 CONTINUE - 70 CONTINUE -* -* Successively merge eigensystems of adjacent submatrices -* into eigensystem for the corresponding larger matrix. -* -* while ( SUBPBS > 1 ) -* - CURLVL = 1 - 80 CONTINUE - IF( SUBPBS.GT.1 ) THEN - SPM2 = SUBPBS - 2 - DO 90 I = 0, SPM2, 2 - IF( I.EQ.0 ) THEN - SUBMAT = 1 - MATSIZ = IWORK( 2 ) - MSD2 = IWORK( 1 ) - CURPRB = 0 - ELSE - SUBMAT = IWORK( I ) + 1 - MATSIZ = IWORK( I+2 ) - IWORK( I ) - MSD2 = MATSIZ / 2 - CURPRB = CURPRB + 1 - END IF -* -* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2) -* into an eigensystem of size MATSIZ. ZLAED7 handles the case -* when the eigenvectors of a full or band Hermitian matrix (which -* was reduced to tridiagonal form) are desired. -* -* I am free to use Q as a valuable working space until Loop 150. -* - CALL ZLAED7( MATSIZ, MSD2, QSIZ, TLVLS, CURLVL, CURPRB, - $ D( SUBMAT ), QSTORE( 1, SUBMAT ), LDQS, - $ E( SUBMAT+MSD2-1 ), IWORK( INDXQ+SUBMAT ), - $ RWORK( IQ ), IWORK( IQPTR ), IWORK( IPRMPT ), - $ IWORK( IPERM ), IWORK( IGIVPT ), - $ IWORK( IGIVCL ), RWORK( IGIVNM ), - $ Q( 1, SUBMAT ), RWORK( IWREM ), - $ IWORK( SUBPBS+1 ), INFO ) - IF( INFO.GT.0 ) THEN - INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1 - RETURN - END IF - IWORK( I / 2+1 ) = IWORK( I+2 ) - 90 CONTINUE - SUBPBS = SUBPBS / 2 - CURLVL = CURLVL + 1 - GO TO 80 - END IF -* -* end while -* -* Re-merge the eigenvalues/vectors which were deflated at the final -* merge step. -* - DO 100 I = 1, N - J = IWORK( INDXQ+I ) - RWORK( I ) = D( J ) - CALL ZCOPY( QSIZ, QSTORE( 1, J ), 1, Q( 1, I ), 1 ) - 100 CONTINUE - CALL DCOPY( N, RWORK, 1, D, 1 ) -* - RETURN -* -* End of ZLAED0 -* - END diff --git a/lib/linalg/zlaed7.cpp b/lib/linalg/zlaed7.cpp new file mode 100644 index 0000000000..1a045d7edd --- /dev/null +++ b/lib/linalg/zlaed7.cpp @@ -0,0 +1,117 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__2 = 2; +static integer c__1 = 1; +static integer c_n1 = -1; +int zlaed7_(integer *n, integer *cutpnt, integer *qsiz, integer *tlvls, integer *curlvl, + integer *curpbm, doublereal *d__, doublecomplex *q, integer *ldq, doublereal *rho, + integer *indxq, doublereal *qstore, integer *qptr, integer *prmptr, integer *perm, + integer *givptr, integer *givcol, doublereal *givnum, doublecomplex *work, + doublereal *rwork, integer *iwork, integer *info) +{ + integer q_dim1, q_offset, i__1, i__2; + integer pow_lmp_ii(integer *, integer *); + integer i__, k, n1, n2, iq, iw, iz, ptr, indx, curr, indxc, indxp; + extern int dlaed9_(integer *, integer *, integer *, integer *, doublereal *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, + integer *), + zlaed8_(integer *, integer *, integer *, doublecomplex *, integer *, doublereal *, + doublereal *, integer *, doublereal *, doublereal *, doublecomplex *, integer *, + doublereal *, integer *, integer *, integer *, integer *, integer *, integer *, + doublereal *, integer *), + dlaeda_(integer *, integer *, integer *, integer *, integer *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, + integer *); + integer idlmda; + extern int dlamrg_(integer *, integer *, doublereal *, integer *, integer *, integer *), + xerbla_(char *, integer *, ftnlen), + zlacrm_(integer *, integer *, doublecomplex *, integer *, doublereal *, integer *, + doublecomplex *, integer *, doublereal *); + integer coltyp; + --d__; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + --indxq; + --qstore; + --qptr; + --prmptr; + --perm; + --givptr; + givcol -= 3; + givnum -= 3; + --work; + --rwork; + --iwork; + *info = 0; + if (*n < 0) { + *info = -1; + } else if (min(1, *n) > *cutpnt || *n < *cutpnt) { + *info = -2; + } else if (*qsiz < *n) { + *info = -3; + } else if (*ldq < max(1, *n)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"ZLAED7", &i__1, (ftnlen)6); + return 0; + } + if (*n == 0) { + return 0; + } + iz = 1; + idlmda = iz + *n; + iw = idlmda + *n; + iq = iw + *n; + indx = 1; + indxc = indx + *n; + coltyp = indxc + *n; + indxp = coltyp + *n; + ptr = pow_lmp_ii(&c__2, tlvls) + 1; + i__1 = *curlvl - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *tlvls - i__; + ptr += pow_lmp_ii(&c__2, &i__2); + } + curr = ptr + *curpbm; + dlaeda_(n, tlvls, curlvl, curpbm, &prmptr[1], &perm[1], &givptr[1], &givcol[3], &givnum[3], + &qstore[1], &qptr[1], &rwork[iz], &rwork[iz + *n], info); + if (*curlvl == *tlvls) { + qptr[curr] = 1; + prmptr[curr] = 1; + givptr[curr] = 1; + } + zlaed8_(&k, n, qsiz, &q[q_offset], ldq, &d__[1], rho, cutpnt, &rwork[iz], &rwork[idlmda], + &work[1], qsiz, &rwork[iw], &iwork[indxp], &iwork[indx], &indxq[1], &perm[prmptr[curr]], + &givptr[curr + 1], &givcol[(givptr[curr] << 1) + 1], &givnum[(givptr[curr] << 1) + 1], + info); + prmptr[curr + 1] = prmptr[curr] + *n; + givptr[curr + 1] += givptr[curr]; + if (k != 0) { + dlaed9_(&k, &c__1, &k, n, &d__[1], &rwork[iq], &k, rho, &rwork[idlmda], &rwork[iw], + &qstore[qptr[curr]], &k, info); + zlacrm_(qsiz, &k, &work[1], qsiz, &qstore[qptr[curr]], &k, &q[q_offset], ldq, &rwork[iq]); + i__1 = k; + qptr[curr + 1] = qptr[curr] + i__1 * i__1; + if (*info != 0) { + return 0; + } + n1 = k; + n2 = *n - k; + dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]); + } else { + qptr[curr + 1] = qptr[curr]; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + indxq[i__] = i__; + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zlaed7.f b/lib/linalg/zlaed7.f deleted file mode 100644 index 83f32d8b81..0000000000 --- a/lib/linalg/zlaed7.f +++ /dev/null @@ -1,382 +0,0 @@ -*> \brief \b ZLAED7 used by ZSTEDC. Computes the updated eigensystem of a diagonal matrix after modification by a rank-one symmetric matrix. Used when the original matrix is dense. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLAED7 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZLAED7( N, CUTPNT, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, -* LDQ, RHO, INDXQ, QSTORE, QPTR, PRMPTR, PERM, -* GIVPTR, GIVCOL, GIVNUM, WORK, RWORK, IWORK, -* INFO ) -* -* .. Scalar Arguments .. -* INTEGER CURLVL, CURPBM, CUTPNT, INFO, LDQ, N, QSIZ, -* $ TLVLS -* DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. -* INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ), -* $ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * ) -* DOUBLE PRECISION D( * ), GIVNUM( 2, * ), QSTORE( * ), RWORK( * ) -* COMPLEX*16 Q( LDQ, * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLAED7 computes the updated eigensystem of a diagonal -*> matrix after modification by a rank-one symmetric matrix. This -*> routine is used only for the eigenproblem which requires all -*> eigenvalues and optionally eigenvectors of a dense or banded -*> Hermitian matrix that has been reduced to tridiagonal form. -*> -*> T = Q(in) ( D(in) + RHO * Z*Z**H ) Q**H(in) = Q(out) * D(out) * Q**H(out) -*> -*> where Z = Q**Hu, u is a vector of length N with ones in the -*> CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. -*> -*> The eigenvectors of the original matrix are stored in Q, and the -*> eigenvalues are in D. The algorithm consists of three stages: -*> -*> The first stage consists of deflating the size of the problem -*> when there are multiple eigenvalues or if there is a zero in -*> the Z vector. For each such occurrence the dimension of the -*> secular equation problem is reduced by one. This stage is -*> performed by the routine DLAED2. -*> -*> The second stage consists of calculating the updated -*> eigenvalues. This is done by finding the roots of the secular -*> equation via the routine DLAED4 (as called by SLAED3). -*> This routine also calculates the eigenvectors of the current -*> problem. -*> -*> The final stage consists of computing the updated eigenvectors -*> directly using the updated eigenvalues. The eigenvectors for -*> the current problem are multiplied with the eigenvectors from -*> the overall problem. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The dimension of the symmetric tridiagonal matrix. N >= 0. -*> \endverbatim -*> -*> \param[in] CUTPNT -*> \verbatim -*> CUTPNT is INTEGER -*> Contains the location of the last eigenvalue in the leading -*> sub-matrix. min(1,N) <= CUTPNT <= N. -*> \endverbatim -*> -*> \param[in] QSIZ -*> \verbatim -*> QSIZ is INTEGER -*> The dimension of the unitary matrix used to reduce -*> the full matrix to tridiagonal form. QSIZ >= N. -*> \endverbatim -*> -*> \param[in] TLVLS -*> \verbatim -*> TLVLS is INTEGER -*> The total number of merging levels in the overall divide and -*> conquer tree. -*> \endverbatim -*> -*> \param[in] CURLVL -*> \verbatim -*> CURLVL is INTEGER -*> The current level in the overall merge routine, -*> 0 <= curlvl <= tlvls. -*> \endverbatim -*> -*> \param[in] CURPBM -*> \verbatim -*> CURPBM is INTEGER -*> The current problem in the current level in the overall -*> merge routine (counting from upper left to lower right). -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, the eigenvalues of the rank-1-perturbed matrix. -*> On exit, the eigenvalues of the repaired matrix. -*> \endverbatim -*> -*> \param[in,out] Q -*> \verbatim -*> Q is COMPLEX*16 array, dimension (LDQ,N) -*> On entry, the eigenvectors of the rank-1-perturbed matrix. -*> On exit, the eigenvectors of the repaired tridiagonal matrix. -*> \endverbatim -*> -*> \param[in] LDQ -*> \verbatim -*> LDQ is INTEGER -*> The leading dimension of the array Q. LDQ >= max(1,N). -*> \endverbatim -*> -*> \param[in] RHO -*> \verbatim -*> RHO is DOUBLE PRECISION -*> Contains the subdiagonal element used to create the rank-1 -*> modification. -*> \endverbatim -*> -*> \param[out] INDXQ -*> \verbatim -*> INDXQ is INTEGER array, dimension (N) -*> This contains the permutation which will reintegrate the -*> subproblem just solved back into sorted order, -*> ie. D( INDXQ( I = 1, N ) ) will be in ascending order. -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, dimension (4*N) -*> \endverbatim -*> -*> \param[out] RWORK -*> \verbatim -*> RWORK is DOUBLE PRECISION array, -*> dimension (3*N+2*QSIZ*N) -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 array, dimension (QSIZ*N) -*> \endverbatim -*> -*> \param[in,out] QSTORE -*> \verbatim -*> QSTORE is DOUBLE PRECISION array, dimension (N**2+1) -*> Stores eigenvectors of submatrices encountered during -*> divide and conquer, packed together. QPTR points to -*> beginning of the submatrices. -*> \endverbatim -*> -*> \param[in,out] QPTR -*> \verbatim -*> QPTR is INTEGER array, dimension (N+2) -*> List of indices pointing to beginning of submatrices stored -*> in QSTORE. The submatrices are numbered starting at the -*> bottom left of the divide and conquer tree, from left to -*> right and bottom to top. -*> \endverbatim -*> -*> \param[in] PRMPTR -*> \verbatim -*> PRMPTR is INTEGER array, dimension (N lg N) -*> Contains a list of pointers which indicate where in PERM a -*> level's permutation is stored. PRMPTR(i+1) - PRMPTR(i) -*> indicates the size of the permutation and also the size of -*> the full, non-deflated problem. -*> \endverbatim -*> -*> \param[in] PERM -*> \verbatim -*> PERM is INTEGER array, dimension (N lg N) -*> Contains the permutations (from deflation and sorting) to be -*> applied to each eigenblock. -*> \endverbatim -*> -*> \param[in] GIVPTR -*> \verbatim -*> GIVPTR is INTEGER array, dimension (N lg N) -*> Contains a list of pointers which indicate where in GIVCOL a -*> level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i) -*> indicates the number of Givens rotations. -*> \endverbatim -*> -*> \param[in] GIVCOL -*> \verbatim -*> GIVCOL is INTEGER array, dimension (2, N lg N) -*> Each pair of numbers indicates a pair of columns to take place -*> in a Givens rotation. -*> \endverbatim -*> -*> \param[in] GIVNUM -*> \verbatim -*> GIVNUM is DOUBLE PRECISION array, dimension (2, N lg N) -*> Each number indicates the S value to be used in the -*> corresponding Givens rotation. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit. -*> < 0: if INFO = -i, the i-th argument had an illegal value. -*> > 0: if INFO = 1, an eigenvalue did not converge -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZLAED7( N, CUTPNT, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, - $ LDQ, RHO, INDXQ, QSTORE, QPTR, PRMPTR, PERM, - $ GIVPTR, GIVCOL, GIVNUM, WORK, RWORK, IWORK, - $ INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER CURLVL, CURPBM, CUTPNT, INFO, LDQ, N, QSIZ, - $ TLVLS - DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. - INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ), - $ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * ) - DOUBLE PRECISION D( * ), GIVNUM( 2, * ), QSTORE( * ), RWORK( * ) - COMPLEX*16 Q( LDQ, * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER COLTYP, CURR, I, IDLMDA, INDX, - $ INDXC, INDXP, IQ, IW, IZ, K, N1, N2, PTR -* .. -* .. External Subroutines .. - EXTERNAL DLAED9, DLAEDA, DLAMRG, XERBLA, ZLACRM, ZLAED8 -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* -* IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN -* INFO = -1 -* ELSE IF( N.LT.0 ) THEN - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( MIN( 1, N ).GT.CUTPNT .OR. N.LT.CUTPNT ) THEN - INFO = -2 - ELSE IF( QSIZ.LT.N ) THEN - INFO = -3 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZLAED7', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* The following values are for bookkeeping purposes only. They are -* integer pointers which indicate the portion of the workspace -* used by a particular array in DLAED2 and SLAED3. -* - IZ = 1 - IDLMDA = IZ + N - IW = IDLMDA + N - IQ = IW + N -* - INDX = 1 - INDXC = INDX + N - COLTYP = INDXC + N - INDXP = COLTYP + N -* -* Form the z-vector which consists of the last row of Q_1 and the -* first row of Q_2. -* - PTR = 1 + 2**TLVLS - DO 10 I = 1, CURLVL - 1 - PTR = PTR + 2**( TLVLS-I ) - 10 CONTINUE - CURR = PTR + CURPBM - CALL DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, - $ GIVCOL, GIVNUM, QSTORE, QPTR, RWORK( IZ ), - $ RWORK( IZ+N ), INFO ) -* -* When solving the final problem, we no longer need the stored data, -* so we will overwrite the data from this level onto the previously -* used storage space. -* - IF( CURLVL.EQ.TLVLS ) THEN - QPTR( CURR ) = 1 - PRMPTR( CURR ) = 1 - GIVPTR( CURR ) = 1 - END IF -* -* Sort and Deflate eigenvalues. -* - CALL ZLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, RWORK( IZ ), - $ RWORK( IDLMDA ), WORK, QSIZ, RWORK( IW ), - $ IWORK( INDXP ), IWORK( INDX ), INDXQ, - $ PERM( PRMPTR( CURR ) ), GIVPTR( CURR+1 ), - $ GIVCOL( 1, GIVPTR( CURR ) ), - $ GIVNUM( 1, GIVPTR( CURR ) ), INFO ) - PRMPTR( CURR+1 ) = PRMPTR( CURR ) + N - GIVPTR( CURR+1 ) = GIVPTR( CURR+1 ) + GIVPTR( CURR ) -* -* Solve Secular Equation. -* - IF( K.NE.0 ) THEN - CALL DLAED9( K, 1, K, N, D, RWORK( IQ ), K, RHO, - $ RWORK( IDLMDA ), RWORK( IW ), - $ QSTORE( QPTR( CURR ) ), K, INFO ) - CALL ZLACRM( QSIZ, K, WORK, QSIZ, QSTORE( QPTR( CURR ) ), K, Q, - $ LDQ, RWORK( IQ ) ) - QPTR( CURR+1 ) = QPTR( CURR ) + K**2 - IF( INFO.NE.0 ) THEN - RETURN - END IF -* -* Prepare the INDXQ sorting premutation. -* - N1 = K - N2 = N - K - CALL DLAMRG( N1, N2, D, 1, -1, INDXQ ) - ELSE - QPTR( CURR+1 ) = QPTR( CURR ) - DO 20 I = 1, N - INDXQ( I ) = I - 20 CONTINUE - END IF -* - RETURN -* -* End of ZLAED7 -* - END diff --git a/lib/linalg/zlaed8.cpp b/lib/linalg/zlaed8.cpp new file mode 100644 index 0000000000..d29b380587 --- /dev/null +++ b/lib/linalg/zlaed8.cpp @@ -0,0 +1,206 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static doublereal c_b3 = -1.; +static integer c__1 = 1; +int zlaed8_(integer *k, integer *n, integer *qsiz, doublecomplex *q, integer *ldq, doublereal *d__, + doublereal *rho, integer *cutpnt, doublereal *z__, doublereal *dlamda, + doublecomplex *q2, integer *ldq2, doublereal *w, integer *indxp, integer *indx, + integer *indxq, integer *perm, integer *givptr, integer *givcol, doublereal *givnum, + integer *info) +{ + integer q_dim1, q_offset, q2_dim1, q2_offset, i__1; + doublereal d__1; + double sqrt(doublereal); + doublereal c__; + integer i__, j; + doublereal s, t; + integer k2, n1, n2, jp, n1p1; + doublereal eps, tau, tol; + integer jlam, imax, jmax; + extern int dscal_(integer *, doublereal *, doublereal *, integer *), + dcopy_(integer *, doublereal *, integer *, doublereal *, integer *), + zdrot_(integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublereal *, + doublereal *), + zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *); + extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, ftnlen); + extern integer idamax_(integer *, doublereal *, integer *); + extern int dlamrg_(integer *, integer *, doublereal *, integer *, integer *, integer *), + xerbla_(char *, integer *, ftnlen), + zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, + integer *, ftnlen); + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + --d__; + --z__; + --dlamda; + q2_dim1 = *ldq2; + q2_offset = 1 + q2_dim1; + q2 -= q2_offset; + --w; + --indxp; + --indx; + --indxq; + --perm; + givcol -= 3; + givnum -= 3; + *info = 0; + if (*n < 0) { + *info = -2; + } else if (*qsiz < *n) { + *info = -3; + } else if (*ldq < max(1, *n)) { + *info = -5; + } else if (*cutpnt < min(1, *n) || *cutpnt > *n) { + *info = -8; + } else if (*ldq2 < max(1, *n)) { + *info = -12; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"ZLAED8", &i__1, (ftnlen)6); + return 0; + } + *givptr = 0; + if (*n == 0) { + return 0; + } + n1 = *cutpnt; + n2 = *n - n1; + n1p1 = n1 + 1; + if (*rho < 0.) { + dscal_(&n2, &c_b3, &z__[n1p1], &c__1); + } + t = 1. / sqrt(2.); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + indx[j] = j; + } + dscal_(n, &t, &z__[1], &c__1); + *rho = (d__1 = *rho * 2., abs(d__1)); + i__1 = *n; + for (i__ = *cutpnt + 1; i__ <= i__1; ++i__) { + indxq[i__] += *cutpnt; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dlamda[i__] = d__[indxq[i__]]; + w[i__] = z__[indxq[i__]]; + } + i__ = 1; + j = *cutpnt + 1; + dlamrg_(&n1, &n2, &dlamda[1], &c__1, &c__1, &indx[1]); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = dlamda[indx[i__]]; + z__[i__] = w[indx[i__]]; + } + imax = idamax_(n, &z__[1], &c__1); + jmax = idamax_(n, &d__[1], &c__1); + eps = dlamch_((char *)"Epsilon", (ftnlen)7); + tol = eps * 8. * (d__1 = d__[jmax], abs(d__1)); + if (*rho * (d__1 = z__[imax], abs(d__1)) <= tol) { + *k = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + perm[j] = indxq[indx[j]]; + zcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1], &c__1); + } + zlacpy_((char *)"A", qsiz, n, &q2[q2_dim1 + 1], ldq2, &q[q_dim1 + 1], ldq, (ftnlen)1); + return 0; + } + *k = 0; + k2 = *n + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*rho * (d__1 = z__[j], abs(d__1)) <= tol) { + --k2; + indxp[k2] = j; + if (j == *n) { + goto L100; + } + } else { + jlam = j; + goto L70; + } + } +L70: + ++j; + if (j > *n) { + goto L90; + } + if (*rho * (d__1 = z__[j], abs(d__1)) <= tol) { + --k2; + indxp[k2] = j; + } else { + s = z__[jlam]; + c__ = z__[j]; + tau = dlapy2_(&c__, &s); + t = d__[j] - d__[jlam]; + c__ /= tau; + s = -s / tau; + if ((d__1 = t * c__ * s, abs(d__1)) <= tol) { + z__[j] = tau; + z__[jlam] = 0.; + ++(*givptr); + givcol[(*givptr << 1) + 1] = indxq[indx[jlam]]; + givcol[(*givptr << 1) + 2] = indxq[indx[j]]; + givnum[(*givptr << 1) + 1] = c__; + givnum[(*givptr << 1) + 2] = s; + zdrot_(qsiz, &q[indxq[indx[jlam]] * q_dim1 + 1], &c__1, &q[indxq[indx[j]] * q_dim1 + 1], + &c__1, &c__, &s); + t = d__[jlam] * c__ * c__ + d__[j] * s * s; + d__[j] = d__[jlam] * s * s + d__[j] * c__ * c__; + d__[jlam] = t; + --k2; + i__ = 1; + L80: + if (k2 + i__ <= *n) { + if (d__[jlam] < d__[indxp[k2 + i__]]) { + indxp[k2 + i__ - 1] = indxp[k2 + i__]; + indxp[k2 + i__] = jlam; + ++i__; + goto L80; + } else { + indxp[k2 + i__ - 1] = jlam; + } + } else { + indxp[k2 + i__ - 1] = jlam; + } + jlam = j; + } else { + ++(*k); + w[*k] = z__[jlam]; + dlamda[*k] = d__[jlam]; + indxp[*k] = jlam; + jlam = j; + } + } + goto L70; +L90: + ++(*k); + w[*k] = z__[jlam]; + dlamda[*k] = d__[jlam]; + indxp[*k] = jlam; +L100: + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + jp = indxp[j]; + dlamda[j] = d__[jp]; + perm[j] = indxq[indx[jp]]; + zcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1], &c__1); + } + if (*k < *n) { + i__1 = *n - *k; + dcopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1); + i__1 = *n - *k; + zlacpy_((char *)"A", qsiz, &i__1, &q2[(*k + 1) * q2_dim1 + 1], ldq2, &q[(*k + 1) * q_dim1 + 1], ldq, + (ftnlen)1); + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zlaed8.f b/lib/linalg/zlaed8.f deleted file mode 100644 index 995a673de9..0000000000 --- a/lib/linalg/zlaed8.f +++ /dev/null @@ -1,483 +0,0 @@ -*> \brief \b ZLAED8 used by ZSTEDC. Merges eigenvalues and deflates secular equation. Used when the original matrix is dense. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLAED8 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z, DLAMDA, -* Q2, LDQ2, W, INDXP, INDX, INDXQ, PERM, GIVPTR, -* GIVCOL, GIVNUM, INFO ) -* -* .. Scalar Arguments .. -* INTEGER CUTPNT, GIVPTR, INFO, K, LDQ, LDQ2, N, QSIZ -* DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. -* INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ), -* $ INDXQ( * ), PERM( * ) -* DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ), W( * ), -* $ Z( * ) -* COMPLEX*16 Q( LDQ, * ), Q2( LDQ2, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLAED8 merges the two sets of eigenvalues together into a single -*> sorted set. Then it tries to deflate the size of the problem. -*> There are two ways in which deflation can occur: when two or more -*> eigenvalues are close together or if there is a tiny element in the -*> Z vector. For each such occurrence the order of the related secular -*> equation problem is reduced by one. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[out] K -*> \verbatim -*> K is INTEGER -*> Contains the number of non-deflated eigenvalues. -*> This is the order of the related secular equation. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The dimension of the symmetric tridiagonal matrix. N >= 0. -*> \endverbatim -*> -*> \param[in] QSIZ -*> \verbatim -*> QSIZ is INTEGER -*> The dimension of the unitary matrix used to reduce -*> the dense or band matrix to tridiagonal form. -*> QSIZ >= N if ICOMPQ = 1. -*> \endverbatim -*> -*> \param[in,out] Q -*> \verbatim -*> Q is COMPLEX*16 array, dimension (LDQ,N) -*> On entry, Q contains the eigenvectors of the partially solved -*> system which has been previously updated in matrix -*> multiplies with other partially solved eigensystems. -*> On exit, Q contains the trailing (N-K) updated eigenvectors -*> (those which were deflated) in its last N-K columns. -*> \endverbatim -*> -*> \param[in] LDQ -*> \verbatim -*> LDQ is INTEGER -*> The leading dimension of the array Q. LDQ >= max( 1, N ). -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, D contains the eigenvalues of the two submatrices to -*> be combined. On exit, D contains the trailing (N-K) updated -*> eigenvalues (those which were deflated) sorted into increasing -*> order. -*> \endverbatim -*> -*> \param[in,out] RHO -*> \verbatim -*> RHO is DOUBLE PRECISION -*> Contains the off diagonal element associated with the rank-1 -*> cut which originally split the two submatrices which are now -*> being recombined. RHO is modified during the computation to -*> the value required by DLAED3. -*> \endverbatim -*> -*> \param[in] CUTPNT -*> \verbatim -*> CUTPNT is INTEGER -*> Contains the location of the last eigenvalue in the leading -*> sub-matrix. MIN(1,N) <= CUTPNT <= N. -*> \endverbatim -*> -*> \param[in] Z -*> \verbatim -*> Z is DOUBLE PRECISION array, dimension (N) -*> On input this vector contains the updating vector (the last -*> row of the first sub-eigenvector matrix and the first row of -*> the second sub-eigenvector matrix). The contents of Z are -*> destroyed during the updating process. -*> \endverbatim -*> -*> \param[out] DLAMDA -*> \verbatim -*> DLAMDA is DOUBLE PRECISION array, dimension (N) -*> Contains a copy of the first K eigenvalues which will be used -*> by DLAED3 to form the secular equation. -*> \endverbatim -*> -*> \param[out] Q2 -*> \verbatim -*> Q2 is COMPLEX*16 array, dimension (LDQ2,N) -*> If ICOMPQ = 0, Q2 is not referenced. Otherwise, -*> Contains a copy of the first K eigenvectors which will be used -*> by DLAED7 in a matrix multiply (DGEMM) to update the new -*> eigenvectors. -*> \endverbatim -*> -*> \param[in] LDQ2 -*> \verbatim -*> LDQ2 is INTEGER -*> The leading dimension of the array Q2. LDQ2 >= max( 1, N ). -*> \endverbatim -*> -*> \param[out] W -*> \verbatim -*> W is DOUBLE PRECISION array, dimension (N) -*> This will hold the first k values of the final -*> deflation-altered z-vector and will be passed to DLAED3. -*> \endverbatim -*> -*> \param[out] INDXP -*> \verbatim -*> INDXP is INTEGER array, dimension (N) -*> This will contain the permutation used to place deflated -*> values of D at the end of the array. On output INDXP(1:K) -*> points to the nondeflated D-values and INDXP(K+1:N) -*> points to the deflated eigenvalues. -*> \endverbatim -*> -*> \param[out] INDX -*> \verbatim -*> INDX is INTEGER array, dimension (N) -*> This will contain the permutation used to sort the contents of -*> D into ascending order. -*> \endverbatim -*> -*> \param[in] INDXQ -*> \verbatim -*> INDXQ is INTEGER array, dimension (N) -*> This contains the permutation which separately sorts the two -*> sub-problems in D into ascending order. Note that elements in -*> the second half of this permutation must first have CUTPNT -*> added to their values in order to be accurate. -*> \endverbatim -*> -*> \param[out] PERM -*> \verbatim -*> PERM is INTEGER array, dimension (N) -*> Contains the permutations (from deflation and sorting) to be -*> applied to each eigenblock. -*> \endverbatim -*> -*> \param[out] GIVPTR -*> \verbatim -*> GIVPTR is INTEGER -*> Contains the number of Givens rotations which took place in -*> this subproblem. -*> \endverbatim -*> -*> \param[out] GIVCOL -*> \verbatim -*> GIVCOL is INTEGER array, dimension (2, N) -*> Each pair of numbers indicates a pair of columns to take place -*> in a Givens rotation. -*> \endverbatim -*> -*> \param[out] GIVNUM -*> \verbatim -*> GIVNUM is DOUBLE PRECISION array, dimension (2, N) -*> Each number indicates the S value to be used in the -*> corresponding Givens rotation. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit. -*> < 0: if INFO = -i, the i-th argument had an illegal value. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z, DLAMDA, - $ Q2, LDQ2, W, INDXP, INDX, INDXQ, PERM, GIVPTR, - $ GIVCOL, GIVNUM, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER CUTPNT, GIVPTR, INFO, K, LDQ, LDQ2, N, QSIZ - DOUBLE PRECISION RHO -* .. -* .. Array Arguments .. - INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ), - $ INDXQ( * ), PERM( * ) - DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ), W( * ), - $ Z( * ) - COMPLEX*16 Q( LDQ, * ), Q2( LDQ2, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT - PARAMETER ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0, - $ TWO = 2.0D0, EIGHT = 8.0D0 ) -* .. -* .. Local Scalars .. - INTEGER I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2 - DOUBLE PRECISION C, EPS, S, T, TAU, TOL -* .. -* .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH, DLAPY2 - EXTERNAL IDAMAX, DLAMCH, DLAPY2 -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DLAMRG, DSCAL, XERBLA, ZCOPY, ZDROT, - $ ZLACPY -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( QSIZ.LT.N ) THEN - INFO = -3 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN - INFO = -8 - ELSE IF( LDQ2.LT.MAX( 1, N ) ) THEN - INFO = -12 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZLAED8', -INFO ) - RETURN - END IF -* -* Need to initialize GIVPTR to O here in case of quick exit -* to prevent an unspecified code behavior (usually sigfault) -* when IWORK array on entry to *stedc is not zeroed -* (or at least some IWORK entries which used in *laed7 for GIVPTR). -* - GIVPTR = 0 -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - N1 = CUTPNT - N2 = N - N1 - N1P1 = N1 + 1 -* - IF( RHO.LT.ZERO ) THEN - CALL DSCAL( N2, MONE, Z( N1P1 ), 1 ) - END IF -* -* Normalize z so that norm(z) = 1 -* - T = ONE / SQRT( TWO ) - DO 10 J = 1, N - INDX( J ) = J - 10 CONTINUE - CALL DSCAL( N, T, Z, 1 ) - RHO = ABS( TWO*RHO ) -* -* Sort the eigenvalues into increasing order -* - DO 20 I = CUTPNT + 1, N - INDXQ( I ) = INDXQ( I ) + CUTPNT - 20 CONTINUE - DO 30 I = 1, N - DLAMDA( I ) = D( INDXQ( I ) ) - W( I ) = Z( INDXQ( I ) ) - 30 CONTINUE - I = 1 - J = CUTPNT + 1 - CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDX ) - DO 40 I = 1, N - D( I ) = DLAMDA( INDX( I ) ) - Z( I ) = W( INDX( I ) ) - 40 CONTINUE -* -* Calculate the allowable deflation tolerance -* - IMAX = IDAMAX( N, Z, 1 ) - JMAX = IDAMAX( N, D, 1 ) - EPS = DLAMCH( 'Epsilon' ) - TOL = EIGHT*EPS*ABS( D( JMAX ) ) -* -* If the rank-1 modifier is small enough, no more needs to be done -* -- except to reorganize Q so that its columns correspond with the -* elements in D. -* - IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN - K = 0 - DO 50 J = 1, N - PERM( J ) = INDXQ( INDX( J ) ) - CALL ZCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 ) - 50 CONTINUE - CALL ZLACPY( 'A', QSIZ, N, Q2( 1, 1 ), LDQ2, Q( 1, 1 ), LDQ ) - RETURN - END IF -* -* If there are multiple eigenvalues then the problem deflates. Here -* the number of equal eigenvalues are found. As each equal -* eigenvalue is found, an elementary reflector is computed to rotate -* the corresponding eigensubspace so that the corresponding -* components of Z are zero in this new basis. -* - K = 0 - K2 = N + 1 - DO 60 J = 1, N - IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN -* -* Deflate due to small z component. -* - K2 = K2 - 1 - INDXP( K2 ) = J - IF( J.EQ.N ) - $ GO TO 100 - ELSE - JLAM = J - GO TO 70 - END IF - 60 CONTINUE - 70 CONTINUE - J = J + 1 - IF( J.GT.N ) - $ GO TO 90 - IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN -* -* Deflate due to small z component. -* - K2 = K2 - 1 - INDXP( K2 ) = J - ELSE -* -* Check if eigenvalues are close enough to allow deflation. -* - S = Z( JLAM ) - C = Z( J ) -* -* Find sqrt(a**2+b**2) without overflow or -* destructive underflow. -* - TAU = DLAPY2( C, S ) - T = D( J ) - D( JLAM ) - C = C / TAU - S = -S / TAU - IF( ABS( T*C*S ).LE.TOL ) THEN -* -* Deflation is possible. -* - Z( J ) = TAU - Z( JLAM ) = ZERO -* -* Record the appropriate Givens rotation -* - GIVPTR = GIVPTR + 1 - GIVCOL( 1, GIVPTR ) = INDXQ( INDX( JLAM ) ) - GIVCOL( 2, GIVPTR ) = INDXQ( INDX( J ) ) - GIVNUM( 1, GIVPTR ) = C - GIVNUM( 2, GIVPTR ) = S - CALL ZDROT( QSIZ, Q( 1, INDXQ( INDX( JLAM ) ) ), 1, - $ Q( 1, INDXQ( INDX( J ) ) ), 1, C, S ) - T = D( JLAM )*C*C + D( J )*S*S - D( J ) = D( JLAM )*S*S + D( J )*C*C - D( JLAM ) = T - K2 = K2 - 1 - I = 1 - 80 CONTINUE - IF( K2+I.LE.N ) THEN - IF( D( JLAM ).LT.D( INDXP( K2+I ) ) ) THEN - INDXP( K2+I-1 ) = INDXP( K2+I ) - INDXP( K2+I ) = JLAM - I = I + 1 - GO TO 80 - ELSE - INDXP( K2+I-1 ) = JLAM - END IF - ELSE - INDXP( K2+I-1 ) = JLAM - END IF - JLAM = J - ELSE - K = K + 1 - W( K ) = Z( JLAM ) - DLAMDA( K ) = D( JLAM ) - INDXP( K ) = JLAM - JLAM = J - END IF - END IF - GO TO 70 - 90 CONTINUE -* -* Record the last eigenvalue. -* - K = K + 1 - W( K ) = Z( JLAM ) - DLAMDA( K ) = D( JLAM ) - INDXP( K ) = JLAM -* - 100 CONTINUE -* -* Sort the eigenvalues and corresponding eigenvectors into DLAMDA -* and Q2 respectively. The eigenvalues/vectors which were not -* deflated go into the first K slots of DLAMDA and Q2 respectively, -* while those which were deflated go into the last N - K slots. -* - DO 110 J = 1, N - JP = INDXP( J ) - DLAMDA( J ) = D( JP ) - PERM( J ) = INDXQ( INDX( JP ) ) - CALL ZCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 ) - 110 CONTINUE -* -* The deflated eigenvalues and their corresponding vectors go back -* into the last N - K slots of D and Q respectively. -* - IF( K.LT.N ) THEN - CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 ) - CALL ZLACPY( 'A', QSIZ, N-K, Q2( 1, K+1 ), LDQ2, Q( 1, K+1 ), - $ LDQ ) - END IF -* - RETURN -* -* End of ZLAED8 -* - END diff --git a/lib/linalg/zlanhe.cpp b/lib/linalg/zlanhe.cpp new file mode 100644 index 0000000000..e0538d3084 --- /dev/null +++ b/lib/linalg/zlanhe.cpp @@ -0,0 +1,142 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +doublereal zlanhe_(char *norm, char *uplo, integer *n, doublecomplex *a, integer *lda, + doublereal *work, ftnlen norm_len, ftnlen uplo_len) +{ + integer a_dim1, a_offset, i__1, i__2; + doublereal ret_val, d__1; + double z_lmp_abs(doublecomplex *), sqrt(doublereal); + integer i__, j; + doublereal sum, absa, scale; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + doublereal value; + extern logical disnan_(doublereal *); + extern int zlassq_(integer *, doublecomplex *, integer *, doublereal *, doublereal *); + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --work; + if (*n == 0) { + value = 0.; + } else if (lsame_(norm, (char *)"M", (ftnlen)1, (ftnlen)1)) { + value = 0.; + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + sum = z_lmp_abs(&a[i__ + j * a_dim1]); + if (value < sum || disnan_(&sum)) { + value = sum; + } + } + i__2 = j + j * a_dim1; + sum = (d__1 = a[i__2].r, abs(d__1)); + if (value < sum || disnan_(&sum)) { + value = sum; + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j + j * a_dim1; + sum = (d__1 = a[i__2].r, abs(d__1)); + if (value < sum || disnan_(&sum)) { + value = sum; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + sum = z_lmp_abs(&a[i__ + j * a_dim1]); + if (value < sum || disnan_(&sum)) { + value = sum; + } + } + } + } + } else if (lsame_(norm, (char *)"I", (ftnlen)1, (ftnlen)1) || lsame_(norm, (char *)"O", (ftnlen)1, (ftnlen)1) || + *(unsigned char *)norm == '1') { + value = 0.; + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = 0.; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + absa = z_lmp_abs(&a[i__ + j * a_dim1]); + sum += absa; + work[i__] += absa; + } + i__2 = j + j * a_dim1; + work[j] = sum + (d__1 = a[i__2].r, abs(d__1)); + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = work[i__]; + if (value < sum || disnan_(&sum)) { + value = sum; + } + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j + j * a_dim1; + sum = work[j] + (d__1 = a[i__2].r, abs(d__1)); + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + absa = z_lmp_abs(&a[i__ + j * a_dim1]); + sum += absa; + work[i__] += absa; + } + if (value < sum || disnan_(&sum)) { + value = sum; + } + } + } + } else if (lsame_(norm, (char *)"F", (ftnlen)1, (ftnlen)1) || lsame_(norm, (char *)"E", (ftnlen)1, (ftnlen)1)) { + scale = 0.; + sum = 1.; + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + i__2 = j - 1; + zlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum); + } + } else { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = *n - j; + zlassq_(&i__2, &a[j + 1 + j * a_dim1], &c__1, &scale, &sum); + } + } + sum *= 2; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * a_dim1; + if (a[i__2].r != 0.) { + i__2 = i__ + i__ * a_dim1; + absa = (d__1 = a[i__2].r, abs(d__1)); + if (scale < absa) { + d__1 = scale / absa; + sum = sum * (d__1 * d__1) + 1.; + scale = absa; + } else { + d__1 = absa / scale; + sum += d__1 * d__1; + } + } + } + value = scale * sqrt(sum); + } + ret_val = value; + return ret_val; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zlanhe.f b/lib/linalg/zlanhe.f deleted file mode 100644 index bbb4843ffd..0000000000 --- a/lib/linalg/zlanhe.f +++ /dev/null @@ -1,255 +0,0 @@ -*> \brief \b ZLANHE returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a complex Hermitian matrix. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLANHE + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK ) -* -* .. Scalar Arguments .. -* CHARACTER NORM, UPLO -* INTEGER LDA, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION WORK( * ) -* COMPLEX*16 A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLANHE returns the value of the one norm, or the Frobenius norm, or -*> the infinity norm, or the element of largest absolute value of a -*> complex hermitian matrix A. -*> \endverbatim -*> -*> \return ZLANHE -*> \verbatim -*> -*> ZLANHE = ( max(abs(A(i,j))), NORM = 'M' or 'm' -*> ( -*> ( norm1(A), NORM = '1', 'O' or 'o' -*> ( -*> ( normI(A), NORM = 'I' or 'i' -*> ( -*> ( normF(A), NORM = 'F', 'f', 'E' or 'e' -*> -*> where norm1 denotes the one norm of a matrix (maximum column sum), -*> normI denotes the infinity norm of a matrix (maximum row sum) and -*> normF denotes the Frobenius norm of a matrix (square root of sum of -*> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] NORM -*> \verbatim -*> NORM is CHARACTER*1 -*> Specifies the value to be returned in ZLANHE as described -*> above. -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> Specifies whether the upper or lower triangular part of the -*> hermitian matrix A is to be referenced. -*> = 'U': Upper triangular part of A is referenced -*> = 'L': Lower triangular part of A is referenced -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. When N = 0, ZLANHE is -*> set to zero. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,N) -*> The hermitian matrix A. If UPLO = 'U', the leading n by n -*> upper triangular part of A contains the upper triangular part -*> of the matrix A, and the strictly lower triangular part of A -*> is not referenced. If UPLO = 'L', the leading n by n lower -*> triangular part of A contains the lower triangular part of -*> the matrix A, and the strictly upper triangular part of A is -*> not referenced. Note that the imaginary parts of the diagonal -*> elements need not be set and are assumed to be zero. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(N,1). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), -*> where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, -*> WORK is not referenced. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16HEauxiliary -* -* ===================================================================== - DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER NORM, UPLO - INTEGER LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION WORK( * ) - COMPLEX*16 A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J - DOUBLE PRECISION ABSA, SCALE, SUM, VALUE -* .. -* .. External Functions .. - LOGICAL LSAME, DISNAN - EXTERNAL LSAME, DISNAN -* .. -* .. External Subroutines .. - EXTERNAL ZLASSQ -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, SQRT -* .. -* .. Executable Statements .. -* - IF( N.EQ.0 ) THEN - VALUE = ZERO - ELSE IF( LSAME( NORM, 'M' ) ) THEN -* -* Find max(abs(A(i,j))). -* - VALUE = ZERO - IF( LSAME( UPLO, 'U' ) ) THEN - DO 20 J = 1, N - DO 10 I = 1, J - 1 - SUM = ABS( A( I, J ) ) - IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM - 10 CONTINUE - SUM = ABS( DBLE( A( J, J ) ) ) - IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM - 20 CONTINUE - ELSE - DO 40 J = 1, N - SUM = ABS( DBLE( A( J, J ) ) ) - IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM - DO 30 I = J + 1, N - SUM = ABS( A( I, J ) ) - IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM - 30 CONTINUE - 40 CONTINUE - END IF - ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. - $ ( NORM.EQ.'1' ) ) THEN -* -* Find normI(A) ( = norm1(A), since A is hermitian). -* - VALUE = ZERO - IF( LSAME( UPLO, 'U' ) ) THEN - DO 60 J = 1, N - SUM = ZERO - DO 50 I = 1, J - 1 - ABSA = ABS( A( I, J ) ) - SUM = SUM + ABSA - WORK( I ) = WORK( I ) + ABSA - 50 CONTINUE - WORK( J ) = SUM + ABS( DBLE( A( J, J ) ) ) - 60 CONTINUE - DO 70 I = 1, N - SUM = WORK( I ) - IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM - 70 CONTINUE - ELSE - DO 80 I = 1, N - WORK( I ) = ZERO - 80 CONTINUE - DO 100 J = 1, N - SUM = WORK( J ) + ABS( DBLE( A( J, J ) ) ) - DO 90 I = J + 1, N - ABSA = ABS( A( I, J ) ) - SUM = SUM + ABSA - WORK( I ) = WORK( I ) + ABSA - 90 CONTINUE - IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM - 100 CONTINUE - END IF - ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN -* -* Find normF(A). -* - SCALE = ZERO - SUM = ONE - IF( LSAME( UPLO, 'U' ) ) THEN - DO 110 J = 2, N - CALL ZLASSQ( J-1, A( 1, J ), 1, SCALE, SUM ) - 110 CONTINUE - ELSE - DO 120 J = 1, N - 1 - CALL ZLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM ) - 120 CONTINUE - END IF - SUM = 2*SUM - DO 130 I = 1, N - IF( DBLE( A( I, I ) ).NE.ZERO ) THEN - ABSA = ABS( DBLE( A( I, I ) ) ) - IF( SCALE.LT.ABSA ) THEN - SUM = ONE + SUM*( SCALE / ABSA )**2 - SCALE = ABSA - ELSE - SUM = SUM + ( ABSA / SCALE )**2 - END IF - END IF - 130 CONTINUE - VALUE = SCALE*SQRT( SUM ) - END IF -* - ZLANHE = VALUE - RETURN -* -* End of ZLANHE -* - END diff --git a/lib/linalg/zlarf.cpp b/lib/linalg/zlarf.cpp new file mode 100644 index 0000000000..7f7468bcf9 --- /dev/null +++ b/lib/linalg/zlarf.cpp @@ -0,0 +1,74 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static doublecomplex c_b1 = {1., 0.}; +static doublecomplex c_b2 = {0., 0.}; +static integer c__1 = 1; +int zlarf_(char *side, integer *m, integer *n, doublecomplex *v, integer *incv, doublecomplex *tau, + doublecomplex *c__, integer *ldc, doublecomplex *work, ftnlen side_len) +{ + integer c_dim1, c_offset, i__1; + doublecomplex z__1; + integer i__; + logical applyleft; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + integer lastc; + extern int zgerc_(integer *, integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *), + zgemv_(char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, ftnlen); + integer lastv; + extern integer ilazlc_(integer *, integer *, doublecomplex *, integer *), + ilazlr_(integer *, integer *, doublecomplex *, integer *); + --v; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --work; + applyleft = lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1); + lastv = 0; + lastc = 0; + if (tau->r != 0. || tau->i != 0.) { + if (applyleft) { + lastv = *m; + } else { + lastv = *n; + } + if (*incv > 0) { + i__ = (lastv - 1) * *incv + 1; + } else { + i__ = 1; + } + for (;;) { + i__1 = i__; + if (!(lastv > 0 && (v[i__1].r == 0. && v[i__1].i == 0.))) break; + --lastv; + i__ -= *incv; + } + if (applyleft) { + lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc); + } else { + lastc = ilazlr_(m, &lastv, &c__[c_offset], ldc); + } + } + if (applyleft) { + if (lastv > 0) { + zgemv_((char *)"Conjugate transpose", &lastv, &lastc, &c_b1, &c__[c_offset], ldc, &v[1], incv, + &c_b2, &work[1], &c__1, (ftnlen)19); + z__1.r = -tau->r, z__1.i = -tau->i; + zgerc_(&lastv, &lastc, &z__1, &v[1], incv, &work[1], &c__1, &c__[c_offset], ldc); + } + } else { + if (lastv > 0) { + zgemv_((char *)"No transpose", &lastc, &lastv, &c_b1, &c__[c_offset], ldc, &v[1], incv, &c_b2, + &work[1], &c__1, (ftnlen)12); + z__1.r = -tau->r, z__1.i = -tau->i; + zgerc_(&lastc, &lastv, &z__1, &work[1], &c__1, &v[1], incv, &c__[c_offset], ldc); + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zlarf.f b/lib/linalg/zlarf.f deleted file mode 100644 index e555d18ecd..0000000000 --- a/lib/linalg/zlarf.f +++ /dev/null @@ -1,229 +0,0 @@ -*> \brief \b ZLARF applies an elementary reflector to a general rectangular matrix. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLARF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) -* -* .. Scalar Arguments .. -* CHARACTER SIDE -* INTEGER INCV, LDC, M, N -* COMPLEX*16 TAU -* .. -* .. Array Arguments .. -* COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLARF applies a complex elementary reflector H to a complex M-by-N -*> matrix C, from either the left or the right. H is represented in the -*> form -*> -*> H = I - tau * v * v**H -*> -*> where tau is a complex scalar and v is a complex vector. -*> -*> If tau = 0, then H is taken to be the unit matrix. -*> -*> To apply H**H, supply conjg(tau) instead -*> tau. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': form H * C -*> = 'R': form C * H -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. -*> \endverbatim -*> -*> \param[in] V -*> \verbatim -*> V is COMPLEX*16 array, dimension -*> (1 + (M-1)*abs(INCV)) if SIDE = 'L' -*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R' -*> The vector v in the representation of H. V is not used if -*> TAU = 0. -*> \endverbatim -*> -*> \param[in] INCV -*> \verbatim -*> INCV is INTEGER -*> The increment between elements of v. INCV <> 0. -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is COMPLEX*16 -*> The value tau in the representation of H. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is COMPLEX*16 array, dimension (LDC,N) -*> On entry, the M-by-N matrix C. -*> On exit, C is overwritten by the matrix H * C if SIDE = 'L', -*> or C * H if SIDE = 'R'. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 array, dimension -*> (N) if SIDE = 'L' -*> or (M) if SIDE = 'R' -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERauxiliary -* -* ===================================================================== - SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER SIDE - INTEGER INCV, LDC, M, N - COMPLEX*16 TAU -* .. -* .. Array Arguments .. - COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE, ZERO - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL APPLYLEFT - INTEGER I, LASTV, LASTC -* .. -* .. External Subroutines .. - EXTERNAL ZGEMV, ZGERC -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAZLR, ILAZLC - EXTERNAL LSAME, ILAZLR, ILAZLC -* .. -* .. Executable Statements .. -* - APPLYLEFT = LSAME( SIDE, 'L' ) - LASTV = 0 - LASTC = 0 - IF( TAU.NE.ZERO ) THEN -* Set up variables for scanning V. LASTV begins pointing to the end -* of V. - IF( APPLYLEFT ) THEN - LASTV = M - ELSE - LASTV = N - END IF - IF( INCV.GT.0 ) THEN - I = 1 + (LASTV-1) * INCV - ELSE - I = 1 - END IF -* Look for the last non-zero row in V. - DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) - LASTV = LASTV - 1 - I = I - INCV - END DO - IF( APPLYLEFT ) THEN -* Scan for the last non-zero column in C(1:lastv,:). - LASTC = ILAZLC(LASTV, N, C, LDC) - ELSE -* Scan for the last non-zero row in C(:,1:lastv). - LASTC = ILAZLR(M, LASTV, C, LDC) - END IF - END IF -* Note that lastc.eq.0 renders the BLAS operations null; no special -* case is needed at this level. - IF( APPLYLEFT ) THEN -* -* Form H * C -* - IF( LASTV.GT.0 ) THEN -* -* w(1:lastc,1) := C(1:lastv,1:lastc)**H * v(1:lastv,1) -* - CALL ZGEMV( 'Conjugate transpose', LASTV, LASTC, ONE, - $ C, LDC, V, INCV, ZERO, WORK, 1 ) -* -* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**H -* - CALL ZGERC( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC ) - END IF - ELSE -* -* Form C * H -* - IF( LASTV.GT.0 ) THEN -* -* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) -* - CALL ZGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC, - $ V, INCV, ZERO, WORK, 1 ) -* -* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**H -* - CALL ZGERC( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC ) - END IF - END IF - RETURN -* -* End of ZLARF -* - END diff --git a/lib/linalg/zlarfb.cpp b/lib/linalg/zlarfb.cpp new file mode 100644 index 0000000000..6b0d62e99f --- /dev/null +++ b/lib/linalg/zlarfb.cpp @@ -0,0 +1,362 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static doublecomplex c_b1 = {1., 0.}; +static integer c__1 = 1; +int zlarfb_(char *side, char *trans, char *direct, char *storev, integer *m, integer *n, integer *k, + doublecomplex *v, integer *ldv, doublecomplex *t, integer *ldt, doublecomplex *c__, + integer *ldc, doublecomplex *work, integer *ldwork, ftnlen side_len, ftnlen trans_len, + ftnlen direct_len, ftnlen storev_len) +{ + integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, work_offset, i__1, + i__2, i__3, i__4, i__5; + doublecomplex z__1, z__2; + void d_lmp_cnjg(doublecomplex *, doublecomplex *); + integer i__, j; + 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), + zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), + ztrmm_(char *, char *, char *, char *, integer *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, ftnlen, ftnlen, ftnlen, + ftnlen), + zlacgv_(integer *, doublecomplex *, integer *); + char transt[1]; + v_dim1 = *ldv; + v_offset = 1 + v_dim1; + v -= v_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + work_dim1 = *ldwork; + work_offset = 1 + work_dim1; + work -= work_offset; + if (*m <= 0 || *n <= 0) { + return 0; + } + if (lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1)) { + *(unsigned char *)transt = 'C'; + } else { + *(unsigned char *)transt = 'N'; + } + if (lsame_(storev, (char *)"C", (ftnlen)1, (ftnlen)1)) { + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); + zlacgv_(n, &work[j * work_dim1 + 1], &c__1); + } + ztrmm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", n, k, &c_b1, &v[v_offset], ldv, + &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); + if (*m > *k) { + i__1 = *m - *k; + zgemm_((char *)"Conjugate transpose", (char *)"No transpose", n, k, &i__1, &c_b1, + &c__[*k + 1 + c_dim1], ldc, &v[*k + 1 + v_dim1], ldv, &c_b1, + &work[work_offset], ldwork, (ftnlen)19, (ftnlen)12); + } + ztrmm_((char *)"Right", (char *)"Upper", transt, (char *)"Non-unit", n, k, &c_b1, &t[t_offset], ldt, + &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)1, (ftnlen)8); + if (*m > *k) { + i__1 = *m - *k; + z__1.r = -1., z__1.i = -0.; + zgemm_((char *)"No transpose", (char *)"Conjugate transpose", &i__1, n, k, &z__1, + &v[*k + 1 + v_dim1], ldv, &work[work_offset], ldwork, &c_b1, + &c__[*k + 1 + c_dim1], ldc, (ftnlen)12, (ftnlen)19); + } + ztrmm_((char *)"Right", (char *)"Lower", (char *)"Conjugate transpose", (char *)"Unit", n, k, &c_b1, &v[v_offset], + ldv, &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)19, + (ftnlen)4); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = j + i__ * c_dim1; + i__4 = j + i__ * c_dim1; + d_lmp_cnjg(&z__2, &work[i__ + j * work_dim1]); + 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; + } + } + } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &c__1); + } + ztrmm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", m, k, &c_b1, &v[v_offset], ldv, + &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); + if (*n > *k) { + i__1 = *n - *k; + zgemm_((char *)"No transpose", (char *)"No transpose", m, k, &i__1, &c_b1, + &c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k + 1 + v_dim1], ldv, &c_b1, + &work[work_offset], ldwork, (ftnlen)12, (ftnlen)12); + } + ztrmm_((char *)"Right", (char *)"Upper", trans, (char *)"Non-unit", m, k, &c_b1, &t[t_offset], ldt, + &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)1, (ftnlen)8); + if (*n > *k) { + i__1 = *n - *k; + z__1.r = -1., z__1.i = -0.; + zgemm_((char *)"No transpose", (char *)"Conjugate transpose", m, &i__1, k, &z__1, + &work[work_offset], ldwork, &v[*k + 1 + v_dim1], ldv, &c_b1, + &c__[(*k + 1) * c_dim1 + 1], ldc, (ftnlen)12, (ftnlen)19); + } + ztrmm_((char *)"Right", (char *)"Lower", (char *)"Conjugate transpose", (char *)"Unit", m, k, &c_b1, &v[v_offset], + ldv, &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)19, + (ftnlen)4); + i__1 = *k; + 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; + i__5 = i__ + j * work_dim1; + z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[i__4].i - work[i__5].i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } + } + } + } else { + if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); + zlacgv_(n, &work[j * work_dim1 + 1], &c__1); + } + ztrmm_((char *)"Right", (char *)"Upper", (char *)"No transpose", (char *)"Unit", n, k, &c_b1, + &v[*m - *k + 1 + v_dim1], ldv, &work[work_offset], ldwork, (ftnlen)5, + (ftnlen)5, (ftnlen)12, (ftnlen)4); + if (*m > *k) { + i__1 = *m - *k; + zgemm_((char *)"Conjugate transpose", (char *)"No transpose", n, k, &i__1, &c_b1, + &c__[c_offset], ldc, &v[v_offset], ldv, &c_b1, &work[work_offset], + ldwork, (ftnlen)19, (ftnlen)12); + } + ztrmm_((char *)"Right", (char *)"Lower", transt, (char *)"Non-unit", n, k, &c_b1, &t[t_offset], ldt, + &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)1, (ftnlen)8); + if (*m > *k) { + i__1 = *m - *k; + z__1.r = -1., z__1.i = -0.; + zgemm_((char *)"No transpose", (char *)"Conjugate transpose", &i__1, n, k, &z__1, &v[v_offset], + ldv, &work[work_offset], ldwork, &c_b1, &c__[c_offset], ldc, (ftnlen)12, + (ftnlen)19); + } + ztrmm_((char *)"Right", (char *)"Upper", (char *)"Conjugate transpose", (char *)"Unit", n, k, &c_b1, + &v[*m - *k + 1 + v_dim1], ldv, &work[work_offset], ldwork, (ftnlen)5, + (ftnlen)5, (ftnlen)19, (ftnlen)4); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = *m - *k + j + i__ * c_dim1; + i__4 = *m - *k + j + i__ * c_dim1; + d_lmp_cnjg(&z__2, &work[i__ + j * work_dim1]); + 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; + } + } + } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], + &c__1); + } + ztrmm_((char *)"Right", (char *)"Upper", (char *)"No transpose", (char *)"Unit", m, k, &c_b1, + &v[*n - *k + 1 + v_dim1], ldv, &work[work_offset], ldwork, (ftnlen)5, + (ftnlen)5, (ftnlen)12, (ftnlen)4); + if (*n > *k) { + i__1 = *n - *k; + zgemm_((char *)"No transpose", (char *)"No transpose", m, k, &i__1, &c_b1, &c__[c_offset], ldc, + &v[v_offset], ldv, &c_b1, &work[work_offset], ldwork, (ftnlen)12, + (ftnlen)12); + } + ztrmm_((char *)"Right", (char *)"Lower", trans, (char *)"Non-unit", m, k, &c_b1, &t[t_offset], ldt, + &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)1, (ftnlen)8); + if (*n > *k) { + i__1 = *n - *k; + z__1.r = -1., z__1.i = -0.; + zgemm_((char *)"No transpose", (char *)"Conjugate transpose", m, &i__1, k, &z__1, + &work[work_offset], ldwork, &v[v_offset], ldv, &c_b1, &c__[c_offset], + ldc, (ftnlen)12, (ftnlen)19); + } + ztrmm_((char *)"Right", (char *)"Upper", (char *)"Conjugate transpose", (char *)"Unit", m, k, &c_b1, + &v[*n - *k + 1 + v_dim1], ldv, &work[work_offset], ldwork, (ftnlen)5, + (ftnlen)5, (ftnlen)19, (ftnlen)4); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + (*n - *k + j) * c_dim1; + i__4 = i__ + (*n - *k + j) * c_dim1; + i__5 = i__ + j * work_dim1; + z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[i__4].i - work[i__5].i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } + } + } + } + } else if (lsame_(storev, (char *)"R", (ftnlen)1, (ftnlen)1)) { + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); + zlacgv_(n, &work[j * work_dim1 + 1], &c__1); + } + ztrmm_((char *)"Right", (char *)"Upper", (char *)"Conjugate transpose", (char *)"Unit", n, k, &c_b1, &v[v_offset], + ldv, &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)19, + (ftnlen)4); + if (*m > *k) { + i__1 = *m - *k; + zgemm_((char *)"Conjugate transpose", (char *)"Conjugate transpose", n, k, &i__1, &c_b1, + &c__[*k + 1 + c_dim1], ldc, &v[(*k + 1) * v_dim1 + 1], ldv, &c_b1, + &work[work_offset], ldwork, (ftnlen)19, (ftnlen)19); + } + ztrmm_((char *)"Right", (char *)"Upper", transt, (char *)"Non-unit", n, k, &c_b1, &t[t_offset], ldt, + &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)1, (ftnlen)8); + if (*m > *k) { + i__1 = *m - *k; + z__1.r = -1., z__1.i = -0.; + zgemm_((char *)"Conjugate transpose", (char *)"Conjugate transpose", &i__1, n, k, &z__1, + &v[(*k + 1) * v_dim1 + 1], ldv, &work[work_offset], ldwork, &c_b1, + &c__[*k + 1 + c_dim1], ldc, (ftnlen)19, (ftnlen)19); + } + ztrmm_((char *)"Right", (char *)"Upper", (char *)"No transpose", (char *)"Unit", n, k, &c_b1, &v[v_offset], ldv, + &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = j + i__ * c_dim1; + i__4 = j + i__ * c_dim1; + d_lmp_cnjg(&z__2, &work[i__ + j * work_dim1]); + 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; + } + } + } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &c__1); + } + ztrmm_((char *)"Right", (char *)"Upper", (char *)"Conjugate transpose", (char *)"Unit", m, k, &c_b1, &v[v_offset], + ldv, &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)19, + (ftnlen)4); + if (*n > *k) { + i__1 = *n - *k; + zgemm_((char *)"No transpose", (char *)"Conjugate transpose", m, k, &i__1, &c_b1, + &c__[(*k + 1) * c_dim1 + 1], ldc, &v[(*k + 1) * v_dim1 + 1], ldv, &c_b1, + &work[work_offset], ldwork, (ftnlen)12, (ftnlen)19); + } + ztrmm_((char *)"Right", (char *)"Upper", trans, (char *)"Non-unit", m, k, &c_b1, &t[t_offset], ldt, + &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)1, (ftnlen)8); + if (*n > *k) { + i__1 = *n - *k; + z__1.r = -1., z__1.i = -0.; + zgemm_((char *)"No transpose", (char *)"No transpose", m, &i__1, k, &z__1, &work[work_offset], + ldwork, &v[(*k + 1) * v_dim1 + 1], ldv, &c_b1, + &c__[(*k + 1) * c_dim1 + 1], ldc, (ftnlen)12, (ftnlen)12); + } + ztrmm_((char *)"Right", (char *)"Upper", (char *)"No transpose", (char *)"Unit", m, k, &c_b1, &v[v_offset], ldv, + &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)12, (ftnlen)4); + i__1 = *k; + 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; + i__5 = i__ + j * work_dim1; + z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[i__4].i - work[i__5].i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } + } + } + } else { + if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); + zlacgv_(n, &work[j * work_dim1 + 1], &c__1); + } + ztrmm_((char *)"Right", (char *)"Lower", (char *)"Conjugate transpose", (char *)"Unit", n, k, &c_b1, + &v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[work_offset], ldwork, (ftnlen)5, + (ftnlen)5, (ftnlen)19, (ftnlen)4); + if (*m > *k) { + i__1 = *m - *k; + zgemm_((char *)"Conjugate transpose", (char *)"Conjugate transpose", n, k, &i__1, &c_b1, + &c__[c_offset], ldc, &v[v_offset], ldv, &c_b1, &work[work_offset], + ldwork, (ftnlen)19, (ftnlen)19); + } + ztrmm_((char *)"Right", (char *)"Lower", transt, (char *)"Non-unit", n, k, &c_b1, &t[t_offset], ldt, + &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)1, (ftnlen)8); + if (*m > *k) { + i__1 = *m - *k; + z__1.r = -1., z__1.i = -0.; + zgemm_((char *)"Conjugate transpose", (char *)"Conjugate transpose", &i__1, n, k, &z__1, + &v[v_offset], ldv, &work[work_offset], ldwork, &c_b1, &c__[c_offset], + ldc, (ftnlen)19, (ftnlen)19); + } + ztrmm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", n, k, &c_b1, + &v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[work_offset], ldwork, (ftnlen)5, + (ftnlen)5, (ftnlen)12, (ftnlen)4); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = *m - *k + j + i__ * c_dim1; + i__4 = *m - *k + j + i__ * c_dim1; + d_lmp_cnjg(&z__2, &work[i__ + j * work_dim1]); + 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; + } + } + } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], + &c__1); + } + ztrmm_((char *)"Right", (char *)"Lower", (char *)"Conjugate transpose", (char *)"Unit", m, k, &c_b1, + &v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[work_offset], ldwork, (ftnlen)5, + (ftnlen)5, (ftnlen)19, (ftnlen)4); + if (*n > *k) { + i__1 = *n - *k; + zgemm_((char *)"No transpose", (char *)"Conjugate transpose", m, k, &i__1, &c_b1, + &c__[c_offset], ldc, &v[v_offset], ldv, &c_b1, &work[work_offset], + ldwork, (ftnlen)12, (ftnlen)19); + } + ztrmm_((char *)"Right", (char *)"Lower", trans, (char *)"Non-unit", m, k, &c_b1, &t[t_offset], ldt, + &work[work_offset], ldwork, (ftnlen)5, (ftnlen)5, (ftnlen)1, (ftnlen)8); + if (*n > *k) { + i__1 = *n - *k; + z__1.r = -1., z__1.i = -0.; + zgemm_((char *)"No transpose", (char *)"No transpose", m, &i__1, k, &z__1, &work[work_offset], + ldwork, &v[v_offset], ldv, &c_b1, &c__[c_offset], ldc, (ftnlen)12, + (ftnlen)12); + } + ztrmm_((char *)"Right", (char *)"Lower", (char *)"No transpose", (char *)"Unit", m, k, &c_b1, + &v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[work_offset], ldwork, (ftnlen)5, + (ftnlen)5, (ftnlen)12, (ftnlen)4); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + (*n - *k + j) * c_dim1; + i__4 = i__ + (*n - *k + j) * c_dim1; + i__5 = i__ + j * work_dim1; + z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[i__4].i - work[i__5].i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; + } + } + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zlarfb.f b/lib/linalg/zlarfb.f deleted file mode 100644 index c5f424db31..0000000000 --- a/lib/linalg/zlarfb.f +++ /dev/null @@ -1,730 +0,0 @@ -*> \brief \b ZLARFB applies a block reflector or its conjugate-transpose to a general rectangular matrix. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLARFB + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, -* T, LDT, C, LDC, WORK, LDWORK ) -* -* .. Scalar Arguments .. -* CHARACTER DIRECT, SIDE, STOREV, TRANS -* INTEGER K, LDC, LDT, LDV, LDWORK, M, N -* .. -* .. Array Arguments .. -* COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ), -* $ WORK( LDWORK, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLARFB applies a complex block reflector H or its transpose H**H to a -*> complex M-by-N matrix C, from either the left or the right. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': apply H or H**H from the Left -*> = 'R': apply H or H**H from the Right -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> = 'N': apply H (No transpose) -*> = 'C': apply H**H (Conjugate transpose) -*> \endverbatim -*> -*> \param[in] DIRECT -*> \verbatim -*> DIRECT is CHARACTER*1 -*> Indicates how H is formed from a product of elementary -*> reflectors -*> = 'F': H = H(1) H(2) . . . H(k) (Forward) -*> = 'B': H = H(k) . . . H(2) H(1) (Backward) -*> \endverbatim -*> -*> \param[in] STOREV -*> \verbatim -*> STOREV is CHARACTER*1 -*> Indicates how the vectors which define the elementary -*> reflectors are stored: -*> = 'C': Columnwise -*> = 'R': Rowwise -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The order of the matrix T (= the number of elementary -*> reflectors whose product defines the block reflector). -*> If SIDE = 'L', M >= K >= 0; -*> if SIDE = 'R', N >= K >= 0. -*> \endverbatim -*> -*> \param[in] V -*> \verbatim -*> V is COMPLEX*16 array, dimension -*> (LDV,K) if STOREV = 'C' -*> (LDV,M) if STOREV = 'R' and SIDE = 'L' -*> (LDV,N) if STOREV = 'R' and SIDE = 'R' -*> See Further Details. -*> \endverbatim -*> -*> \param[in] LDV -*> \verbatim -*> LDV is INTEGER -*> The leading dimension of the array V. -*> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); -*> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); -*> if STOREV = 'R', LDV >= K. -*> \endverbatim -*> -*> \param[in] T -*> \verbatim -*> T is COMPLEX*16 array, dimension (LDT,K) -*> The triangular K-by-K matrix T in the representation of the -*> block reflector. -*> \endverbatim -*> -*> \param[in] LDT -*> \verbatim -*> LDT is INTEGER -*> The leading dimension of the array T. LDT >= K. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is COMPLEX*16 array, dimension (LDC,N) -*> On entry, the M-by-N matrix C. -*> On exit, C is overwritten by H*C or H**H*C or C*H or C*H**H. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 array, dimension (LDWORK,K) -*> \endverbatim -*> -*> \param[in] LDWORK -*> \verbatim -*> LDWORK is INTEGER -*> The leading dimension of the array WORK. -*> If SIDE = 'L', LDWORK >= max(1,N); -*> if SIDE = 'R', LDWORK >= max(1,M). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The shape of the matrix V and the storage of the vectors which define -*> the H(i) is best illustrated by the following example with n = 5 and -*> k = 3. The elements equal to 1 are not stored; the corresponding -*> array elements are modified but restored on exit. The rest of the -*> array is not used. -*> -*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': -*> -*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) -*> ( v1 1 ) ( 1 v2 v2 v2 ) -*> ( v1 v2 1 ) ( 1 v3 v3 ) -*> ( v1 v2 v3 ) -*> ( v1 v2 v3 ) -*> -*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': -*> -*> V = ( v1 v2 v3 ) V = ( v1 v1 1 ) -*> ( v1 v2 v3 ) ( v2 v2 v2 1 ) -*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) -*> ( 1 v3 ) -*> ( 1 ) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, - $ T, LDT, C, LDC, WORK, LDWORK ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER DIRECT, SIDE, STOREV, TRANS - INTEGER K, LDC, LDT, LDV, LDWORK, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ), - $ WORK( LDWORK, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - CHARACTER TRANST - INTEGER I, J -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL ZCOPY, ZGEMM, ZLACGV, ZTRMM -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( M.LE.0 .OR. N.LE.0 ) - $ RETURN -* - IF( LSAME( TRANS, 'N' ) ) THEN - TRANST = 'C' - ELSE - TRANST = 'N' - END IF -* - IF( LSAME( STOREV, 'C' ) ) THEN -* - IF( LSAME( DIRECT, 'F' ) ) THEN -* -* Let V = ( V1 ) (first K rows) -* ( V2 ) -* where V1 is unit lower triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**H * C where C = ( C1 ) -* ( C2 ) -* -* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK) -* -* W := C1**H -* - DO 10 J = 1, K - CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - CALL ZLACGV( N, WORK( 1, J ), 1 ) - 10 CONTINUE -* -* W := W * V1 -* - CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, - $ K, ONE, V, LDV, WORK, LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C2**H * V2 -* - CALL ZGEMM( 'Conjugate transpose', 'No transpose', N, - $ K, M-K, ONE, C( K+1, 1 ), LDC, - $ V( K+1, 1 ), LDV, ONE, WORK, LDWORK ) - END IF -* -* W := W * T**H or W * T -* - CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V * W**H -* - IF( M.GT.K ) THEN -* -* C2 := C2 - V2 * W**H -* - CALL ZGEMM( 'No transpose', 'Conjugate transpose', - $ M-K, N, K, -ONE, V( K+1, 1 ), LDV, WORK, - $ LDWORK, ONE, C( K+1, 1 ), LDC ) - END IF -* -* W := W * V1**H -* - CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', - $ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W**H -* - DO 30 J = 1, K - DO 20 I = 1, N - C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) ) - 20 CONTINUE - 30 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**H where C = ( C1 C2 ) -* -* W := C * V = (C1*V1 + C2*V2) (stored in WORK) -* -* W := C1 -* - DO 40 J = 1, K - CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) - 40 CONTINUE -* -* W := W * V1 -* - CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, - $ K, ONE, V, LDV, WORK, LDWORK ) - IF( N.GT.K ) THEN -* -* W := W + C2 * V2 -* - CALL ZGEMM( 'No transpose', 'No transpose', M, K, N-K, - $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T**H -* - CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V**H -* - IF( N.GT.K ) THEN -* -* C2 := C2 - W * V2**H -* - CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, - $ N-K, K, -ONE, WORK, LDWORK, V( K+1, 1 ), - $ LDV, ONE, C( 1, K+1 ), LDC ) - END IF -* -* W := W * V1**H -* - CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', - $ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 60 J = 1, K - DO 50 I = 1, M - C( I, J ) = C( I, J ) - WORK( I, J ) - 50 CONTINUE - 60 CONTINUE - END IF -* - ELSE -* -* Let V = ( V1 ) -* ( V2 ) (last K rows) -* where V2 is unit upper triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**H * C where C = ( C1 ) -* ( C2 ) -* -* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK) -* -* W := C2**H -* - DO 70 J = 1, K - CALL ZCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) - CALL ZLACGV( N, WORK( 1, J ), 1 ) - 70 CONTINUE -* -* W := W * V2 -* - CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, - $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C1**H * V1 -* - CALL ZGEMM( 'Conjugate transpose', 'No transpose', N, - $ K, M-K, ONE, C, LDC, V, LDV, ONE, WORK, - $ LDWORK ) - END IF -* -* W := W * T**H or W * T -* - CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V * W**H -* - IF( M.GT.K ) THEN -* -* C1 := C1 - V1 * W**H -* - CALL ZGEMM( 'No transpose', 'Conjugate transpose', - $ M-K, N, K, -ONE, V, LDV, WORK, LDWORK, - $ ONE, C, LDC ) - END IF -* -* W := W * V2**H -* - CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', - $ 'Unit', N, K, ONE, V( M-K+1, 1 ), LDV, WORK, - $ LDWORK ) -* -* C2 := C2 - W**H -* - DO 90 J = 1, K - DO 80 I = 1, N - C( M-K+J, I ) = C( M-K+J, I ) - - $ DCONJG( WORK( I, J ) ) - 80 CONTINUE - 90 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**H where C = ( C1 C2 ) -* -* W := C * V = (C1*V1 + C2*V2) (stored in WORK) -* -* W := C2 -* - DO 100 J = 1, K - CALL ZCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) - 100 CONTINUE -* -* W := W * V2 -* - CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, - $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) - IF( N.GT.K ) THEN -* -* W := W + C1 * V1 -* - CALL ZGEMM( 'No transpose', 'No transpose', M, K, N-K, - $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T**H -* - CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V**H -* - IF( N.GT.K ) THEN -* -* C1 := C1 - W * V1**H -* - CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, - $ N-K, K, -ONE, WORK, LDWORK, V, LDV, ONE, - $ C, LDC ) - END IF -* -* W := W * V2**H -* - CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', - $ 'Unit', M, K, ONE, V( N-K+1, 1 ), LDV, WORK, - $ LDWORK ) -* -* C2 := C2 - W -* - DO 120 J = 1, K - DO 110 I = 1, M - C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) - 110 CONTINUE - 120 CONTINUE - END IF - END IF -* - ELSE IF( LSAME( STOREV, 'R' ) ) THEN -* - IF( LSAME( DIRECT, 'F' ) ) THEN -* -* Let V = ( V1 V2 ) (V1: first K columns) -* where V1 is unit upper triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**H * C where C = ( C1 ) -* ( C2 ) -* -* W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK) -* -* W := C1**H -* - DO 130 J = 1, K - CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - CALL ZLACGV( N, WORK( 1, J ), 1 ) - 130 CONTINUE -* -* W := W * V1**H -* - CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', - $ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C2**H * V2**H -* - CALL ZGEMM( 'Conjugate transpose', - $ 'Conjugate transpose', N, K, M-K, ONE, - $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, - $ WORK, LDWORK ) - END IF -* -* W := W * T**H or W * T -* - CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V**H * W**H -* - IF( M.GT.K ) THEN -* -* C2 := C2 - V2**H * W**H -* - CALL ZGEMM( 'Conjugate transpose', - $ 'Conjugate transpose', M-K, N, K, -ONE, - $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE, - $ C( K+1, 1 ), LDC ) - END IF -* -* W := W * V1 -* - CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, - $ K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W**H -* - DO 150 J = 1, K - DO 140 I = 1, N - C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) ) - 140 CONTINUE - 150 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**H where C = ( C1 C2 ) -* -* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK) -* -* W := C1 -* - DO 160 J = 1, K - CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) - 160 CONTINUE -* -* W := W * V1**H -* - CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', - $ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK ) - IF( N.GT.K ) THEN -* -* W := W + C2 * V2**H -* - CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, - $ K, N-K, ONE, C( 1, K+1 ), LDC, - $ V( 1, K+1 ), LDV, ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T**H -* - CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V -* - IF( N.GT.K ) THEN -* -* C2 := C2 - W * V2 -* - CALL ZGEMM( 'No transpose', 'No transpose', M, N-K, K, - $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, - $ C( 1, K+1 ), LDC ) - END IF -* -* W := W * V1 -* - CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, - $ K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 180 J = 1, K - DO 170 I = 1, M - C( I, J ) = C( I, J ) - WORK( I, J ) - 170 CONTINUE - 180 CONTINUE -* - END IF -* - ELSE -* -* Let V = ( V1 V2 ) (V2: last K columns) -* where V2 is unit lower triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H**H * C where C = ( C1 ) -* ( C2 ) -* -* W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK) -* -* W := C2**H -* - DO 190 J = 1, K - CALL ZCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) - CALL ZLACGV( N, WORK( 1, J ), 1 ) - 190 CONTINUE -* -* W := W * V2**H -* - CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', - $ 'Unit', N, K, ONE, V( 1, M-K+1 ), LDV, WORK, - $ LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C1**H * V1**H -* - CALL ZGEMM( 'Conjugate transpose', - $ 'Conjugate transpose', N, K, M-K, ONE, C, - $ LDC, V, LDV, ONE, WORK, LDWORK ) - END IF -* -* W := W * T**H or W * T -* - CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V**H * W**H -* - IF( M.GT.K ) THEN -* -* C1 := C1 - V1**H * W**H -* - CALL ZGEMM( 'Conjugate transpose', - $ 'Conjugate transpose', M-K, N, K, -ONE, V, - $ LDV, WORK, LDWORK, ONE, C, LDC ) - END IF -* -* W := W * V2 -* - CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, - $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) -* -* C2 := C2 - W**H -* - DO 210 J = 1, K - DO 200 I = 1, N - C( M-K+J, I ) = C( M-K+J, I ) - - $ DCONJG( WORK( I, J ) ) - 200 CONTINUE - 210 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H**H where C = ( C1 C2 ) -* -* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK) -* -* W := C2 -* - DO 220 J = 1, K - CALL ZCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) - 220 CONTINUE -* -* W := W * V2**H -* - CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', - $ 'Unit', M, K, ONE, V( 1, N-K+1 ), LDV, WORK, - $ LDWORK ) - IF( N.GT.K ) THEN -* -* W := W + C1 * V1**H -* - CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, - $ K, N-K, ONE, C, LDC, V, LDV, ONE, WORK, - $ LDWORK ) - END IF -* -* W := W * T or W * T**H -* - CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V -* - IF( N.GT.K ) THEN -* -* C1 := C1 - W * V1 -* - CALL ZGEMM( 'No transpose', 'No transpose', M, N-K, K, - $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) - END IF -* -* W := W * V2 -* - CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, - $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 240 J = 1, K - DO 230 I = 1, M - C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) - 230 CONTINUE - 240 CONTINUE -* - END IF -* - END IF - END IF -* - RETURN -* -* End of ZLARFB -* - END diff --git a/lib/linalg/zlarfg.cpp b/lib/linalg/zlarfg.cpp new file mode 100644 index 0000000000..84f5efad01 --- /dev/null +++ b/lib/linalg/zlarfg.cpp @@ -0,0 +1,76 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static doublecomplex c_b5 = {1., 0.}; +int zlarfg_(integer *n, doublecomplex *alpha, doublecomplex *x, integer *incx, doublecomplex *tau) +{ + integer i__1; + doublereal d__1, d__2; + doublecomplex z__1, z__2; + double d_lmp_imag(doublecomplex *), d_lmp_sign(doublereal *, doublereal *); + integer j, knt; + doublereal beta, alphi, alphr; + extern int zscal_(integer *, doublecomplex *, doublecomplex *, integer *); + doublereal xnorm; + extern doublereal dlapy3_(doublereal *, doublereal *, doublereal *), + dznrm2_(integer *, doublecomplex *, integer *), dlamch_(char *, ftnlen); + doublereal safmin; + extern int zdscal_(integer *, doublereal *, doublecomplex *, integer *); + doublereal rsafmn; + extern VOID zladiv_(doublecomplex *, doublecomplex *, doublecomplex *); + --x; + if (*n <= 0) { + tau->r = 0., tau->i = 0.; + return 0; + } + i__1 = *n - 1; + xnorm = dznrm2_(&i__1, &x[1], incx); + alphr = alpha->r; + alphi = d_lmp_imag(alpha); + if (xnorm == 0. && alphi == 0.) { + tau->r = 0., tau->i = 0.; + } else { + d__1 = dlapy3_(&alphr, &alphi, &xnorm); + beta = -d_lmp_sign(&d__1, &alphr); + safmin = dlamch_((char *)"S", (ftnlen)1) / dlamch_((char *)"E", (ftnlen)1); + rsafmn = 1. / safmin; + knt = 0; + if (abs(beta) < safmin) { + L10: + ++knt; + i__1 = *n - 1; + zdscal_(&i__1, &rsafmn, &x[1], incx); + beta *= rsafmn; + alphi *= rsafmn; + alphr *= rsafmn; + if (abs(beta) < safmin && knt < 20) { + goto L10; + } + i__1 = *n - 1; + xnorm = dznrm2_(&i__1, &x[1], incx); + z__1.r = alphr, z__1.i = alphi; + alpha->r = z__1.r, alpha->i = z__1.i; + d__1 = dlapy3_(&alphr, &alphi, &xnorm); + beta = -d_lmp_sign(&d__1, &alphr); + } + d__1 = (beta - alphr) / beta; + d__2 = -alphi / beta; + z__1.r = d__1, z__1.i = d__2; + tau->r = z__1.r, tau->i = z__1.i; + z__2.r = alpha->r - beta, z__2.i = alpha->i; + zladiv_(&z__1, &c_b5, &z__2); + alpha->r = z__1.r, alpha->i = z__1.i; + i__1 = *n - 1; + zscal_(&i__1, alpha, &x[1], incx); + i__1 = knt; + for (j = 1; j <= i__1; ++j) { + beta *= safmin; + } + alpha->r = beta, alpha->i = 0.; + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zlarfg.f b/lib/linalg/zlarfg.f deleted file mode 100644 index d69796cadc..0000000000 --- a/lib/linalg/zlarfg.f +++ /dev/null @@ -1,200 +0,0 @@ -*> \brief \b ZLARFG generates an elementary reflector (Householder matrix). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLARFG + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU ) -* -* .. Scalar Arguments .. -* INTEGER INCX, N -* COMPLEX*16 ALPHA, TAU -* .. -* .. Array Arguments .. -* COMPLEX*16 X( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLARFG generates a complex elementary reflector H of order n, such -*> that -*> -*> H**H * ( alpha ) = ( beta ), H**H * H = I. -*> ( x ) ( 0 ) -*> -*> where alpha and beta are scalars, with beta real, and x is an -*> (n-1)-element complex vector. H is represented in the form -*> -*> H = I - tau * ( 1 ) * ( 1 v**H ) , -*> ( v ) -*> -*> where tau is a complex scalar and v is a complex (n-1)-element -*> vector. Note that H is not hermitian. -*> -*> If the elements of x are all zero and alpha is real, then tau = 0 -*> and H is taken to be the unit matrix. -*> -*> Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 . -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the elementary reflector. -*> \endverbatim -*> -*> \param[in,out] ALPHA -*> \verbatim -*> ALPHA is COMPLEX*16 -*> On entry, the value alpha. -*> On exit, it is overwritten with the value beta. -*> \endverbatim -*> -*> \param[in,out] X -*> \verbatim -*> X is COMPLEX*16 array, dimension -*> (1+(N-2)*abs(INCX)) -*> On entry, the vector x. -*> On exit, it is overwritten with the vector v. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> The increment between elements of X. INCX > 0. -*> \endverbatim -*> -*> \param[out] TAU -*> \verbatim -*> TAU is COMPLEX*16 -*> The value tau. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERauxiliary -* -* ===================================================================== - SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX, N - COMPLEX*16 ALPHA, TAU -* .. -* .. Array Arguments .. - COMPLEX*16 X( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER J, KNT - DOUBLE PRECISION ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH, DLAPY3, DZNRM2 - COMPLEX*16 ZLADIV - EXTERNAL DLAMCH, DLAPY3, DZNRM2, ZLADIV -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DCMPLX, DIMAG, SIGN -* .. -* .. External Subroutines .. - EXTERNAL ZDSCAL, ZSCAL -* .. -* .. Executable Statements .. -* - IF( N.LE.0 ) THEN - TAU = ZERO - RETURN - END IF -* - XNORM = DZNRM2( N-1, X, INCX ) - ALPHR = DBLE( ALPHA ) - ALPHI = DIMAG( ALPHA ) -* - IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN -* -* H = I -* - TAU = ZERO - ELSE -* -* general case -* - BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR ) - SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) - RSAFMN = ONE / SAFMIN -* - KNT = 0 - IF( ABS( BETA ).LT.SAFMIN ) THEN -* -* XNORM, BETA may be inaccurate; scale X and recompute them -* - 10 CONTINUE - KNT = KNT + 1 - CALL ZDSCAL( N-1, RSAFMN, X, INCX ) - BETA = BETA*RSAFMN - ALPHI = ALPHI*RSAFMN - ALPHR = ALPHR*RSAFMN - IF( (ABS( BETA ).LT.SAFMIN) .AND. (KNT .LT. 20) ) - $ GO TO 10 -* -* New BETA is at most 1, at least SAFMIN -* - XNORM = DZNRM2( N-1, X, INCX ) - ALPHA = DCMPLX( ALPHR, ALPHI ) - BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR ) - END IF - TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA ) - ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA ) - CALL ZSCAL( N-1, ALPHA, X, INCX ) -* -* If ALPHA is subnormal, it may lose relative accuracy -* - DO 20 J = 1, KNT - BETA = BETA*SAFMIN - 20 CONTINUE - ALPHA = BETA - END IF -* - RETURN -* -* End of ZLARFG -* - END diff --git a/lib/linalg/zlarft.cpp b/lib/linalg/zlarft.cpp new file mode 100644 index 0000000000..f778f646d2 --- /dev/null +++ b/lib/linalg/zlarft.cpp @@ -0,0 +1,202 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static doublecomplex c_b1 = {1., 0.}; +static integer c__1 = 1; +int zlarft_(char *direct, char *storev, integer *n, integer *k, doublecomplex *v, integer *ldv, + doublecomplex *tau, doublecomplex *t, integer *ldt, ftnlen direct_len, + ftnlen storev_len) +{ + integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4, i__5; + doublecomplex z__1, z__2, z__3; + void d_lmp_cnjg(doublecomplex *, doublecomplex *); + integer i__, j, prevlastv; + 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), + zgemv_(char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, ftnlen); + integer lastv; + extern int ztrmv_(char *, char *, char *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, ftnlen, ftnlen, ftnlen); + v_dim1 = *ldv; + v_offset = 1 + v_dim1; + v -= v_offset; + --tau; + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; + if (*n == 0) { + return 0; + } + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + prevlastv = *n; + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + prevlastv = max(prevlastv, i__); + i__2 = i__; + if (tau[i__2].r == 0. && tau[i__2].i == 0.) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * t_dim1; + t[i__3].r = 0., t[i__3].i = 0.; + } + } else { + if (lsame_(storev, (char *)"C", (ftnlen)1, (ftnlen)1)) { + i__2 = i__ + 1; + for (lastv = *n; lastv >= i__2; --lastv) { + i__3 = lastv + i__ * v_dim1; + if (v[i__3].r != 0. || v[i__3].i != 0.) { + goto L220; + } + } + L220: + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * t_dim1; + i__4 = i__; + z__2.r = -tau[i__4].r, z__2.i = -tau[i__4].i; + d_lmp_cnjg(&z__3, &v[i__ + j * v_dim1]); + 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; + t[i__3].r = z__1.r, t[i__3].i = z__1.i; + } + j = min(lastv, prevlastv); + i__2 = j - i__; + i__3 = i__ - 1; + i__4 = i__; + z__1.r = -tau[i__4].r, z__1.i = -tau[i__4].i; + zgemv_((char *)"Conjugate transpose", &i__2, &i__3, &z__1, &v[i__ + 1 + v_dim1], ldv, + &v[i__ + 1 + i__ * v_dim1], &c__1, &c_b1, &t[i__ * t_dim1 + 1], &c__1, + (ftnlen)19); + } else { + i__2 = i__ + 1; + for (lastv = *n; lastv >= i__2; --lastv) { + i__3 = i__ + lastv * v_dim1; + if (v[i__3].r != 0. || v[i__3].i != 0.) { + goto L236; + } + } + L236: + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * t_dim1; + i__4 = i__; + z__2.r = -tau[i__4].r, z__2.i = -tau[i__4].i; + i__5 = j + i__ * v_dim1; + z__1.r = z__2.r * v[i__5].r - z__2.i * v[i__5].i, + z__1.i = z__2.r * v[i__5].i + z__2.i * v[i__5].r; + t[i__3].r = z__1.r, t[i__3].i = z__1.i; + } + j = min(lastv, prevlastv); + i__2 = i__ - 1; + i__3 = j - i__; + i__4 = i__; + z__1.r = -tau[i__4].r, z__1.i = -tau[i__4].i; + zgemm_((char *)"N", (char *)"C", &i__2, &c__1, &i__3, &z__1, &v[(i__ + 1) * v_dim1 + 1], ldv, + &v[i__ + (i__ + 1) * v_dim1], ldv, &c_b1, &t[i__ * t_dim1 + 1], ldt, + (ftnlen)1, (ftnlen)1); + } + i__2 = i__ - 1; + ztrmv_((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); + i__2 = i__ + i__ * t_dim1; + i__3 = i__; + t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i; + if (i__ > 1) { + prevlastv = max(prevlastv, lastv); + } else { + prevlastv = lastv; + } + } + } + } else { + prevlastv = 1; + for (i__ = *k; i__ >= 1; --i__) { + i__1 = i__; + if (tau[i__1].r == 0. && tau[i__1].i == 0.) { + i__1 = *k; + for (j = i__; j <= i__1; ++j) { + i__2 = j + i__ * t_dim1; + t[i__2].r = 0., t[i__2].i = 0.; + } + } else { + if (i__ < *k) { + if (lsame_(storev, (char *)"C", (ftnlen)1, (ftnlen)1)) { + i__1 = i__ - 1; + for (lastv = 1; lastv <= i__1; ++lastv) { + i__2 = lastv + i__ * v_dim1; + if (v[i__2].r != 0. || v[i__2].i != 0.) { + goto L281; + } + } + L281: + i__1 = *k; + for (j = i__ + 1; j <= i__1; ++j) { + i__2 = j + i__ * t_dim1; + i__3 = i__; + z__2.r = -tau[i__3].r, z__2.i = -tau[i__3].i; + d_lmp_cnjg(&z__3, &v[*n - *k + i__ + j * v_dim1]); + 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; + t[i__2].r = z__1.r, t[i__2].i = z__1.i; + } + j = max(lastv, prevlastv); + i__1 = *n - *k + i__ - j; + i__2 = *k - i__; + i__3 = i__; + z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i; + zgemv_((char *)"Conjugate transpose", &i__1, &i__2, &z__1, + &v[j + (i__ + 1) * v_dim1], ldv, &v[j + i__ * v_dim1], &c__1, &c_b1, + &t[i__ + 1 + i__ * t_dim1], &c__1, (ftnlen)19); + } else { + i__1 = i__ - 1; + for (lastv = 1; lastv <= i__1; ++lastv) { + i__2 = i__ + lastv * v_dim1; + if (v[i__2].r != 0. || v[i__2].i != 0.) { + goto L297; + } + } + L297: + i__1 = *k; + for (j = i__ + 1; j <= i__1; ++j) { + i__2 = j + i__ * t_dim1; + i__3 = i__; + z__2.r = -tau[i__3].r, z__2.i = -tau[i__3].i; + i__4 = j + (*n - *k + i__) * v_dim1; + z__1.r = z__2.r * v[i__4].r - z__2.i * v[i__4].i, + z__1.i = z__2.r * v[i__4].i + z__2.i * v[i__4].r; + t[i__2].r = z__1.r, t[i__2].i = z__1.i; + } + j = max(lastv, prevlastv); + i__1 = *k - i__; + i__2 = *n - *k + i__ - j; + i__3 = i__; + z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i; + zgemm_((char *)"N", (char *)"C", &i__1, &c__1, &i__2, &z__1, &v[i__ + 1 + j * v_dim1], ldv, + &v[i__ + j * v_dim1], ldv, &c_b1, &t[i__ + 1 + i__ * t_dim1], ldt, + (ftnlen)1, (ftnlen)1); + } + i__1 = *k - i__; + ztrmv_((char *)"Lower", (char *)"No transpose", (char *)"Non-unit", &i__1, + &t[i__ + 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * t_dim1], &c__1, + (ftnlen)5, (ftnlen)12, (ftnlen)8); + if (i__ > 1) { + prevlastv = min(prevlastv, lastv); + } else { + prevlastv = lastv; + } + } + i__1 = i__ + i__ * t_dim1; + i__2 = i__; + t[i__1].r = tau[i__2].r, t[i__1].i = tau[i__2].i; + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zlarft.f b/lib/linalg/zlarft.f deleted file mode 100644 index 5ad0996fab..0000000000 --- a/lib/linalg/zlarft.f +++ /dev/null @@ -1,324 +0,0 @@ -*> \brief \b ZLARFT forms the triangular factor T of a block reflector H = I - vtvH -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLARFT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) -* -* .. Scalar Arguments .. -* CHARACTER DIRECT, STOREV -* INTEGER K, LDT, LDV, N -* .. -* .. Array Arguments .. -* COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLARFT forms the triangular factor T of a complex block reflector H -*> of order n, which is defined as a product of k elementary reflectors. -*> -*> If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; -*> -*> If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. -*> -*> If STOREV = 'C', the vector which defines the elementary reflector -*> H(i) is stored in the i-th column of the array V, and -*> -*> H = I - V * T * V**H -*> -*> If STOREV = 'R', the vector which defines the elementary reflector -*> H(i) is stored in the i-th row of the array V, and -*> -*> H = I - V**H * T * V -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] DIRECT -*> \verbatim -*> DIRECT is CHARACTER*1 -*> Specifies the order in which the elementary reflectors are -*> multiplied to form the block reflector: -*> = 'F': H = H(1) H(2) . . . H(k) (Forward) -*> = 'B': H = H(k) . . . H(2) H(1) (Backward) -*> \endverbatim -*> -*> \param[in] STOREV -*> \verbatim -*> STOREV is CHARACTER*1 -*> Specifies how the vectors which define the elementary -*> reflectors are stored (see also Further Details): -*> = 'C': columnwise -*> = 'R': rowwise -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the block reflector H. N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The order of the triangular factor T (= the number of -*> elementary reflectors). K >= 1. -*> \endverbatim -*> -*> \param[in] V -*> \verbatim -*> V is COMPLEX*16 array, dimension -*> (LDV,K) if STOREV = 'C' -*> (LDV,N) if STOREV = 'R' -*> The matrix V. See further details. -*> \endverbatim -*> -*> \param[in] LDV -*> \verbatim -*> LDV is INTEGER -*> The leading dimension of the array V. -*> If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i). -*> \endverbatim -*> -*> \param[out] T -*> \verbatim -*> T is COMPLEX*16 array, dimension (LDT,K) -*> The k by k triangular factor T of the block reflector. -*> If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is -*> lower triangular. The rest of the array is not used. -*> \endverbatim -*> -*> \param[in] LDT -*> \verbatim -*> LDT is INTEGER -*> The leading dimension of the array T. LDT >= K. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The shape of the matrix V and the storage of the vectors which define -*> the H(i) is best illustrated by the following example with n = 5 and -*> k = 3. The elements equal to 1 are not stored. -*> -*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': -*> -*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) -*> ( v1 1 ) ( 1 v2 v2 v2 ) -*> ( v1 v2 1 ) ( 1 v3 v3 ) -*> ( v1 v2 v3 ) -*> ( v1 v2 v3 ) -*> -*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': -*> -*> V = ( v1 v2 v3 ) V = ( v1 v1 1 ) -*> ( v1 v2 v3 ) ( v2 v2 v2 1 ) -*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) -*> ( 1 v3 ) -*> ( 1 ) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER DIRECT, STOREV - INTEGER K, LDT, LDV, N -* .. -* .. Array Arguments .. - COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE, ZERO - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, J, PREVLASTV, LASTV -* .. -* .. External Subroutines .. - EXTERNAL ZGEMV, ZTRMV, ZGEMM -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( LSAME( DIRECT, 'F' ) ) THEN - PREVLASTV = N - DO I = 1, K - PREVLASTV = MAX( PREVLASTV, I ) - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO J = 1, I - T( J, I ) = ZERO - END DO - ELSE -* -* general case -* - IF( LSAME( STOREV, 'C' ) ) THEN -* Skip any trailing zeros. - DO LASTV = N, I+1, -1 - IF( V( LASTV, I ).NE.ZERO ) EXIT - END DO - DO J = 1, I-1 - T( J, I ) = -TAU( I ) * CONJG( V( I , J ) ) - END DO - J = MIN( LASTV, PREVLASTV ) -* -* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**H * V(i:j,i) -* - CALL ZGEMV( 'Conjugate transpose', J-I, I-1, - $ -TAU( I ), V( I+1, 1 ), LDV, - $ V( I+1, I ), 1, ONE, T( 1, I ), 1 ) - ELSE -* Skip any trailing zeros. - DO LASTV = N, I+1, -1 - IF( V( I, LASTV ).NE.ZERO ) EXIT - END DO - DO J = 1, I-1 - T( J, I ) = -TAU( I ) * V( J , I ) - END DO - J = MIN( LASTV, PREVLASTV ) -* -* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**H -* - CALL ZGEMM( 'N', 'C', I-1, 1, J-I, -TAU( I ), - $ V( 1, I+1 ), LDV, V( I, I+1 ), LDV, - $ ONE, T( 1, I ), LDT ) - END IF -* -* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) -* - CALL ZTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, - $ LDT, T( 1, I ), 1 ) - T( I, I ) = TAU( I ) - IF( I.GT.1 ) THEN - PREVLASTV = MAX( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF - END IF - END DO - ELSE - PREVLASTV = 1 - DO I = K, 1, -1 - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO J = I, K - T( J, I ) = ZERO - END DO - ELSE -* -* general case -* - IF( I.LT.K ) THEN - IF( LSAME( STOREV, 'C' ) ) THEN -* Skip any leading zeros. - DO LASTV = 1, I-1 - IF( V( LASTV, I ).NE.ZERO ) EXIT - END DO - DO J = I+1, K - T( J, I ) = -TAU( I ) * CONJG( V( N-K+I , J ) ) - END DO - J = MAX( LASTV, PREVLASTV ) -* -* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**H * V(j:n-k+i,i) -* - CALL ZGEMV( 'Conjugate transpose', N-K+I-J, K-I, - $ -TAU( I ), V( J, I+1 ), LDV, V( J, I ), - $ 1, ONE, T( I+1, I ), 1 ) - ELSE -* Skip any leading zeros. - DO LASTV = 1, I-1 - IF( V( I, LASTV ).NE.ZERO ) EXIT - END DO - DO J = I+1, K - T( J, I ) = -TAU( I ) * V( J, N-K+I ) - END DO - J = MAX( LASTV, PREVLASTV ) -* -* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**H -* - CALL ZGEMM( 'N', 'C', K-I, 1, N-K+I-J, -TAU( I ), - $ V( I+1, J ), LDV, V( I, J ), LDV, - $ ONE, T( I+1, I ), LDT ) - END IF -* -* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) -* - CALL ZTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, - $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) - IF( I.GT.1 ) THEN - PREVLASTV = MIN( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF - END IF - T( I, I ) = TAU( I ) - END IF - END DO - END IF - RETURN -* -* End of ZLARFT -* - END diff --git a/lib/linalg/zlascl.cpp b/lib/linalg/zlascl.cpp new file mode 100644 index 0000000000..293da0739e --- /dev/null +++ b/lib/linalg/zlascl.cpp @@ -0,0 +1,207 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int zlascl_(char *type__, integer *kl, integer *ku, doublereal *cfrom, doublereal *cto, integer *m, + integer *n, doublecomplex *a, integer *lda, integer *info, ftnlen type_len) +{ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + doublecomplex z__1; + integer i__, j, k1, k2, k3, k4; + doublereal mul, cto1; + logical done; + doublereal ctoc; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + integer itype; + doublereal cfrom1; + extern doublereal dlamch_(char *, ftnlen); + doublereal cfromc; + extern logical disnan_(doublereal *); + extern int xerbla_(char *, integer *, ftnlen); + doublereal bignum, smlnum; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + *info = 0; + if (lsame_(type__, (char *)"G", (ftnlen)1, (ftnlen)1)) { + itype = 0; + } else if (lsame_(type__, (char *)"L", (ftnlen)1, (ftnlen)1)) { + itype = 1; + } else if (lsame_(type__, (char *)"U", (ftnlen)1, (ftnlen)1)) { + itype = 2; + } else if (lsame_(type__, (char *)"H", (ftnlen)1, (ftnlen)1)) { + itype = 3; + } else if (lsame_(type__, (char *)"B", (ftnlen)1, (ftnlen)1)) { + itype = 4; + } else if (lsame_(type__, (char *)"Q", (ftnlen)1, (ftnlen)1)) { + itype = 5; + } else if (lsame_(type__, (char *)"Z", (ftnlen)1, (ftnlen)1)) { + itype = 6; + } else { + itype = -1; + } + if (itype == -1) { + *info = -1; + } else if (*cfrom == 0. || disnan_(cfrom)) { + *info = -4; + } else if (disnan_(cto)) { + *info = -5; + } else if (*m < 0) { + *info = -6; + } else if (*n < 0 || itype == 4 && *n != *m || itype == 5 && *n != *m) { + *info = -7; + } else if (itype <= 3 && *lda < max(1, *m)) { + *info = -9; + } else if (itype >= 4) { + i__1 = *m - 1; + if (*kl < 0 || *kl > max(i__1, 0)) { + *info = -2; + } else { + i__1 = *n - 1; + if (*ku < 0 || *ku > max(i__1, 0) || (itype == 4 || itype == 5) && *kl != *ku) { + *info = -3; + } else if (itype == 4 && *lda < *kl + 1 || itype == 5 && *lda < *ku + 1 || + itype == 6 && *lda < (*kl << 1) + *ku + 1) { + *info = -9; + } + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"ZLASCL", &i__1, (ftnlen)6); + return 0; + } + if (*n == 0 || *m == 0) { + return 0; + } + smlnum = dlamch_((char *)"S", (ftnlen)1); + bignum = 1. / smlnum; + cfromc = *cfrom; + ctoc = *cto; +L10: + cfrom1 = cfromc * smlnum; + if (cfrom1 == cfromc) { + mul = ctoc / cfromc; + done = TRUE_; + cto1 = ctoc; + } else { + cto1 = ctoc / bignum; + if (cto1 == ctoc) { + mul = ctoc; + done = TRUE_; + cfromc = 1.; + } else if (abs(cfrom1) > abs(ctoc) && ctoc != 0.) { + mul = smlnum; + done = FALSE_; + cfromc = cfrom1; + } else if (abs(cto1) > abs(cfromc)) { + mul = bignum; + done = FALSE_; + ctoc = cto1; + } else { + mul = ctoc / cfromc; + done = TRUE_; + if (mul == 1.) { + return 0; + } + } + } + if (itype == 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 * a_dim1; + i__4 = i__ + j * a_dim1; + z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } + } + } else if (itype == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } + } + } else if (itype == 2) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = min(j, *m); + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } + } + } else if (itype == 3) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__3 = j + 1; + i__2 = min(i__3, *m); + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } + } + } else if (itype == 4) { + k3 = *kl + 1; + k4 = *n + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__3 = k3, i__4 = k4 - j; + i__2 = min(i__3, i__4); + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } + } + } else if (itype == 5) { + k1 = *ku + 2; + k3 = *ku + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = k1 - j; + i__3 = k3; + for (i__ = max(i__2, 1); i__ <= i__3; ++i__) { + i__2 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + } + } + } else if (itype == 6) { + k1 = *kl + *ku + 2; + k2 = *kl + 1; + k3 = (*kl << 1) + *ku + 1; + k4 = *kl + *ku + 1 + *m; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__3 = k1 - j; + i__4 = k3, i__5 = k4 - j; + i__2 = min(i__4, i__5); + for (i__ = max(i__3, k2); i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } + } + } + if (!done) { + goto L10; + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zlascl.f b/lib/linalg/zlascl.f deleted file mode 100644 index 4cce5ff5e0..0000000000 --- a/lib/linalg/zlascl.f +++ /dev/null @@ -1,367 +0,0 @@ -*> \brief \b ZLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLASCL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER TYPE -* INTEGER INFO, KL, KU, LDA, M, N -* DOUBLE PRECISION CFROM, CTO -* .. -* .. Array Arguments .. -* COMPLEX*16 A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLASCL multiplies the M by N complex matrix A by the real scalar -*> CTO/CFROM. This is done without over/underflow as long as the final -*> result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that -*> A may be full, upper triangular, lower triangular, upper Hessenberg, -*> or banded. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] TYPE -*> \verbatim -*> TYPE is CHARACTER*1 -*> TYPE indices the storage type of the input matrix. -*> = 'G': A is a full matrix. -*> = 'L': A is a lower triangular matrix. -*> = 'U': A is an upper triangular matrix. -*> = 'H': A is an upper Hessenberg matrix. -*> = 'B': A is a symmetric band matrix with lower bandwidth KL -*> and upper bandwidth KU and with the only the lower -*> half stored. -*> = 'Q': A is a symmetric band matrix with lower bandwidth KL -*> and upper bandwidth KU and with the only the upper -*> half stored. -*> = 'Z': A is a band matrix with lower bandwidth KL and upper -*> bandwidth KU. See ZGBTRF for storage details. -*> \endverbatim -*> -*> \param[in] KL -*> \verbatim -*> KL is INTEGER -*> The lower bandwidth of A. Referenced only if TYPE = 'B', -*> 'Q' or 'Z'. -*> \endverbatim -*> -*> \param[in] KU -*> \verbatim -*> KU is INTEGER -*> The upper bandwidth of A. Referenced only if TYPE = 'B', -*> 'Q' or 'Z'. -*> \endverbatim -*> -*> \param[in] CFROM -*> \verbatim -*> CFROM is DOUBLE PRECISION -*> \endverbatim -*> -*> \param[in] CTO -*> \verbatim -*> CTO is DOUBLE PRECISION -*> -*> The matrix A is multiplied by CTO/CFROM. A(I,J) is computed -*> without over/underflow if the final result CTO*A(I,J)/CFROM -*> can be represented without over/underflow. CFROM must be -*> nonzero. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,N) -*> The matrix to be multiplied by CTO/CFROM. See TYPE for the -*> storage type. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. -*> If TYPE = 'G', 'L', 'U', 'H', LDA >= max(1,M); -*> TYPE = 'B', LDA >= KL+1; -*> TYPE = 'Q', LDA >= KU+1; -*> TYPE = 'Z', LDA >= 2*KL+KU+1. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> 0 - successful exit -*> <0 - if INFO = -i, the i-th argument had an illegal value. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERauxiliary -* -* ===================================================================== - SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER TYPE - INTEGER INFO, KL, KU, LDA, M, N - DOUBLE PRECISION CFROM, CTO -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL DONE - INTEGER I, ITYPE, J, K1, K2, K3, K4 - DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM -* .. -* .. External Functions .. - LOGICAL LSAME, DISNAN - DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, DLAMCH, DISNAN -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 -* - IF( LSAME( TYPE, 'G' ) ) THEN - ITYPE = 0 - ELSE IF( LSAME( TYPE, 'L' ) ) THEN - ITYPE = 1 - ELSE IF( LSAME( TYPE, 'U' ) ) THEN - ITYPE = 2 - ELSE IF( LSAME( TYPE, 'H' ) ) THEN - ITYPE = 3 - ELSE IF( LSAME( TYPE, 'B' ) ) THEN - ITYPE = 4 - ELSE IF( LSAME( TYPE, 'Q' ) ) THEN - ITYPE = 5 - ELSE IF( LSAME( TYPE, 'Z' ) ) THEN - ITYPE = 6 - ELSE - ITYPE = -1 - END IF -* - IF( ITYPE.EQ.-1 ) THEN - INFO = -1 - ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN - INFO = -4 - ELSE IF( DISNAN(CTO) ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. - $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN - INFO = -7 - ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN - INFO = -9 - ELSE IF( ITYPE.GE.4 ) THEN - IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN - INFO = -2 - ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. - $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) - $ THEN - INFO = -3 - ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. - $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. - $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN - INFO = -9 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZLASCL', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. M.EQ.0 ) - $ RETURN -* -* Get machine parameters -* - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM -* - CFROMC = CFROM - CTOC = CTO -* - 10 CONTINUE - CFROM1 = CFROMC*SMLNUM - IF( CFROM1.EQ.CFROMC ) THEN -! CFROMC is an inf. Multiply by a correctly signed zero for -! finite CTOC, or a NaN if CTOC is infinite. - MUL = CTOC / CFROMC - DONE = .TRUE. - CTO1 = CTOC - ELSE - CTO1 = CTOC / BIGNUM - IF( CTO1.EQ.CTOC ) THEN -! CTOC is either 0 or an inf. In both cases, CTOC itself -! serves as the correct multiplication factor. - MUL = CTOC - DONE = .TRUE. - CFROMC = ONE - ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN - MUL = SMLNUM - DONE = .FALSE. - CFROMC = CFROM1 - ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN - MUL = BIGNUM - DONE = .FALSE. - CTOC = CTO1 - ELSE - MUL = CTOC / CFROMC - DONE = .TRUE. - IF (MUL .EQ. ONE) - $ RETURN - END IF - END IF -* - IF( ITYPE.EQ.0 ) THEN -* -* Full matrix -* - DO 30 J = 1, N - DO 20 I = 1, M - A( I, J ) = A( I, J )*MUL - 20 CONTINUE - 30 CONTINUE -* - ELSE IF( ITYPE.EQ.1 ) THEN -* -* Lower triangular matrix -* - DO 50 J = 1, N - DO 40 I = J, M - A( I, J ) = A( I, J )*MUL - 40 CONTINUE - 50 CONTINUE -* - ELSE IF( ITYPE.EQ.2 ) THEN -* -* Upper triangular matrix -* - DO 70 J = 1, N - DO 60 I = 1, MIN( J, M ) - A( I, J ) = A( I, J )*MUL - 60 CONTINUE - 70 CONTINUE -* - ELSE IF( ITYPE.EQ.3 ) THEN -* -* Upper Hessenberg matrix -* - DO 90 J = 1, N - DO 80 I = 1, MIN( J+1, M ) - A( I, J ) = A( I, J )*MUL - 80 CONTINUE - 90 CONTINUE -* - ELSE IF( ITYPE.EQ.4 ) THEN -* -* Lower half of a symmetric band matrix -* - K3 = KL + 1 - K4 = N + 1 - DO 110 J = 1, N - DO 100 I = 1, MIN( K3, K4-J ) - A( I, J ) = A( I, J )*MUL - 100 CONTINUE - 110 CONTINUE -* - ELSE IF( ITYPE.EQ.5 ) THEN -* -* Upper half of a symmetric band matrix -* - K1 = KU + 2 - K3 = KU + 1 - DO 130 J = 1, N - DO 120 I = MAX( K1-J, 1 ), K3 - A( I, J ) = A( I, J )*MUL - 120 CONTINUE - 130 CONTINUE -* - ELSE IF( ITYPE.EQ.6 ) THEN -* -* Band matrix -* - K1 = KL + KU + 2 - K2 = KL + 1 - K3 = 2*KL + KU + 1 - K4 = KL + KU + 1 + M - DO 150 J = 1, N - DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) - A( I, J ) = A( I, J )*MUL - 140 CONTINUE - 150 CONTINUE -* - END IF -* - IF( .NOT.DONE ) - $ GO TO 10 -* - RETURN -* -* End of ZLASCL -* - END diff --git a/lib/linalg/zlaset.cpp b/lib/linalg/zlaset.cpp new file mode 100644 index 0000000000..dc5dd4740c --- /dev/null +++ b/lib/linalg/zlaset.cpp @@ -0,0 +1,62 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int zlaset_(char *uplo, integer *m, integer *n, doublecomplex *alpha, doublecomplex *beta, + doublecomplex *a, integer *lda, ftnlen uplo_len) +{ + integer a_dim1, a_offset, i__1, i__2, i__3; + integer i__, j; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + i__3 = j - 1; + i__2 = min(i__3, *m); + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + a[i__3].r = alpha->r, a[i__3].i = alpha->i; + } + } + i__1 = min(*n, *m); + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * a_dim1; + a[i__2].r = beta->r, a[i__2].i = beta->i; + } + } else if (lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { + i__1 = min(*m, *n); + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + a[i__3].r = alpha->r, a[i__3].i = alpha->i; + } + } + i__1 = min(*n, *m); + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * a_dim1; + a[i__2].r = beta->r, a[i__2].i = beta->i; + } + } 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 * a_dim1; + a[i__3].r = alpha->r, a[i__3].i = alpha->i; + } + } + i__1 = min(*m, *n); + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * a_dim1; + a[i__2].r = beta->r, a[i__2].i = beta->i; + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zlaset.f b/lib/linalg/zlaset.f deleted file mode 100644 index 00f5f595fc..0000000000 --- a/lib/linalg/zlaset.f +++ /dev/null @@ -1,181 +0,0 @@ -*> \brief \b ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLASET + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER LDA, M, N -* COMPLEX*16 ALPHA, BETA -* .. -* .. Array Arguments .. -* COMPLEX*16 A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLASET initializes a 2-D array A to BETA on the diagonal and -*> ALPHA on the offdiagonals. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> Specifies the part of the matrix A to be set. -*> = 'U': Upper triangular part is set. The lower triangle -*> is unchanged. -*> = 'L': Lower triangular part is set. The upper triangle -*> is unchanged. -*> Otherwise: All of the matrix A is set. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> On entry, M specifies the number of rows of A. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the number of columns of A. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is COMPLEX*16 -*> All the offdiagonal array elements are set to ALPHA. -*> \endverbatim -*> -*> \param[in] BETA -*> \verbatim -*> BETA is COMPLEX*16 -*> All the diagonal array elements are set to BETA. -*> \endverbatim -*> -*> \param[out] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,N) -*> On entry, the m by n matrix A. -*> On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j; -*> A(i,i) = BETA , 1 <= i <= min(m,n) -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERauxiliary -* -* ===================================================================== - SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, M, N - COMPLEX*16 ALPHA, BETA -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, J -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* - IF( LSAME( UPLO, 'U' ) ) THEN -* -* Set the diagonal to BETA and the strictly upper triangular -* part of the array to ALPHA. -* - DO 20 J = 2, N - DO 10 I = 1, MIN( J-1, M ) - A( I, J ) = ALPHA - 10 CONTINUE - 20 CONTINUE - DO 30 I = 1, MIN( N, M ) - A( I, I ) = BETA - 30 CONTINUE -* - ELSE IF( LSAME( UPLO, 'L' ) ) THEN -* -* Set the diagonal to BETA and the strictly lower triangular -* part of the array to ALPHA. -* - DO 50 J = 1, MIN( M, N ) - DO 40 I = J + 1, M - A( I, J ) = ALPHA - 40 CONTINUE - 50 CONTINUE - DO 60 I = 1, MIN( N, M ) - A( I, I ) = BETA - 60 CONTINUE -* - ELSE -* -* Set the array to BETA on the diagonal and ALPHA on the -* offdiagonal. -* - DO 80 J = 1, N - DO 70 I = 1, M - A( I, J ) = ALPHA - 70 CONTINUE - 80 CONTINUE - DO 90 I = 1, MIN( M, N ) - A( I, I ) = BETA - 90 CONTINUE - END IF -* - RETURN -* -* End of ZLASET -* - END diff --git a/lib/linalg/zlasr.cpp b/lib/linalg/zlasr.cpp new file mode 100644 index 0000000000..06dc5606d2 --- /dev/null +++ b/lib/linalg/zlasr.cpp @@ -0,0 +1,360 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int zlasr_(char *side, char *pivot, char *direct, integer *m, integer *n, doublereal *c__, + doublereal *s, doublecomplex *a, integer *lda, ftnlen side_len, ftnlen pivot_len, + ftnlen direct_len) +{ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + doublecomplex z__1, z__2, z__3; + integer i__, j, info; + doublecomplex temp; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + doublereal ctemp, stemp; + extern int xerbla_(char *, integer *, ftnlen); + --c__; + --s; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + info = 0; + if (!(lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1) || lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1))) { + info = 1; + } else if (!(lsame_(pivot, (char *)"V", (ftnlen)1, (ftnlen)1) || + lsame_(pivot, (char *)"T", (ftnlen)1, (ftnlen)1) || + lsame_(pivot, (char *)"B", (ftnlen)1, (ftnlen)1))) { + info = 2; + } else if (!(lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1) || + lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1))) { + info = 3; + } else if (*m < 0) { + info = 4; + } else if (*n < 0) { + info = 5; + } else if (*lda < max(1, *m)) { + info = 9; + } + if (info != 0) { + xerbla_((char *)"ZLASR ", &info, (ftnlen)6); + return 0; + } + if (*m == 0 || *n == 0) { + return 0; + } + if (lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1)) { + if (lsame_(pivot, (char *)"V", (ftnlen)1, (ftnlen)1)) { + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + i__1 = *m - 1; + for (j = 1; j <= i__1; ++j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = j + 1 + i__ * a_dim1; + temp.r = a[i__3].r, temp.i = a[i__3].i; + i__3 = j + 1 + i__ * a_dim1; + z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; + i__4 = j + i__ * a_dim1; + z__3.r = stemp * a[i__4].r, z__3.i = stemp * a[i__4].i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__3 = j + i__ * a_dim1; + z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; + i__4 = j + i__ * a_dim1; + z__3.r = ctemp * a[i__4].r, z__3.i = ctemp * a[i__4].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } + } + } + } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { + for (j = *m - 1; j >= 1; --j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = j + 1 + i__ * a_dim1; + temp.r = a[i__2].r, temp.i = a[i__2].i; + i__2 = j + 1 + i__ * a_dim1; + z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; + i__3 = j + i__ * a_dim1; + z__3.r = stemp * a[i__3].r, z__3.i = stemp * a[i__3].i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = j + i__ * a_dim1; + z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; + i__3 = j + i__ * a_dim1; + z__3.r = ctemp * a[i__3].r, z__3.i = ctemp * a[i__3].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + } + } + } + } + } else if (lsame_(pivot, (char *)"T", (ftnlen)1, (ftnlen)1)) { + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + i__1 = *m; + for (j = 2; j <= i__1; ++j) { + ctemp = c__[j - 1]; + stemp = s[j - 1]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = j + i__ * a_dim1; + temp.r = a[i__3].r, temp.i = a[i__3].i; + i__3 = j + i__ * a_dim1; + z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; + i__4 = i__ * a_dim1 + 1; + z__3.r = stemp * a[i__4].r, z__3.i = stemp * a[i__4].i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__3 = i__ * a_dim1 + 1; + z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; + i__4 = i__ * a_dim1 + 1; + z__3.r = ctemp * a[i__4].r, z__3.i = ctemp * a[i__4].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } + } + } + } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { + for (j = *m; j >= 2; --j) { + ctemp = c__[j - 1]; + stemp = s[j - 1]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = j + i__ * a_dim1; + temp.r = a[i__2].r, temp.i = a[i__2].i; + i__2 = j + i__ * a_dim1; + z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; + i__3 = i__ * a_dim1 + 1; + z__3.r = stemp * a[i__3].r, z__3.i = stemp * a[i__3].i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = i__ * a_dim1 + 1; + z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; + i__3 = i__ * a_dim1 + 1; + z__3.r = ctemp * a[i__3].r, z__3.i = ctemp * a[i__3].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + } + } + } + } + } else if (lsame_(pivot, (char *)"B", (ftnlen)1, (ftnlen)1)) { + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + i__1 = *m - 1; + for (j = 1; j <= i__1; ++j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = j + i__ * a_dim1; + temp.r = a[i__3].r, temp.i = a[i__3].i; + i__3 = j + i__ * a_dim1; + i__4 = *m + i__ * a_dim1; + z__2.r = stemp * a[i__4].r, z__2.i = stemp * a[i__4].i; + z__3.r = ctemp * temp.r, z__3.i = ctemp * temp.i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__3 = *m + i__ * a_dim1; + i__4 = *m + i__ * a_dim1; + z__2.r = ctemp * a[i__4].r, z__2.i = ctemp * a[i__4].i; + z__3.r = stemp * temp.r, z__3.i = stemp * temp.i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } + } + } + } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { + for (j = *m - 1; j >= 1; --j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = j + i__ * a_dim1; + temp.r = a[i__2].r, temp.i = a[i__2].i; + i__2 = j + i__ * a_dim1; + i__3 = *m + i__ * a_dim1; + z__2.r = stemp * a[i__3].r, z__2.i = stemp * a[i__3].i; + z__3.r = ctemp * temp.r, z__3.i = ctemp * temp.i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = *m + i__ * a_dim1; + i__3 = *m + i__ * a_dim1; + z__2.r = ctemp * a[i__3].r, z__2.i = ctemp * a[i__3].i; + z__3.r = stemp * temp.r, z__3.i = stemp * temp.i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + } + } + } + } + } + } else if (lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { + if (lsame_(pivot, (char *)"V", (ftnlen)1, (ftnlen)1)) { + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + (j + 1) * a_dim1; + temp.r = a[i__3].r, temp.i = a[i__3].i; + i__3 = i__ + (j + 1) * a_dim1; + z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; + i__4 = i__ + j * a_dim1; + z__3.r = stemp * a[i__4].r, z__3.i = stemp * a[i__4].i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__3 = i__ + j * a_dim1; + z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; + i__4 = i__ + j * a_dim1; + z__3.r = ctemp * a[i__4].r, z__3.i = ctemp * a[i__4].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } + } + } + } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { + for (j = *n - 1; j >= 1; --j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + (j + 1) * a_dim1; + temp.r = a[i__2].r, temp.i = a[i__2].i; + i__2 = i__ + (j + 1) * a_dim1; + z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; + i__3 = i__ + j * a_dim1; + z__3.r = stemp * a[i__3].r, z__3.i = stemp * a[i__3].i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = i__ + j * a_dim1; + z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; + i__3 = i__ + j * a_dim1; + z__3.r = ctemp * a[i__3].r, z__3.i = ctemp * a[i__3].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + } + } + } + } + } else if (lsame_(pivot, (char *)"T", (ftnlen)1, (ftnlen)1)) { + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + ctemp = c__[j - 1]; + stemp = s[j - 1]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + temp.r = a[i__3].r, temp.i = a[i__3].i; + i__3 = i__ + j * a_dim1; + z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; + i__4 = i__ + a_dim1; + z__3.r = stemp * a[i__4].r, z__3.i = stemp * a[i__4].i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__3 = i__ + a_dim1; + z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; + i__4 = i__ + a_dim1; + z__3.r = ctemp * a[i__4].r, z__3.i = ctemp * a[i__4].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } + } + } + } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { + for (j = *n; j >= 2; --j) { + ctemp = c__[j - 1]; + stemp = s[j - 1]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + j * a_dim1; + temp.r = a[i__2].r, temp.i = a[i__2].i; + i__2 = i__ + j * a_dim1; + z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; + i__3 = i__ + a_dim1; + z__3.r = stemp * a[i__3].r, z__3.i = stemp * a[i__3].i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = i__ + a_dim1; + z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; + i__3 = i__ + a_dim1; + z__3.r = ctemp * a[i__3].r, z__3.i = ctemp * a[i__3].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + } + } + } + } + } else if (lsame_(pivot, (char *)"B", (ftnlen)1, (ftnlen)1)) { + if (lsame_(direct, (char *)"F", (ftnlen)1, (ftnlen)1)) { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + temp.r = a[i__3].r, temp.i = a[i__3].i; + i__3 = i__ + j * a_dim1; + i__4 = i__ + *n * a_dim1; + z__2.r = stemp * a[i__4].r, z__2.i = stemp * a[i__4].i; + z__3.r = ctemp * temp.r, z__3.i = ctemp * temp.i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__3 = i__ + *n * a_dim1; + i__4 = i__ + *n * a_dim1; + z__2.r = ctemp * a[i__4].r, z__2.i = ctemp * a[i__4].i; + z__3.r = stemp * temp.r, z__3.i = stemp * temp.i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } + } + } + } else if (lsame_(direct, (char *)"B", (ftnlen)1, (ftnlen)1)) { + for (j = *n - 1; j >= 1; --j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + j * a_dim1; + temp.r = a[i__2].r, temp.i = a[i__2].i; + i__2 = i__ + j * a_dim1; + i__3 = i__ + *n * a_dim1; + z__2.r = stemp * a[i__3].r, z__2.i = stemp * a[i__3].i; + z__3.r = ctemp * temp.r, z__3.i = ctemp * temp.i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = i__ + *n * a_dim1; + i__3 = i__ + *n * a_dim1; + z__2.r = ctemp * a[i__3].r, z__2.i = ctemp * a[i__3].i; + z__3.r = stemp * temp.r, z__3.i = stemp * temp.i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + } + } + } + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zlasr.f b/lib/linalg/zlasr.f deleted file mode 100644 index 07c91329c4..0000000000 --- a/lib/linalg/zlasr.f +++ /dev/null @@ -1,436 +0,0 @@ -*> \brief \b ZLASR applies a sequence of plane rotations to a general rectangular matrix. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLASR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) -* -* .. Scalar Arguments .. -* CHARACTER DIRECT, PIVOT, SIDE -* INTEGER LDA, M, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION C( * ), S( * ) -* COMPLEX*16 A( LDA, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLASR applies a sequence of real plane rotations to a complex matrix -*> A, from either the left or the right. -*> -*> When SIDE = 'L', the transformation takes the form -*> -*> A := P*A -*> -*> and when SIDE = 'R', the transformation takes the form -*> -*> A := A*P**T -*> -*> where P is an orthogonal matrix consisting of a sequence of z plane -*> rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R', -*> and P**T is the transpose of P. -*> -*> When DIRECT = 'F' (Forward sequence), then -*> -*> P = P(z-1) * ... * P(2) * P(1) -*> -*> and when DIRECT = 'B' (Backward sequence), then -*> -*> P = P(1) * P(2) * ... * P(z-1) -*> -*> where P(k) is a plane rotation matrix defined by the 2-by-2 rotation -*> -*> R(k) = ( c(k) s(k) ) -*> = ( -s(k) c(k) ). -*> -*> When PIVOT = 'V' (Variable pivot), the rotation is performed -*> for the plane (k,k+1), i.e., P(k) has the form -*> -*> P(k) = ( 1 ) -*> ( ... ) -*> ( 1 ) -*> ( c(k) s(k) ) -*> ( -s(k) c(k) ) -*> ( 1 ) -*> ( ... ) -*> ( 1 ) -*> -*> where R(k) appears as a rank-2 modification to the identity matrix in -*> rows and columns k and k+1. -*> -*> When PIVOT = 'T' (Top pivot), the rotation is performed for the -*> plane (1,k+1), so P(k) has the form -*> -*> P(k) = ( c(k) s(k) ) -*> ( 1 ) -*> ( ... ) -*> ( 1 ) -*> ( -s(k) c(k) ) -*> ( 1 ) -*> ( ... ) -*> ( 1 ) -*> -*> where R(k) appears in rows and columns 1 and k+1. -*> -*> Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is -*> performed for the plane (k,z), giving P(k) the form -*> -*> P(k) = ( 1 ) -*> ( ... ) -*> ( 1 ) -*> ( c(k) s(k) ) -*> ( 1 ) -*> ( ... ) -*> ( 1 ) -*> ( -s(k) c(k) ) -*> -*> where R(k) appears in rows and columns k and z. The rotations are -*> performed without ever forming P(k) explicitly. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> Specifies whether the plane rotation matrix P is applied to -*> A on the left or the right. -*> = 'L': Left, compute A := P*A -*> = 'R': Right, compute A:= A*P**T -*> \endverbatim -*> -*> \param[in] PIVOT -*> \verbatim -*> PIVOT is CHARACTER*1 -*> Specifies the plane for which P(k) is a plane rotation -*> matrix. -*> = 'V': Variable pivot, the plane (k,k+1) -*> = 'T': Top pivot, the plane (1,k+1) -*> = 'B': Bottom pivot, the plane (k,z) -*> \endverbatim -*> -*> \param[in] DIRECT -*> \verbatim -*> DIRECT is CHARACTER*1 -*> Specifies whether P is a forward or backward sequence of -*> plane rotations. -*> = 'F': Forward, P = P(z-1)*...*P(2)*P(1) -*> = 'B': Backward, P = P(1)*P(2)*...*P(z-1) -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. If m <= 1, an immediate -*> return is effected. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. If n <= 1, an -*> immediate return is effected. -*> \endverbatim -*> -*> \param[in] C -*> \verbatim -*> C is DOUBLE PRECISION array, dimension -*> (M-1) if SIDE = 'L' -*> (N-1) if SIDE = 'R' -*> The cosines c(k) of the plane rotations. -*> \endverbatim -*> -*> \param[in] S -*> \verbatim -*> S is DOUBLE PRECISION array, dimension -*> (M-1) if SIDE = 'L' -*> (N-1) if SIDE = 'R' -*> The sines s(k) of the plane rotations. The 2-by-2 plane -*> rotation part of the matrix P(k), R(k), has the form -*> R(k) = ( c(k) s(k) ) -*> ( -s(k) c(k) ). -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,N) -*> The M-by-N matrix A. On exit, A is overwritten by P*A if -*> SIDE = 'R' or by A*P**T if SIDE = 'L'. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERauxiliary -* -* ===================================================================== - SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER DIRECT, PIVOT, SIDE - INTEGER LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION C( * ), S( * ) - COMPLEX*16 A( LDA, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, INFO, J - DOUBLE PRECISION CTEMP, STEMP - COMPLEX*16 TEMP -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN - INFO = 1 - ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT, - $ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN - INFO = 2 - ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) ) - $ THEN - INFO = 3 - ELSE IF( M.LT.0 ) THEN - INFO = 4 - ELSE IF( N.LT.0 ) THEN - INFO = 5 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = 9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZLASR ', INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) - $ RETURN - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form P * A -* - IF( LSAME( PIVOT, 'V' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 20 J = 1, M - 1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 10 I = 1, N - TEMP = A( J+1, I ) - A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) - A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) - 10 CONTINUE - END IF - 20 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 40 J = M - 1, 1, -1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 30 I = 1, N - TEMP = A( J+1, I ) - A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) - A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) - 30 CONTINUE - END IF - 40 CONTINUE - END IF - ELSE IF( LSAME( PIVOT, 'T' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 60 J = 2, M - CTEMP = C( J-1 ) - STEMP = S( J-1 ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 50 I = 1, N - TEMP = A( J, I ) - A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) - A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) - 50 CONTINUE - END IF - 60 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 80 J = M, 2, -1 - CTEMP = C( J-1 ) - STEMP = S( J-1 ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 70 I = 1, N - TEMP = A( J, I ) - A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) - A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) - 70 CONTINUE - END IF - 80 CONTINUE - END IF - ELSE IF( LSAME( PIVOT, 'B' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 100 J = 1, M - 1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 90 I = 1, N - TEMP = A( J, I ) - A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP - A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP - 90 CONTINUE - END IF - 100 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 120 J = M - 1, 1, -1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 110 I = 1, N - TEMP = A( J, I ) - A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP - A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP - 110 CONTINUE - END IF - 120 CONTINUE - END IF - END IF - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form A * P**T -* - IF( LSAME( PIVOT, 'V' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 140 J = 1, N - 1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 130 I = 1, M - TEMP = A( I, J+1 ) - A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) - A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) - 130 CONTINUE - END IF - 140 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 160 J = N - 1, 1, -1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 150 I = 1, M - TEMP = A( I, J+1 ) - A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) - A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) - 150 CONTINUE - END IF - 160 CONTINUE - END IF - ELSE IF( LSAME( PIVOT, 'T' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 180 J = 2, N - CTEMP = C( J-1 ) - STEMP = S( J-1 ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 170 I = 1, M - TEMP = A( I, J ) - A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) - A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) - 170 CONTINUE - END IF - 180 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 200 J = N, 2, -1 - CTEMP = C( J-1 ) - STEMP = S( J-1 ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 190 I = 1, M - TEMP = A( I, J ) - A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) - A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) - 190 CONTINUE - END IF - 200 CONTINUE - END IF - ELSE IF( LSAME( PIVOT, 'B' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 220 J = 1, N - 1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 210 I = 1, M - TEMP = A( I, J ) - A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP - A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP - 210 CONTINUE - END IF - 220 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 240 J = N - 1, 1, -1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 230 I = 1, M - TEMP = A( I, J ) - A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP - A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP - 230 CONTINUE - END IF - 240 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZLASR -* - END diff --git a/lib/linalg/zlassq.cpp b/lib/linalg/zlassq.cpp new file mode 100644 index 0000000000..b60831044f --- /dev/null +++ b/lib/linalg/zlassq.cpp @@ -0,0 +1,47 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int zlassq_(integer *n, doublecomplex *x, integer *incx, doublereal *scale, doublereal *sumsq) +{ + integer i__1, i__2, i__3; + doublereal d__1; + double d_lmp_imag(doublecomplex *); + integer ix; + doublereal temp1; + extern logical disnan_(doublereal *); + --x; + if (*n > 0) { + i__1 = (*n - 1) * *incx + 1; + i__2 = *incx; + for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { + i__3 = ix; + temp1 = (d__1 = x[i__3].r, abs(d__1)); + if (temp1 > 0. || disnan_(&temp1)) { + if (*scale < temp1) { + d__1 = *scale / temp1; + *sumsq = *sumsq * (d__1 * d__1) + 1; + *scale = temp1; + } else { + d__1 = temp1 / *scale; + *sumsq += d__1 * d__1; + } + } + temp1 = (d__1 = d_lmp_imag(&x[ix]), abs(d__1)); + if (temp1 > 0. || disnan_(&temp1)) { + if (*scale < temp1) { + d__1 = *scale / temp1; + *sumsq = *sumsq * (d__1 * d__1) + 1; + *scale = temp1; + } else { + d__1 = temp1 / *scale; + *sumsq += d__1 * d__1; + } + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zlassq.f b/lib/linalg/zlassq.f deleted file mode 100644 index fd13811bd9..0000000000 --- a/lib/linalg/zlassq.f +++ /dev/null @@ -1,168 +0,0 @@ -*> \brief \b ZLASSQ updates a sum of squares represented in scaled form. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLASSQ + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ ) -* -* .. Scalar Arguments .. -* INTEGER INCX, N -* DOUBLE PRECISION SCALE, SUMSQ -* .. -* .. Array Arguments .. -* COMPLEX*16 X( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLASSQ returns the values scl and ssq such that -*> -*> ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, -*> -*> where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is -*> assumed to be at least unity and the value of ssq will then satisfy -*> -*> 1.0 .le. ssq .le. ( sumsq + 2*n ). -*> -*> scale is assumed to be non-negative and scl returns the value -*> -*> scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ), -*> i -*> -*> scale and sumsq must be supplied in SCALE and SUMSQ respectively. -*> SCALE and SUMSQ are overwritten by scl and ssq respectively. -*> -*> The routine makes only one pass through the vector X. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of elements to be used from the vector X. -*> \endverbatim -*> -*> \param[in] X -*> \verbatim -*> X is COMPLEX*16 array, dimension (N) -*> The vector x as described above. -*> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> The increment between successive values of the vector X. -*> INCX > 0. -*> \endverbatim -*> -*> \param[in,out] SCALE -*> \verbatim -*> SCALE is DOUBLE PRECISION -*> On entry, the value scale in the equation above. -*> On exit, SCALE is overwritten with the value scl . -*> \endverbatim -*> -*> \param[in,out] SUMSQ -*> \verbatim -*> SUMSQ is DOUBLE PRECISION -*> On entry, the value sumsq in the equation above. -*> On exit, SUMSQ is overwritten with the value ssq . -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date December 2016 -* -*> \ingroup complex16OTHERauxiliary -* -* ===================================================================== - SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ ) -* -* -- LAPACK auxiliary routine (version 3.7.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* December 2016 -* -* .. Scalar Arguments .. - INTEGER INCX, N - DOUBLE PRECISION SCALE, SUMSQ -* .. -* .. Array Arguments .. - COMPLEX*16 X( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER IX - DOUBLE PRECISION TEMP1 -* .. -* .. External Functions .. - LOGICAL DISNAN - EXTERNAL DISNAN -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DIMAG -* .. -* .. Executable Statements .. -* - IF( N.GT.0 ) THEN - DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX - TEMP1 = ABS( DBLE( X( IX ) ) ) - IF( TEMP1.GT.ZERO.OR.DISNAN( TEMP1 ) ) THEN - IF( SCALE.LT.TEMP1 ) THEN - SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2 - SCALE = TEMP1 - ELSE - SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2 - END IF - END IF - TEMP1 = ABS( DIMAG( X( IX ) ) ) - IF( TEMP1.GT.ZERO.OR.DISNAN( TEMP1 ) ) THEN - IF( SCALE.LT.TEMP1 ) THEN - SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2 - SCALE = TEMP1 - ELSE - SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2 - END IF - END IF - 10 CONTINUE - END IF -* - RETURN -* -* End of ZLASSQ -* - END diff --git a/lib/linalg/zlatrd.cpp b/lib/linalg/zlatrd.cpp new file mode 100644 index 0000000000..4f2a1750df --- /dev/null +++ b/lib/linalg/zlatrd.cpp @@ -0,0 +1,207 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static doublecomplex c_b1 = {0., 0.}; +static doublecomplex c_b2 = {1., 0.}; +static integer c__1 = 1; +int zlatrd_(char *uplo, integer *n, integer *nb, doublecomplex *a, integer *lda, doublereal *e, + doublecomplex *tau, doublecomplex *w, integer *ldw, ftnlen uplo_len) +{ + integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3; + doublereal d__1; + doublecomplex z__1, z__2, z__3, z__4; + integer i__, iw; + doublecomplex alpha; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern int zscal_(integer *, doublecomplex *, doublecomplex *, integer *); + extern VOID zdotc_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, + integer *); + extern int zgemv_(char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, + ftnlen), + zhemv_(char *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *, ftnlen), + zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), + zlarfg_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *), + zlacgv_(integer *, doublecomplex *, integer *); + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --e; + --tau; + w_dim1 = *ldw; + w_offset = 1 + w_dim1; + w -= w_offset; + if (*n <= 0) { + return 0; + } + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + i__1 = *n - *nb + 1; + for (i__ = *n; i__ >= i__1; --i__) { + iw = i__ - *n + *nb; + if (i__ < *n) { + i__2 = i__ + i__ * a_dim1; + i__3 = i__ + i__ * a_dim1; + d__1 = a[i__3].r; + a[i__2].r = d__1, a[i__2].i = 0.; + i__2 = *n - i__; + zlacgv_(&i__2, &w[i__ + (iw + 1) * w_dim1], ldw); + i__2 = *n - i__; + z__1.r = -1., z__1.i = -0.; + zgemv_((char *)"No transpose", &i__, &i__2, &z__1, &a[(i__ + 1) * a_dim1 + 1], lda, + &w[i__ + (iw + 1) * w_dim1], ldw, &c_b2, &a[i__ * a_dim1 + 1], &c__1, + (ftnlen)12); + i__2 = *n - i__; + zlacgv_(&i__2, &w[i__ + (iw + 1) * w_dim1], ldw); + i__2 = *n - i__; + zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda); + i__2 = *n - i__; + z__1.r = -1., z__1.i = -0.; + zgemv_((char *)"No transpose", &i__, &i__2, &z__1, &w[(iw + 1) * w_dim1 + 1], ldw, + &a[i__ + (i__ + 1) * a_dim1], lda, &c_b2, &a[i__ * a_dim1 + 1], &c__1, + (ftnlen)12); + i__2 = *n - i__; + zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda); + i__2 = i__ + i__ * a_dim1; + i__3 = i__ + i__ * a_dim1; + d__1 = a[i__3].r; + a[i__2].r = d__1, a[i__2].i = 0.; + } + if (i__ > 1) { + i__2 = i__ - 1 + i__ * a_dim1; + alpha.r = a[i__2].r, alpha.i = a[i__2].i; + i__2 = i__ - 1; + zlarfg_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &tau[i__ - 1]); + e[i__ - 1] = alpha.r; + i__2 = i__ - 1 + i__ * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + i__2 = i__ - 1; + zhemv_((char *)"Upper", &i__2, &c_b2, &a[a_offset], lda, &a[i__ * a_dim1 + 1], &c__1, &c_b1, + &w[iw * w_dim1 + 1], &c__1, (ftnlen)5); + if (i__ < *n) { + i__2 = i__ - 1; + i__3 = *n - i__; + zgemv_((char *)"Conjugate transpose", &i__2, &i__3, &c_b2, &w[(iw + 1) * w_dim1 + 1], + ldw, &a[i__ * a_dim1 + 1], &c__1, &c_b1, &w[i__ + 1 + iw * w_dim1], + &c__1, (ftnlen)19); + i__2 = i__ - 1; + i__3 = *n - i__; + z__1.r = -1., z__1.i = -0.; + zgemv_((char *)"No transpose", &i__2, &i__3, &z__1, &a[(i__ + 1) * a_dim1 + 1], lda, + &w[i__ + 1 + iw * w_dim1], &c__1, &c_b2, &w[iw * w_dim1 + 1], &c__1, + (ftnlen)12); + i__2 = i__ - 1; + i__3 = *n - i__; + zgemv_((char *)"Conjugate transpose", &i__2, &i__3, &c_b2, &a[(i__ + 1) * a_dim1 + 1], + lda, &a[i__ * a_dim1 + 1], &c__1, &c_b1, &w[i__ + 1 + iw * w_dim1], + &c__1, (ftnlen)19); + i__2 = i__ - 1; + i__3 = *n - i__; + z__1.r = -1., z__1.i = -0.; + zgemv_((char *)"No transpose", &i__2, &i__3, &z__1, &w[(iw + 1) * w_dim1 + 1], ldw, + &w[i__ + 1 + iw * w_dim1], &c__1, &c_b2, &w[iw * w_dim1 + 1], &c__1, + (ftnlen)12); + } + i__2 = i__ - 1; + zscal_(&i__2, &tau[i__ - 1], &w[iw * w_dim1 + 1], &c__1); + z__3.r = -.5, z__3.i = -0.; + i__2 = i__ - 1; + z__2.r = z__3.r * tau[i__2].r - z__3.i * tau[i__2].i, + z__2.i = z__3.r * tau[i__2].i + z__3.i * tau[i__2].r; + i__3 = i__ - 1; + zdotc_(&z__4, &i__3, &w[iw * w_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &c__1); + z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, + z__1.i = z__2.r * z__4.i + z__2.i * z__4.r; + alpha.r = z__1.r, alpha.i = z__1.i; + i__2 = i__ - 1; + zaxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &w[iw * w_dim1 + 1], &c__1); + } + } + } else { + i__1 = *nb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * a_dim1; + i__3 = i__ + i__ * a_dim1; + d__1 = a[i__3].r; + a[i__2].r = d__1, a[i__2].i = 0.; + i__2 = i__ - 1; + zlacgv_(&i__2, &w[i__ + w_dim1], ldw); + i__2 = *n - i__ + 1; + i__3 = i__ - 1; + z__1.r = -1., z__1.i = -0.; + zgemv_((char *)"No transpose", &i__2, &i__3, &z__1, &a[i__ + a_dim1], lda, &w[i__ + w_dim1], + ldw, &c_b2, &a[i__ + i__ * a_dim1], &c__1, (ftnlen)12); + i__2 = i__ - 1; + zlacgv_(&i__2, &w[i__ + w_dim1], ldw); + i__2 = i__ - 1; + zlacgv_(&i__2, &a[i__ + a_dim1], lda); + i__2 = *n - i__ + 1; + i__3 = i__ - 1; + z__1.r = -1., z__1.i = -0.; + zgemv_((char *)"No transpose", &i__2, &i__3, &z__1, &w[i__ + w_dim1], ldw, &a[i__ + a_dim1], + lda, &c_b2, &a[i__ + i__ * a_dim1], &c__1, (ftnlen)12); + i__2 = i__ - 1; + zlacgv_(&i__2, &a[i__ + a_dim1], lda); + i__2 = i__ + i__ * a_dim1; + i__3 = i__ + i__ * a_dim1; + d__1 = a[i__3].r; + a[i__2].r = d__1, a[i__2].i = 0.; + if (i__ < *n) { + i__2 = i__ + 1 + i__ * a_dim1; + alpha.r = a[i__2].r, alpha.i = a[i__2].i; + i__2 = *n - i__; + i__3 = i__ + 2; + zlarfg_(&i__2, &alpha, &a[min(i__3, *n) + i__ * a_dim1], &c__1, &tau[i__]); + e[i__] = alpha.r; + i__2 = i__ + 1 + i__ * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + i__2 = *n - i__; + zhemv_((char *)"Lower", &i__2, &c_b2, &a[i__ + 1 + (i__ + 1) * a_dim1], lda, + &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b1, &w[i__ + 1 + i__ * w_dim1], &c__1, + (ftnlen)5); + i__2 = *n - i__; + i__3 = i__ - 1; + zgemv_((char *)"Conjugate transpose", &i__2, &i__3, &c_b2, &w[i__ + 1 + w_dim1], ldw, + &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b1, &w[i__ * w_dim1 + 1], &c__1, + (ftnlen)19); + i__2 = *n - i__; + i__3 = i__ - 1; + z__1.r = -1., z__1.i = -0.; + zgemv_((char *)"No transpose", &i__2, &i__3, &z__1, &a[i__ + 1 + a_dim1], lda, + &w[i__ * w_dim1 + 1], &c__1, &c_b2, &w[i__ + 1 + i__ * w_dim1], &c__1, + (ftnlen)12); + i__2 = *n - i__; + i__3 = i__ - 1; + zgemv_((char *)"Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + a_dim1], lda, + &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b1, &w[i__ * w_dim1 + 1], &c__1, + (ftnlen)19); + i__2 = *n - i__; + i__3 = i__ - 1; + z__1.r = -1., z__1.i = -0.; + zgemv_((char *)"No transpose", &i__2, &i__3, &z__1, &w[i__ + 1 + w_dim1], ldw, + &w[i__ * w_dim1 + 1], &c__1, &c_b2, &w[i__ + 1 + i__ * w_dim1], &c__1, + (ftnlen)12); + i__2 = *n - i__; + zscal_(&i__2, &tau[i__], &w[i__ + 1 + i__ * w_dim1], &c__1); + z__3.r = -.5, z__3.i = -0.; + i__2 = i__; + z__2.r = z__3.r * tau[i__2].r - z__3.i * tau[i__2].i, + z__2.i = z__3.r * tau[i__2].i + z__3.i * tau[i__2].r; + i__3 = *n - i__; + zdotc_(&z__4, &i__3, &w[i__ + 1 + i__ * w_dim1], &c__1, &a[i__ + 1 + i__ * a_dim1], + &c__1); + z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, + z__1.i = z__2.r * z__4.i + z__2.i * z__4.r; + alpha.r = z__1.r, alpha.i = z__1.i; + i__2 = *n - i__; + zaxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &w[i__ + 1 + i__ * w_dim1], + &c__1); + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zlatrd.f b/lib/linalg/zlatrd.f deleted file mode 100644 index ee2a484723..0000000000 --- a/lib/linalg/zlatrd.f +++ /dev/null @@ -1,355 +0,0 @@ -*> \brief \b ZLATRD reduces the first nb rows and columns of a symmetric/Hermitian matrix A to real tridiagonal form by an unitary similarity transformation. -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLATRD + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER LDA, LDW, N, NB -* .. -* .. Array Arguments .. -* DOUBLE PRECISION E( * ) -* COMPLEX*16 A( LDA, * ), TAU( * ), W( LDW, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZLATRD reduces NB rows and columns of a complex Hermitian matrix A to -*> Hermitian tridiagonal form by a unitary similarity -*> transformation Q**H * A * Q, and returns the matrices V and W which are -*> needed to apply the transformation to the unreduced part of A. -*> -*> If UPLO = 'U', ZLATRD reduces the last NB rows and columns of a -*> matrix, of which the upper triangle is supplied; -*> if UPLO = 'L', ZLATRD reduces the first NB rows and columns of a -*> matrix, of which the lower triangle is supplied. -*> -*> This is an auxiliary routine called by ZHETRD. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> Specifies whether the upper or lower triangular part of the -*> Hermitian matrix A is stored: -*> = 'U': Upper triangular -*> = 'L': Lower triangular -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. -*> \endverbatim -*> -*> \param[in] NB -*> \verbatim -*> NB is INTEGER -*> The number of rows and columns to be reduced. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,N) -*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading -*> n-by-n upper triangular part of A contains the upper -*> triangular part of the matrix A, and the strictly lower -*> triangular part of A is not referenced. If UPLO = 'L', the -*> leading n-by-n lower triangular part of A contains the lower -*> triangular part of the matrix A, and the strictly upper -*> triangular part of A is not referenced. -*> On exit: -*> if UPLO = 'U', the last NB columns have been reduced to -*> tridiagonal form, with the diagonal elements overwriting -*> the diagonal elements of A; the elements above the diagonal -*> with the array TAU, represent the unitary matrix Q as a -*> product of elementary reflectors; -*> if UPLO = 'L', the first NB columns have been reduced to -*> tridiagonal form, with the diagonal elements overwriting -*> the diagonal elements of A; the elements below the diagonal -*> with the array TAU, represent the unitary matrix Q as a -*> product of elementary reflectors. -*> See Further Details. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,N). -*> \endverbatim -*> -*> \param[out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N-1) -*> If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal -*> elements of the last NB columns of the reduced matrix; -*> if UPLO = 'L', E(1:nb) contains the subdiagonal elements of -*> the first NB columns of the reduced matrix. -*> \endverbatim -*> -*> \param[out] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension (N-1) -*> The scalar factors of the elementary reflectors, stored in -*> TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. -*> See Further Details. -*> \endverbatim -*> -*> \param[out] W -*> \verbatim -*> W is COMPLEX*16 array, dimension (LDW,NB) -*> The n-by-nb matrix W required to update the unreduced part -*> of A. -*> \endverbatim -*> -*> \param[in] LDW -*> \verbatim -*> LDW is INTEGER -*> The leading dimension of the array W. LDW >= max(1,N). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERauxiliary -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> If UPLO = 'U', the matrix Q is represented as a product of elementary -*> reflectors -*> -*> Q = H(n) H(n-1) . . . H(n-nb+1). -*> -*> Each H(i) has the form -*> -*> H(i) = I - tau * v * v**H -*> -*> where tau is a complex scalar, and v is a complex vector with -*> v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), -*> and tau in TAU(i-1). -*> -*> If UPLO = 'L', the matrix Q is represented as a product of elementary -*> reflectors -*> -*> Q = H(1) H(2) . . . H(nb). -*> -*> Each H(i) has the form -*> -*> H(i) = I - tau * v * v**H -*> -*> where tau is a complex scalar, and v is a complex vector with -*> v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), -*> and tau in TAU(i). -*> -*> The elements of the vectors v together form the n-by-nb matrix V -*> which is needed, with W, to apply the transformation to the unreduced -*> part of the matrix, using a Hermitian rank-2k update of the form: -*> A := A - V*W**H - W*V**H. -*> -*> The contents of A on exit are illustrated by the following examples -*> with n = 5 and nb = 2: -*> -*> if UPLO = 'U': if UPLO = 'L': -*> -*> ( a a a v4 v5 ) ( d ) -*> ( a a v4 v5 ) ( 1 d ) -*> ( a 1 v5 ) ( v1 1 a ) -*> ( d 1 ) ( v1 v2 a a ) -*> ( d ) ( v1 v2 a a a ) -*> -*> where d denotes a diagonal element of the reduced matrix, a denotes -*> an element of the original matrix that is unchanged, and vi denotes -*> an element of the vector defining H(i). -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) -* -* -- LAPACK auxiliary routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, LDW, N, NB -* .. -* .. Array Arguments .. - DOUBLE PRECISION E( * ) - COMPLEX*16 A( LDA, * ), TAU( * ), W( LDW, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO, ONE, HALF - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), - $ ONE = ( 1.0D+0, 0.0D+0 ), - $ HALF = ( 0.5D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, IW - COMPLEX*16 ALPHA -* .. -* .. External Subroutines .. - EXTERNAL ZAXPY, ZGEMV, ZHEMV, ZLACGV, ZLARFG, ZSCAL -* .. -* .. External Functions .. - LOGICAL LSAME - COMPLEX*16 ZDOTC - EXTERNAL LSAME, ZDOTC -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, MIN -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* - IF( LSAME( UPLO, 'U' ) ) THEN -* -* Reduce last NB columns of upper triangle -* - DO 10 I = N, N - NB + 1, -1 - IW = I - N + NB - IF( I.LT.N ) THEN -* -* Update A(1:i,i) -* - A( I, I ) = DBLE( A( I, I ) ) - CALL ZLACGV( N-I, W( I, IW+1 ), LDW ) - CALL ZGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ), - $ LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 ) - CALL ZLACGV( N-I, W( I, IW+1 ), LDW ) - CALL ZLACGV( N-I, A( I, I+1 ), LDA ) - CALL ZGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ), - $ LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 ) - CALL ZLACGV( N-I, A( I, I+1 ), LDA ) - A( I, I ) = DBLE( A( I, I ) ) - END IF - IF( I.GT.1 ) THEN -* -* Generate elementary reflector H(i) to annihilate -* A(1:i-2,i) -* - ALPHA = A( I-1, I ) - CALL ZLARFG( I-1, ALPHA, A( 1, I ), 1, TAU( I-1 ) ) - E( I-1 ) = DBLE( ALPHA ) - A( I-1, I ) = ONE -* -* Compute W(1:i-1,i) -* - CALL ZHEMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1, - $ ZERO, W( 1, IW ), 1 ) - IF( I.LT.N ) THEN - CALL ZGEMV( 'Conjugate transpose', I-1, N-I, ONE, - $ W( 1, IW+1 ), LDW, A( 1, I ), 1, ZERO, - $ W( I+1, IW ), 1 ) - CALL ZGEMV( 'No transpose', I-1, N-I, -ONE, - $ A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE, - $ W( 1, IW ), 1 ) - CALL ZGEMV( 'Conjugate transpose', I-1, N-I, ONE, - $ A( 1, I+1 ), LDA, A( 1, I ), 1, ZERO, - $ W( I+1, IW ), 1 ) - CALL ZGEMV( 'No transpose', I-1, N-I, -ONE, - $ W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE, - $ W( 1, IW ), 1 ) - END IF - CALL ZSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 ) - ALPHA = -HALF*TAU( I-1 )*ZDOTC( I-1, W( 1, IW ), 1, - $ A( 1, I ), 1 ) - CALL ZAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 ) - END IF -* - 10 CONTINUE - ELSE -* -* Reduce first NB columns of lower triangle -* - DO 20 I = 1, NB -* -* Update A(i:n,i) -* - A( I, I ) = DBLE( A( I, I ) ) - CALL ZLACGV( I-1, W( I, 1 ), LDW ) - CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ), - $ LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 ) - CALL ZLACGV( I-1, W( I, 1 ), LDW ) - CALL ZLACGV( I-1, A( I, 1 ), LDA ) - CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ), - $ LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 ) - CALL ZLACGV( I-1, A( I, 1 ), LDA ) - A( I, I ) = DBLE( A( I, I ) ) - IF( I.LT.N ) THEN -* -* Generate elementary reflector H(i) to annihilate -* A(i+2:n,i) -* - ALPHA = A( I+1, I ) - CALL ZLARFG( N-I, ALPHA, A( MIN( I+2, N ), I ), 1, - $ TAU( I ) ) - E( I ) = DBLE( ALPHA ) - A( I+1, I ) = ONE -* -* Compute W(i+1:n,i) -* - CALL ZHEMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA, - $ A( I+1, I ), 1, ZERO, W( I+1, I ), 1 ) - CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE, - $ W( I+1, 1 ), LDW, A( I+1, I ), 1, ZERO, - $ W( 1, I ), 1 ) - CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ), - $ LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) - CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE, - $ A( I+1, 1 ), LDA, A( I+1, I ), 1, ZERO, - $ W( 1, I ), 1 ) - CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ), - $ LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) - CALL ZSCAL( N-I, TAU( I ), W( I+1, I ), 1 ) - ALPHA = -HALF*TAU( I )*ZDOTC( N-I, W( I+1, I ), 1, - $ A( I+1, I ), 1 ) - CALL ZAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 ) - END IF -* - 20 CONTINUE - END IF -* - RETURN -* -* End of ZLATRD -* - END diff --git a/lib/linalg/zpptrf.cpp b/lib/linalg/zpptrf.cpp new file mode 100644 index 0000000000..7c7049c6a1 --- /dev/null +++ b/lib/linalg/zpptrf.cpp @@ -0,0 +1,97 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +static doublereal c_b16 = -1.; +int zpptrf_(char *uplo, integer *n, doublecomplex *ap, integer *info, ftnlen uplo_len) +{ + integer i__1, i__2, i__3; + doublereal d__1; + doublecomplex z__1; + double sqrt(doublereal); + integer j, jc, jj; + doublereal ajj; + extern int zhpr_(char *, integer *, doublereal *, doublecomplex *, integer *, doublecomplex *, + ftnlen); + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern VOID zdotc_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, + integer *); + logical upper; + extern int ztpsv_(char *, char *, char *, integer *, doublecomplex *, doublecomplex *, + integer *, ftnlen, ftnlen, ftnlen), + xerbla_(char *, integer *, ftnlen), + zdscal_(integer *, doublereal *, doublecomplex *, integer *); + --ap; + *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; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"ZPPTRF", &i__1, (ftnlen)6); + return 0; + } + if (*n == 0) { + return 0; + } + if (upper) { + jj = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + jc = jj + 1; + jj += j; + if (j > 1) { + i__2 = j - 1; + ztpsv_((char *)"Upper", (char *)"Conjugate transpose", (char *)"Non-unit", &i__2, &ap[1], &ap[jc], &c__1, + (ftnlen)5, (ftnlen)19, (ftnlen)8); + } + i__2 = jj; + i__3 = j - 1; + zdotc_(&z__1, &i__3, &ap[jc], &c__1, &ap[jc], &c__1); + ajj = ap[i__2].r - z__1.r; + if (ajj <= 0.) { + i__2 = jj; + ap[i__2].r = ajj, ap[i__2].i = 0.; + goto L30; + } + i__2 = jj; + d__1 = sqrt(ajj); + ap[i__2].r = d__1, ap[i__2].i = 0.; + } + } else { + jj = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jj; + ajj = ap[i__2].r; + if (ajj <= 0.) { + i__2 = jj; + ap[i__2].r = ajj, ap[i__2].i = 0.; + goto L30; + } + ajj = sqrt(ajj); + i__2 = jj; + ap[i__2].r = ajj, ap[i__2].i = 0.; + if (j < *n) { + i__2 = *n - j; + d__1 = 1. / ajj; + zdscal_(&i__2, &d__1, &ap[jj + 1], &c__1); + i__2 = *n - j; + zhpr_((char *)"Lower", &i__2, &c_b16, &ap[jj + 1], &c__1, &ap[jj + *n - j + 1], (ftnlen)5); + jj = jj + *n - j + 1; + } + } + } + goto L40; +L30: + *info = j; +L40: + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zpptrf.f b/lib/linalg/zpptrf.f deleted file mode 100644 index a34d639131..0000000000 --- a/lib/linalg/zpptrf.f +++ /dev/null @@ -1,238 +0,0 @@ -*> \brief \b ZPPTRF -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZPPTRF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZPPTRF( UPLO, N, AP, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, N -* .. -* .. Array Arguments .. -* COMPLEX*16 AP( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZPPTRF computes the Cholesky factorization of a complex Hermitian -*> positive definite matrix A stored in packed format. -*> -*> The factorization has the form -*> A = U**H * U, if UPLO = 'U', or -*> A = L * L**H, if UPLO = 'L', -*> where U is an upper triangular matrix and L is lower triangular. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A is stored; -*> = 'L': Lower triangle of A is stored. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] AP -*> \verbatim -*> AP is COMPLEX*16 array, dimension (N*(N+1)/2) -*> On entry, the upper or lower triangle of the Hermitian matrix -*> A, packed columnwise in a linear array. The j-th column of A -*> is stored in the array AP as follows: -*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; -*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. -*> See below for further details. -*> -*> On exit, if INFO = 0, the triangular factor U or L from the -*> Cholesky factorization A = U**H*U or A = L*L**H, in the same -*> storage format as A. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> > 0: if INFO = i, the leading minor of order i is not -*> positive definite, and the factorization could not be -*> completed. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> The packed storage scheme is illustrated by the following example -*> when N = 4, UPLO = 'U': -*> -*> Two-dimensional storage of the Hermitian matrix A: -*> -*> a11 a12 a13 a14 -*> a22 a23 a24 -*> a33 a34 (aij = conjg(aji)) -*> a44 -*> -*> Packed storage of the upper triangle of A: -*> -*> AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZPPTRF( UPLO, N, AP, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, N -* .. -* .. Array Arguments .. - COMPLEX*16 AP( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER J, JC, JJ - DOUBLE PRECISION AJJ -* .. -* .. External Functions .. - LOGICAL LSAME - COMPLEX*16 ZDOTC - EXTERNAL LSAME, ZDOTC -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZDSCAL, ZHPR, ZTPSV -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZPPTRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Compute the Cholesky factorization A = U**H * U. -* - JJ = 0 - DO 10 J = 1, N - JC = JJ + 1 - JJ = JJ + J -* -* Compute elements 1:J-1 of column J. -* - IF( J.GT.1 ) - $ CALL ZTPSV( 'Upper', 'Conjugate transpose', 'Non-unit', - $ J-1, AP, AP( JC ), 1 ) -* -* Compute U(J,J) and test for non-positive-definiteness. -* - AJJ = DBLE( AP( JJ ) ) - DBLE( ZDOTC( J-1, - $ AP( JC ), 1, AP( JC ), 1 ) ) - IF( AJJ.LE.ZERO ) THEN - AP( JJ ) = AJJ - GO TO 30 - END IF - AP( JJ ) = SQRT( AJJ ) - 10 CONTINUE - ELSE -* -* Compute the Cholesky factorization A = L * L**H. -* - JJ = 1 - DO 20 J = 1, N -* -* Compute L(J,J) and test for non-positive-definiteness. -* - AJJ = DBLE( AP( JJ ) ) - IF( AJJ.LE.ZERO ) THEN - AP( JJ ) = AJJ - GO TO 30 - END IF - AJJ = SQRT( AJJ ) - AP( JJ ) = AJJ -* -* Compute elements J+1:N of column J and update the trailing -* submatrix. -* - IF( J.LT.N ) THEN - CALL ZDSCAL( N-J, ONE / AJJ, AP( JJ+1 ), 1 ) - CALL ZHPR( 'Lower', N-J, -ONE, AP( JJ+1 ), 1, - $ AP( JJ+N-J+1 ) ) - JJ = JJ + N - J + 1 - END IF - 20 CONTINUE - END IF - GO TO 40 -* - 30 CONTINUE - INFO = J -* - 40 CONTINUE - RETURN -* -* End of ZPPTRF -* - END diff --git a/lib/linalg/zpptri.cpp b/lib/linalg/zpptri.cpp new file mode 100644 index 0000000000..947af9b38d --- /dev/null +++ b/lib/linalg/zpptri.cpp @@ -0,0 +1,82 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static doublereal c_b8 = 1.; +static integer c__1 = 1; +int zpptri_(char *uplo, integer *n, doublecomplex *ap, integer *info, ftnlen uplo_len) +{ + integer i__1, i__2, i__3; + doublereal d__1; + doublecomplex z__1; + integer j, jc, jj; + doublereal ajj; + integer jjn; + extern int zhpr_(char *, integer *, doublereal *, doublecomplex *, integer *, doublecomplex *, + ftnlen); + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern VOID zdotc_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, + integer *); + logical upper; + extern int ztpmv_(char *, char *, char *, integer *, doublecomplex *, doublecomplex *, + integer *, ftnlen, ftnlen, ftnlen), + xerbla_(char *, integer *, ftnlen), + zdscal_(integer *, doublereal *, doublecomplex *, integer *), + ztptri_(char *, char *, integer *, doublecomplex *, integer *, ftnlen, ftnlen); + --ap; + *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; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"ZPPTRI", &i__1, (ftnlen)6); + return 0; + } + if (*n == 0) { + return 0; + } + ztptri_(uplo, (char *)"Non-unit", n, &ap[1], info, (ftnlen)1, (ftnlen)8); + if (*info > 0) { + return 0; + } + if (upper) { + jj = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + jc = jj + 1; + jj += j; + if (j > 1) { + i__2 = j - 1; + zhpr_((char *)"Upper", &i__2, &c_b8, &ap[jc], &c__1, &ap[1], (ftnlen)5); + } + i__2 = jj; + ajj = ap[i__2].r; + zdscal_(&j, &ajj, &ap[jc], &c__1); + } + } else { + jj = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + jjn = jj + *n - j + 1; + i__2 = jj; + i__3 = *n - j + 1; + zdotc_(&z__1, &i__3, &ap[jj], &c__1, &ap[jj], &c__1); + d__1 = z__1.r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + if (j < *n) { + i__2 = *n - j; + ztpmv_((char *)"Lower", (char *)"Conjugate transpose", (char *)"Non-unit", &i__2, &ap[jjn], &ap[jj + 1], + &c__1, (ftnlen)5, (ftnlen)19, (ftnlen)8); + } + jj = jjn; + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zpptri.f b/lib/linalg/zpptri.f deleted file mode 100644 index a74466eb80..0000000000 --- a/lib/linalg/zpptri.f +++ /dev/null @@ -1,187 +0,0 @@ -*> \brief \b ZPPTRI -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZPPTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZPPTRI( UPLO, N, AP, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, N -* .. -* .. Array Arguments .. -* COMPLEX*16 AP( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZPPTRI computes the inverse of a complex Hermitian positive definite -*> matrix A using the Cholesky factorization A = U**H*U or A = L*L**H -*> computed by ZPPTRF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangular factor is stored in AP; -*> = 'L': Lower triangular factor is stored in AP. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] AP -*> \verbatim -*> AP is COMPLEX*16 array, dimension (N*(N+1)/2) -*> On entry, the triangular factor U or L from the Cholesky -*> factorization A = U**H*U or A = L*L**H, packed columnwise as -*> a linear array. The j-th column of U or L is stored in the -*> array AP as follows: -*> if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; -*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. -*> -*> On exit, the upper or lower triangle of the (Hermitian) -*> inverse of A, overwriting the input factor U or L. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> > 0: if INFO = i, the (i,i) element of the factor U or L is -*> zero, and the inverse could not be computed. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZPPTRI( UPLO, N, AP, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, N -* .. -* .. Array Arguments .. - COMPLEX*16 AP( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER J, JC, JJ, JJN - DOUBLE PRECISION AJJ -* .. -* .. External Functions .. - LOGICAL LSAME - COMPLEX*16 ZDOTC - EXTERNAL LSAME, ZDOTC -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZDSCAL, ZHPR, ZTPMV, ZTPTRI -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZPPTRI', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Invert the triangular Cholesky factor U or L. -* - CALL ZTPTRI( UPLO, 'Non-unit', N, AP, INFO ) - IF( INFO.GT.0 ) - $ RETURN - IF( UPPER ) THEN -* -* Compute the product inv(U) * inv(U)**H. -* - JJ = 0 - DO 10 J = 1, N - JC = JJ + 1 - JJ = JJ + J - IF( J.GT.1 ) - $ CALL ZHPR( 'Upper', J-1, ONE, AP( JC ), 1, AP ) - AJJ = DBLE( AP( JJ ) ) - CALL ZDSCAL( J, AJJ, AP( JC ), 1 ) - 10 CONTINUE -* - ELSE -* -* Compute the product inv(L)**H * inv(L). -* - JJ = 1 - DO 20 J = 1, N - JJN = JJ + N - J + 1 - AP( JJ ) = DBLE( ZDOTC( N-J+1, AP( JJ ), 1, AP( JJ ), 1 ) ) - IF( J.LT.N ) - $ CALL ZTPMV( 'Lower', 'Conjugate transpose', 'Non-unit', - $ N-J, AP( JJN ), AP( JJ+1 ), 1 ) - JJ = JJN - 20 CONTINUE - END IF -* - RETURN -* -* End of ZPPTRI -* - END diff --git a/lib/linalg/zscal.cpp b/lib/linalg/zscal.cpp new file mode 100644 index 0000000000..ee91d39b21 --- /dev/null +++ b/lib/linalg/zscal.cpp @@ -0,0 +1,39 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int zscal_(integer *n, doublecomplex *za, doublecomplex *zx, integer *incx) +{ + integer i__1, i__2, i__3, i__4; + doublecomplex z__1; + integer i__, nincx; + --zx; + if (*n <= 0 || *incx <= 0 || za->r == 1. && za->i == 0.) { + return 0; + } + if (*incx == 1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + z__1.r = za->r * zx[i__3].r - za->i * zx[i__3].i, + z__1.i = za->r * zx[i__3].i + za->i * zx[i__3].r; + zx[i__2].r = z__1.r, zx[i__2].i = z__1.i; + } + } else { + nincx = *n * *incx; + i__1 = nincx; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + i__3 = i__; + i__4 = i__; + z__1.r = za->r * zx[i__4].r - za->i * zx[i__4].i, + z__1.i = za->r * zx[i__4].i + za->i * zx[i__4].r; + zx[i__3].r = z__1.r, zx[i__3].i = z__1.i; + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zscal.f b/lib/linalg/zscal.f deleted file mode 100644 index 8b8c2c8ab5..0000000000 --- a/lib/linalg/zscal.f +++ /dev/null @@ -1,121 +0,0 @@ -*> \brief \b ZSCAL -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE ZSCAL(N,ZA,ZX,INCX) -* -* .. Scalar Arguments .. -* COMPLEX*16 ZA -* INTEGER INCX,N -* .. -* .. Array Arguments .. -* COMPLEX*16 ZX(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZSCAL scales a vector by a constant. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> number of elements in input vector(s) -*> \endverbatim -*> -*> \param[in] ZA -*> \verbatim -*> ZA is COMPLEX*16 -*> On entry, ZA specifies the scalar alpha. -*> \endverbatim -*> -*> \param[in,out] ZX -*> \verbatim -*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> storage spacing between elements of ZX -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16_blas_level1 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> jack dongarra, 3/11/78. -*> modified 3/93 to return if incx .le. 0. -*> modified 12/3/93, array(1) declarations changed to array(*) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZSCAL(N,ZA,ZX,INCX) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - COMPLEX*16 ZA - INTEGER INCX,N -* .. -* .. Array Arguments .. - COMPLEX*16 ZX(*) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I,NINCX -* .. -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER (ONE= (1.0D+0,0.0D+0)) -* .. - IF (N.LE.0 .OR. INCX.LE.0 .OR. ZA.EQ.ONE) RETURN - IF (INCX.EQ.1) THEN -* -* code for increment equal to 1 -* - DO I = 1,N - ZX(I) = ZA*ZX(I) - END DO - ELSE -* -* code for increment not equal to 1 -* - NINCX = N*INCX - DO I = 1,NINCX,INCX - ZX(I) = ZA*ZX(I) - END DO - END IF - RETURN -* -* End of ZSCAL -* - END diff --git a/lib/linalg/zstedc.cpp b/lib/linalg/zstedc.cpp new file mode 100644 index 0000000000..99804fef30 --- /dev/null +++ b/lib/linalg/zstedc.cpp @@ -0,0 +1,237 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__9 = 9; +static integer c__0 = 0; +static integer c__2 = 2; +static doublereal c_b17 = 0.; +static doublereal c_b18 = 1.; +static integer c__1 = 1; +int zstedc_(char *compz, integer *n, doublereal *d__, doublereal *e, doublecomplex *z__, + integer *ldz, doublecomplex *work, integer *lwork, doublereal *rwork, integer *lrwork, + integer *iwork, integer *liwork, integer *info, ftnlen compz_len) +{ + integer z_dim1, z_offset, i__1, i__2, i__3, i__4; + doublereal d__1, d__2; + double log(doublereal); + integer pow_lmp_ii(integer *, integer *); + double sqrt(doublereal); + integer i__, j, k, m; + doublereal p; + integer ii, ll, lgn; + doublereal eps, tiny; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + integer lwmin, start; + extern int zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), + zlaed0_(integer *, integer *, doublereal *, doublereal *, doublecomplex *, integer *, + doublecomplex *, integer *, doublereal *, integer *, integer *); + extern doublereal dlamch_(char *, ftnlen); + extern int dlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, + integer *, doublereal *, integer *, integer *, ftnlen), + dstedc_(char *, integer *, doublereal *, doublereal *, doublereal *, integer *, + doublereal *, integer *, integer *, integer *, integer *, ftnlen), + 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); + integer finish; + extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *, ftnlen); + extern int dsterf_(integer *, doublereal *, doublereal *, integer *), + zlacrm_(integer *, integer *, doublecomplex *, integer *, doublereal *, integer *, + doublecomplex *, integer *, doublereal *); + integer liwmin, icompz; + extern int dsteqr_(char *, integer *, doublereal *, doublereal *, doublereal *, integer *, + doublereal *, integer *, ftnlen), + zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, + integer *, ftnlen); + doublereal orgnrm; + integer lrwmin; + logical lquery; + integer smlsiz; + extern int zsteqr_(char *, integer *, doublereal *, doublereal *, doublecomplex *, integer *, + doublereal *, integer *, ftnlen); + --d__; + --e; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + --rwork; + --iwork; + *info = 0; + lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1; + if (lsame_(compz, (char *)"N", (ftnlen)1, (ftnlen)1)) { + icompz = 0; + } else if (lsame_(compz, (char *)"V", (ftnlen)1, (ftnlen)1)) { + icompz = 1; + } else if (lsame_(compz, (char *)"I", (ftnlen)1, (ftnlen)1)) { + icompz = 2; + } else { + icompz = -1; + } + if (icompz < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*ldz < 1 || icompz > 0 && *ldz < max(1, *n)) { + *info = -6; + } + if (*info == 0) { + smlsiz = ilaenv_(&c__9, (char *)"ZSTEDC", (char *)" ", &c__0, &c__0, &c__0, &c__0, (ftnlen)6, (ftnlen)1); + if (*n <= 1 || icompz == 0) { + lwmin = 1; + liwmin = 1; + lrwmin = 1; + } else if (*n <= smlsiz) { + lwmin = 1; + liwmin = 1; + lrwmin = *n - 1 << 1; + } else if (icompz == 1) { + lgn = (integer)(log((doublereal)(*n)) / log(2.)); + if (pow_lmp_ii(&c__2, &lgn) < *n) { + ++lgn; + } + if (pow_lmp_ii(&c__2, &lgn) < *n) { + ++lgn; + } + lwmin = *n * *n; + i__1 = *n; + lrwmin = *n * 3 + 1 + (*n << 1) * lgn + (i__1 * i__1 << 2); + liwmin = *n * 6 + 6 + *n * 5 * lgn; + } else if (icompz == 2) { + lwmin = 1; + i__1 = *n; + lrwmin = (*n << 2) + 1 + (i__1 * i__1 << 1); + liwmin = *n * 5 + 3; + } + work[1].r = (doublereal)lwmin, work[1].i = 0.; + rwork[1] = (doublereal)lrwmin; + iwork[1] = liwmin; + if (*lwork < lwmin && !lquery) { + *info = -8; + } else if (*lrwork < lrwmin && !lquery) { + *info = -10; + } else if (*liwork < liwmin && !lquery) { + *info = -12; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"ZSTEDC", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + if (*n == 0) { + return 0; + } + if (*n == 1) { + if (icompz != 0) { + i__1 = z_dim1 + 1; + z__[i__1].r = 1., z__[i__1].i = 0.; + } + return 0; + } + if (icompz == 0) { + dsterf_(n, &d__[1], &e[1], info); + goto L70; + } + if (*n <= smlsiz) { + zsteqr_(compz, n, &d__[1], &e[1], &z__[z_offset], ldz, &rwork[1], info, (ftnlen)1); + } else { + if (icompz == 2) { + dlaset_((char *)"Full", n, n, &c_b17, &c_b18, &rwork[1], n, (ftnlen)4); + ll = *n * *n + 1; + i__1 = *lrwork - ll + 1; + dstedc_((char *)"I", n, &d__[1], &e[1], &rwork[1], n, &rwork[ll], &i__1, &iwork[1], liwork, + info, (ftnlen)1); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * z_dim1; + i__4 = (j - 1) * *n + i__; + z__[i__3].r = rwork[i__4], z__[i__3].i = 0.; + } + } + goto L70; + } + orgnrm = dlanst_((char *)"M", n, &d__[1], &e[1], (ftnlen)1); + if (orgnrm == 0.) { + goto L70; + } + eps = dlamch_((char *)"Epsilon", (ftnlen)7); + start = 1; + L30: + if (start <= *n) { + finish = start; + L40: + if (finish < *n) { + tiny = eps * sqrt((d__1 = d__[finish], abs(d__1))) * + sqrt((d__2 = d__[finish + 1], abs(d__2))); + if ((d__1 = e[finish], abs(d__1)) > tiny) { + ++finish; + goto L40; + } + } + m = finish - start + 1; + if (m > smlsiz) { + orgnrm = dlanst_((char *)"M", &m, &d__[start], &e[start], (ftnlen)1); + dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b18, &m, &c__1, &d__[start], &m, info, + (ftnlen)1); + i__1 = m - 1; + i__2 = m - 1; + dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b18, &i__1, &c__1, &e[start], &i__2, info, + (ftnlen)1); + zlaed0_(n, &m, &d__[start], &e[start], &z__[start * z_dim1 + 1], ldz, &work[1], n, + &rwork[1], &iwork[1], info); + if (*info > 0) { + *info = (*info / (m + 1) + start - 1) * (*n + 1) + *info % (m + 1) + start - 1; + goto L70; + } + dlascl_((char *)"G", &c__0, &c__0, &c_b18, &orgnrm, &m, &c__1, &d__[start], &m, info, + (ftnlen)1); + } else { + dsteqr_((char *)"I", &m, &d__[start], &e[start], &rwork[1], &m, &rwork[m * m + 1], info, + (ftnlen)1); + zlacrm_(n, &m, &z__[start * z_dim1 + 1], ldz, &rwork[1], &m, &work[1], n, + &rwork[m * m + 1]); + zlacpy_((char *)"A", n, &m, &work[1], n, &z__[start * z_dim1 + 1], ldz, (ftnlen)1); + if (*info > 0) { + *info = start * (*n + 1) + finish; + goto L70; + } + } + start = finish + 1; + goto L30; + } + i__1 = *n; + for (ii = 2; ii <= i__1; ++ii) { + i__ = ii - 1; + k = i__; + p = d__[i__]; + i__2 = *n; + for (j = ii; j <= i__2; ++j) { + if (d__[j] < p) { + k = j; + p = d__[j]; + } + } + if (k != i__) { + d__[k] = d__[i__]; + d__[i__] = p; + zswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1], &c__1); + } + } + } +L70: + work[1].r = (doublereal)lwmin, work[1].i = 0.; + rwork[1] = (doublereal)lrwmin; + iwork[1] = liwmin; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zstedc.f b/lib/linalg/zstedc.f deleted file mode 100644 index 74d390af7e..0000000000 --- a/lib/linalg/zstedc.f +++ /dev/null @@ -1,483 +0,0 @@ -*> \brief \b ZSTEDC -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZSTEDC + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK, -* LRWORK, IWORK, LIWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER COMPZ -* INTEGER INFO, LDZ, LIWORK, LRWORK, LWORK, N -* .. -* .. Array Arguments .. -* INTEGER IWORK( * ) -* DOUBLE PRECISION D( * ), E( * ), RWORK( * ) -* COMPLEX*16 WORK( * ), Z( LDZ, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZSTEDC computes all eigenvalues and, optionally, eigenvectors of a -*> symmetric tridiagonal matrix using the divide and conquer method. -*> The eigenvectors of a full or band complex Hermitian matrix can also -*> be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this -*> matrix to tridiagonal form. -*> -*> This code makes very mild assumptions about floating point -*> arithmetic. It will work on machines with a guard digit in -*> add/subtract, or on those binary machines without guard digits -*> which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. -*> It could conceivably fail on hexadecimal or decimal machines -*> without guard digits, but we know of none. See DLAED3 for details. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] COMPZ -*> \verbatim -*> COMPZ is CHARACTER*1 -*> = 'N': Compute eigenvalues only. -*> = 'I': Compute eigenvectors of tridiagonal matrix also. -*> = 'V': Compute eigenvectors of original Hermitian matrix -*> also. On entry, Z contains the unitary matrix used -*> to reduce the original matrix to tridiagonal form. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The dimension of the symmetric tridiagonal matrix. N >= 0. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, the diagonal elements of the tridiagonal matrix. -*> On exit, if INFO = 0, the eigenvalues in ascending order. -*> \endverbatim -*> -*> \param[in,out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N-1) -*> On entry, the subdiagonal elements of the tridiagonal matrix. -*> On exit, E has been destroyed. -*> \endverbatim -*> -*> \param[in,out] Z -*> \verbatim -*> Z is COMPLEX*16 array, dimension (LDZ,N) -*> On entry, if COMPZ = 'V', then Z contains the unitary -*> matrix used in the reduction to tridiagonal form. -*> On exit, if INFO = 0, then if COMPZ = 'V', Z contains the -*> orthonormal eigenvectors of the original Hermitian matrix, -*> and if COMPZ = 'I', Z contains the orthonormal eigenvectors -*> of the symmetric tridiagonal matrix. -*> If COMPZ = 'N', then Z is not referenced. -*> \endverbatim -*> -*> \param[in] LDZ -*> \verbatim -*> LDZ is INTEGER -*> The leading dimension of the array Z. LDZ >= 1. -*> If eigenvectors are desired, then LDZ >= max(1,N). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. -*> If COMPZ = 'N' or 'I', or N <= 1, LWORK must be at least 1. -*> If COMPZ = 'V' and N > 1, LWORK must be at least N*N. -*> Note that for COMPZ = 'V', then if N is less than or -*> equal to the minimum divide size, usually 25, then LWORK need -*> only be 1. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal sizes of the WORK, RWORK and -*> IWORK arrays, returns these values as the first entries of -*> the WORK, RWORK and IWORK arrays, and no error message -*> related to LWORK or LRWORK or LIWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] RWORK -*> \verbatim -*> RWORK is DOUBLE PRECISION array, dimension (MAX(1,LRWORK)) -*> On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK. -*> \endverbatim -*> -*> \param[in] LRWORK -*> \verbatim -*> LRWORK is INTEGER -*> The dimension of the array RWORK. -*> If COMPZ = 'N' or N <= 1, LRWORK must be at least 1. -*> If COMPZ = 'V' and N > 1, LRWORK must be at least -*> 1 + 3*N + 2*N*lg N + 4*N**2 , -*> where lg( N ) = smallest integer k such -*> that 2**k >= N. -*> If COMPZ = 'I' and N > 1, LRWORK must be at least -*> 1 + 4*N + 2*N**2 . -*> Note that for COMPZ = 'I' or 'V', then if N is less than or -*> equal to the minimum divide size, usually 25, then LRWORK -*> need only be max(1,2*(N-1)). -*> -*> If LRWORK = -1, then a workspace query is assumed; the -*> routine only calculates the optimal sizes of the WORK, RWORK -*> and IWORK arrays, returns these values as the first entries -*> of the WORK, RWORK and IWORK arrays, and no error message -*> related to LWORK or LRWORK or LIWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) -*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. -*> \endverbatim -*> -*> \param[in] LIWORK -*> \verbatim -*> LIWORK is INTEGER -*> The dimension of the array IWORK. -*> If COMPZ = 'N' or N <= 1, LIWORK must be at least 1. -*> If COMPZ = 'V' or N > 1, LIWORK must be at least -*> 6 + 6*N + 5*N*lg N. -*> If COMPZ = 'I' or N > 1, LIWORK must be at least -*> 3 + 5*N . -*> Note that for COMPZ = 'I' or 'V', then if N is less than or -*> equal to the minimum divide size, usually 25, then LIWORK -*> need only be 1. -*> -*> If LIWORK = -1, then a workspace query is assumed; the -*> routine only calculates the optimal sizes of the WORK, RWORK -*> and IWORK arrays, returns these values as the first entries -*> of the WORK, RWORK and IWORK arrays, and no error message -*> related to LWORK or LRWORK or LIWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit. -*> < 0: if INFO = -i, the i-th argument had an illegal value. -*> > 0: The algorithm failed to compute an eigenvalue while -*> working on the submatrix lying in rows and columns -*> INFO/(N+1) through mod(INFO,N+1). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -*> \par Contributors: -* ================== -*> -*> Jeff Rutter, Computer Science Division, University of California -*> at Berkeley, USA -* -* ===================================================================== - SUBROUTINE ZSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK, - $ LRWORK, IWORK, LIWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER COMPZ - INTEGER INFO, LDZ, LIWORK, LRWORK, LWORK, N -* .. -* .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION D( * ), E( * ), RWORK( * ) - COMPLEX*16 WORK( * ), Z( LDZ, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER FINISH, I, ICOMPZ, II, J, K, LGN, LIWMIN, LL, - $ LRWMIN, LWMIN, M, SMLSIZ, START - DOUBLE PRECISION EPS, ORGNRM, P, TINY -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANST - EXTERNAL LSAME, ILAENV, DLAMCH, DLANST -* .. -* .. External Subroutines .. - EXTERNAL DLASCL, DLASET, DSTEDC, DSTEQR, DSTERF, XERBLA, - $ ZLACPY, ZLACRM, ZLAED0, ZSTEQR, ZSWAP -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, LOG, MAX, MOD, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) -* - IF( LSAME( COMPZ, 'N' ) ) THEN - ICOMPZ = 0 - ELSE IF( LSAME( COMPZ, 'V' ) ) THEN - ICOMPZ = 1 - ELSE IF( LSAME( COMPZ, 'I' ) ) THEN - ICOMPZ = 2 - ELSE - ICOMPZ = -1 - END IF - IF( ICOMPZ.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( ( LDZ.LT.1 ) .OR. - $ ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, N ) ) ) THEN - INFO = -6 - END IF -* - IF( INFO.EQ.0 ) THEN -* -* Compute the workspace requirements -* - SMLSIZ = ILAENV( 9, 'ZSTEDC', ' ', 0, 0, 0, 0 ) - IF( N.LE.1 .OR. ICOMPZ.EQ.0 ) THEN - LWMIN = 1 - LIWMIN = 1 - LRWMIN = 1 - ELSE IF( N.LE.SMLSIZ ) THEN - LWMIN = 1 - LIWMIN = 1 - LRWMIN = 2*( N - 1 ) - ELSE IF( ICOMPZ.EQ.1 ) THEN - LGN = INT( LOG( DBLE( N ) ) / LOG( TWO ) ) - IF( 2**LGN.LT.N ) - $ LGN = LGN + 1 - IF( 2**LGN.LT.N ) - $ LGN = LGN + 1 - LWMIN = N*N - LRWMIN = 1 + 3*N + 2*N*LGN + 4*N**2 - LIWMIN = 6 + 6*N + 5*N*LGN - ELSE IF( ICOMPZ.EQ.2 ) THEN - LWMIN = 1 - LRWMIN = 1 + 4*N + 2*N**2 - LIWMIN = 3 + 5*N - END IF - WORK( 1 ) = LWMIN - RWORK( 1 ) = LRWMIN - IWORK( 1 ) = LIWMIN -* - IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN - INFO = -8 - ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN - INFO = -10 - ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZSTEDC', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN - IF( N.EQ.1 ) THEN - IF( ICOMPZ.NE.0 ) - $ Z( 1, 1 ) = ONE - RETURN - END IF -* -* If the following conditional clause is removed, then the routine -* will use the Divide and Conquer routine to compute only the -* eigenvalues, which requires (3N + 3N**2) real workspace and -* (2 + 5N + 2N lg(N)) integer workspace. -* Since on many architectures DSTERF is much faster than any other -* algorithm for finding eigenvalues only, it is used here -* as the default. If the conditional clause is removed, then -* information on the size of workspace needs to be changed. -* -* If COMPZ = 'N', use DSTERF to compute the eigenvalues. -* - IF( ICOMPZ.EQ.0 ) THEN - CALL DSTERF( N, D, E, INFO ) - GO TO 70 - END IF -* -* If N is smaller than the minimum divide size (SMLSIZ+1), then -* solve the problem with another solver. -* - IF( N.LE.SMLSIZ ) THEN -* - CALL ZSTEQR( COMPZ, N, D, E, Z, LDZ, RWORK, INFO ) -* - ELSE -* -* If COMPZ = 'I', we simply call DSTEDC instead. -* - IF( ICOMPZ.EQ.2 ) THEN - CALL DLASET( 'Full', N, N, ZERO, ONE, RWORK, N ) - LL = N*N + 1 - CALL DSTEDC( 'I', N, D, E, RWORK, N, - $ RWORK( LL ), LRWORK-LL+1, IWORK, LIWORK, INFO ) - DO 20 J = 1, N - DO 10 I = 1, N - Z( I, J ) = RWORK( ( J-1 )*N+I ) - 10 CONTINUE - 20 CONTINUE - GO TO 70 - END IF -* -* From now on, only option left to be handled is COMPZ = 'V', -* i.e. ICOMPZ = 1. -* -* Scale. -* - ORGNRM = DLANST( 'M', N, D, E ) - IF( ORGNRM.EQ.ZERO ) - $ GO TO 70 -* - EPS = DLAMCH( 'Epsilon' ) -* - START = 1 -* -* while ( START <= N ) -* - 30 CONTINUE - IF( START.LE.N ) THEN -* -* Let FINISH be the position of the next subdiagonal entry -* such that E( FINISH ) <= TINY or FINISH = N if no such -* subdiagonal exists. The matrix identified by the elements -* between START and FINISH constitutes an independent -* sub-problem. -* - FINISH = START - 40 CONTINUE - IF( FINISH.LT.N ) THEN - TINY = EPS*SQRT( ABS( D( FINISH ) ) )* - $ SQRT( ABS( D( FINISH+1 ) ) ) - IF( ABS( E( FINISH ) ).GT.TINY ) THEN - FINISH = FINISH + 1 - GO TO 40 - END IF - END IF -* -* (Sub) Problem determined. Compute its size and solve it. -* - M = FINISH - START + 1 - IF( M.GT.SMLSIZ ) THEN -* -* Scale. -* - ORGNRM = DLANST( 'M', M, D( START ), E( START ) ) - CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M, 1, D( START ), M, - $ INFO ) - CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M-1, 1, E( START ), - $ M-1, INFO ) -* - CALL ZLAED0( N, M, D( START ), E( START ), Z( 1, START ), - $ LDZ, WORK, N, RWORK, IWORK, INFO ) - IF( INFO.GT.0 ) THEN - INFO = ( INFO / ( M+1 )+START-1 )*( N+1 ) + - $ MOD( INFO, ( M+1 ) ) + START - 1 - GO TO 70 - END IF -* -* Scale back. -* - CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, M, 1, D( START ), M, - $ INFO ) -* - ELSE - CALL DSTEQR( 'I', M, D( START ), E( START ), RWORK, M, - $ RWORK( M*M+1 ), INFO ) - CALL ZLACRM( N, M, Z( 1, START ), LDZ, RWORK, M, WORK, N, - $ RWORK( M*M+1 ) ) - CALL ZLACPY( 'A', N, M, WORK, N, Z( 1, START ), LDZ ) - IF( INFO.GT.0 ) THEN - INFO = START*( N+1 ) + FINISH - GO TO 70 - END IF - END IF -* - START = FINISH + 1 - GO TO 30 - END IF -* -* endwhile -* -* -* Use Selection Sort to minimize swaps of eigenvectors -* - DO 60 II = 2, N - I = II - 1 - K = I - P = D( I ) - DO 50 J = II, N - IF( D( J ).LT.P ) THEN - K = J - P = D( J ) - END IF - 50 CONTINUE - IF( K.NE.I ) THEN - D( K ) = D( I ) - D( I ) = P - CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) - END IF - 60 CONTINUE - END IF -* - 70 CONTINUE - WORK( 1 ) = LWMIN - RWORK( 1 ) = LRWMIN - IWORK( 1 ) = LIWMIN -* - RETURN -* -* End of ZSTEDC -* - END diff --git a/lib/linalg/zsteqr.cpp b/lib/linalg/zsteqr.cpp new file mode 100644 index 0000000000..acf4f9168b --- /dev/null +++ b/lib/linalg/zsteqr.cpp @@ -0,0 +1,378 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static doublecomplex c_b1 = {0., 0.}; +static doublecomplex c_b2 = {1., 0.}; +static integer c__0 = 0; +static integer c__1 = 1; +static integer c__2 = 2; +static doublereal c_b41 = 1.; +int zsteqr_(char *compz, integer *n, doublereal *d__, doublereal *e, doublecomplex *z__, + integer *ldz, doublereal *work, integer *info, ftnlen compz_len) +{ + integer z_dim1, z_offset, i__1, i__2; + doublereal d__1, d__2; + double sqrt(doublereal), d_lmp_sign(doublereal *, doublereal *); + doublereal b, c__, f, g; + integer i__, j, k, l, m; + doublereal p, r__, s; + integer l1, ii, mm, lm1, mm1, nm1; + doublereal rt1, rt2, eps; + integer lsv; + doublereal tst, eps2; + integer lend, jtot; + extern int dlae2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *); + extern logical lsame_(char *, char *, ftnlen, ftnlen); + doublereal anorm; + extern int zlasr_(char *, char *, char *, integer *, integer *, doublereal *, doublereal *, + doublecomplex *, integer *, ftnlen, ftnlen, ftnlen), + zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), + dlaev2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *); + integer lendm1, lendp1; + extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, ftnlen); + integer iscale; + extern int dlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, + integer *, doublereal *, integer *, integer *, ftnlen); + doublereal safmin; + extern int dlartg_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *); + doublereal safmax; + extern int xerbla_(char *, integer *, ftnlen); + extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *, ftnlen); + extern int dlasrt_(char *, integer *, doublereal *, integer *, ftnlen); + integer lendsv; + doublereal ssfmin; + integer nmaxit, icompz; + doublereal ssfmax; + extern int zlaset_(char *, integer *, integer *, doublecomplex *, doublecomplex *, + doublecomplex *, integer *, ftnlen); + --d__; + --e; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + *info = 0; + if (lsame_(compz, (char *)"N", (ftnlen)1, (ftnlen)1)) { + icompz = 0; + } else if (lsame_(compz, (char *)"V", (ftnlen)1, (ftnlen)1)) { + icompz = 1; + } else if (lsame_(compz, (char *)"I", (ftnlen)1, (ftnlen)1)) { + icompz = 2; + } else { + icompz = -1; + } + if (icompz < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*ldz < 1 || icompz > 0 && *ldz < max(1, *n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"ZSTEQR", &i__1, (ftnlen)6); + return 0; + } + if (*n == 0) { + return 0; + } + if (*n == 1) { + if (icompz == 2) { + i__1 = z_dim1 + 1; + z__[i__1].r = 1., z__[i__1].i = 0.; + } + return 0; + } + eps = dlamch_((char *)"E", (ftnlen)1); + d__1 = eps; + eps2 = d__1 * d__1; + safmin = dlamch_((char *)"S", (ftnlen)1); + safmax = 1. / safmin; + ssfmax = sqrt(safmax) / 3.; + ssfmin = sqrt(safmin) / eps2; + if (icompz == 2) { + zlaset_((char *)"Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz, (ftnlen)4); + } + nmaxit = *n * 30; + jtot = 0; + l1 = 1; + nm1 = *n - 1; +L10: + if (l1 > *n) { + goto L160; + } + if (l1 > 1) { + e[l1 - 1] = 0.; + } + if (l1 <= nm1) { + i__1 = nm1; + for (m = l1; m <= i__1; ++m) { + tst = (d__1 = e[m], abs(d__1)); + if (tst == 0.) { + goto L30; + } + if (tst <= + sqrt((d__1 = d__[m], abs(d__1))) * sqrt((d__2 = d__[m + 1], abs(d__2))) * eps) { + e[m] = 0.; + goto L30; + } + } + } + m = *n; +L30: + l = l1; + lsv = l; + lend = m; + lendsv = lend; + l1 = m + 1; + if (lend == l) { + goto L10; + } + i__1 = lend - l + 1; + anorm = dlanst_((char *)"I", &i__1, &d__[l], &e[l], (ftnlen)1); + iscale = 0; + if (anorm == 0.) { + goto L10; + } + if (anorm > ssfmax) { + iscale = 1; + i__1 = lend - l + 1; + dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n, info, (ftnlen)1); + i__1 = lend - l; + dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n, info, (ftnlen)1); + } else if (anorm < ssfmin) { + iscale = 2; + i__1 = lend - l + 1; + dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n, info, (ftnlen)1); + i__1 = lend - l; + dlascl_((char *)"G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n, info, (ftnlen)1); + } + if ((d__1 = d__[lend], abs(d__1)) < (d__2 = d__[l], abs(d__2))) { + lend = lsv; + l = lendsv; + } + if (lend > l) { + L40: + if (l != lend) { + lendm1 = lend - 1; + i__1 = lendm1; + for (m = l; m <= i__1; ++m) { + d__2 = (d__1 = e[m], abs(d__1)); + tst = d__2 * d__2; + if (tst <= + eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m + 1], abs(d__2)) + safmin) { + goto L60; + } + } + } + m = lend; + L60: + if (m < lend) { + e[m] = 0.; + } + p = d__[l]; + if (m == l) { + goto L80; + } + if (m == l + 1) { + if (icompz > 0) { + dlaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s); + work[l] = c__; + work[*n - 1 + l] = s; + zlasr_((char *)"R", (char *)"V", (char *)"B", n, &c__2, &work[l], &work[*n - 1 + l], &z__[l * z_dim1 + 1], + ldz, (ftnlen)1, (ftnlen)1, (ftnlen)1); + } else { + dlae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2); + } + d__[l] = rt1; + d__[l + 1] = rt2; + e[l] = 0.; + l += 2; + if (l <= lend) { + goto L40; + } + goto L140; + } + if (jtot == nmaxit) { + goto L140; + } + ++jtot; + g = (d__[l + 1] - p) / (e[l] * 2.); + r__ = dlapy2_(&g, &c_b41); + g = d__[m] - p + e[l] / (g + d_lmp_sign(&r__, &g)); + s = 1.; + c__ = 1.; + p = 0.; + mm1 = m - 1; + i__1 = l; + for (i__ = mm1; i__ >= i__1; --i__) { + f = s * e[i__]; + b = c__ * e[i__]; + dlartg_(&g, &f, &c__, &s, &r__); + if (i__ != m - 1) { + e[i__ + 1] = r__; + } + g = d__[i__ + 1] - p; + r__ = (d__[i__] - g) * s + c__ * 2. * b; + p = s * r__; + d__[i__ + 1] = g + p; + g = c__ * r__ - b; + if (icompz > 0) { + work[i__] = c__; + work[*n - 1 + i__] = -s; + } + } + if (icompz > 0) { + mm = m - l + 1; + zlasr_((char *)"R", (char *)"V", (char *)"B", n, &mm, &work[l], &work[*n - 1 + l], &z__[l * z_dim1 + 1], ldz, + (ftnlen)1, (ftnlen)1, (ftnlen)1); + } + d__[l] -= p; + e[l] = g; + goto L40; + L80: + d__[l] = p; + ++l; + if (l <= lend) { + goto L40; + } + goto L140; + } else { + L90: + if (l != lend) { + lendp1 = lend + 1; + i__1 = lendp1; + for (m = l; m >= i__1; --m) { + d__2 = (d__1 = e[m - 1], abs(d__1)); + tst = d__2 * d__2; + if (tst <= + eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m - 1], abs(d__2)) + safmin) { + goto L110; + } + } + } + m = lend; + L110: + if (m > lend) { + e[m - 1] = 0.; + } + p = d__[l]; + if (m == l) { + goto L130; + } + if (m == l - 1) { + if (icompz > 0) { + dlaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s); + work[m] = c__; + work[*n - 1 + m] = s; + zlasr_((char *)"R", (char *)"V", (char *)"F", n, &c__2, &work[m], &work[*n - 1 + m], + &z__[(l - 1) * z_dim1 + 1], ldz, (ftnlen)1, (ftnlen)1, (ftnlen)1); + } else { + dlae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2); + } + d__[l - 1] = rt1; + d__[l] = rt2; + e[l - 1] = 0.; + l += -2; + if (l >= lend) { + goto L90; + } + goto L140; + } + if (jtot == nmaxit) { + goto L140; + } + ++jtot; + g = (d__[l - 1] - p) / (e[l - 1] * 2.); + r__ = dlapy2_(&g, &c_b41); + g = d__[m] - p + e[l - 1] / (g + d_lmp_sign(&r__, &g)); + s = 1.; + c__ = 1.; + p = 0.; + lm1 = l - 1; + i__1 = lm1; + for (i__ = m; i__ <= i__1; ++i__) { + f = s * e[i__]; + b = c__ * e[i__]; + dlartg_(&g, &f, &c__, &s, &r__); + if (i__ != m) { + e[i__ - 1] = r__; + } + g = d__[i__] - p; + r__ = (d__[i__ + 1] - g) * s + c__ * 2. * b; + p = s * r__; + d__[i__] = g + p; + g = c__ * r__ - b; + if (icompz > 0) { + work[i__] = c__; + work[*n - 1 + i__] = s; + } + } + if (icompz > 0) { + mm = l - m + 1; + zlasr_((char *)"R", (char *)"V", (char *)"F", n, &mm, &work[m], &work[*n - 1 + m], &z__[m * z_dim1 + 1], ldz, + (ftnlen)1, (ftnlen)1, (ftnlen)1); + } + d__[l] -= p; + e[lm1] = g; + goto L90; + L130: + d__[l] = p; + --l; + if (l >= lend) { + goto L90; + } + goto L140; + } +L140: + if (iscale == 1) { + i__1 = lendsv - lsv + 1; + dlascl_((char *)"G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv], n, info, (ftnlen)1); + i__1 = lendsv - lsv; + dlascl_((char *)"G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n, info, (ftnlen)1); + } else if (iscale == 2) { + i__1 = lendsv - lsv + 1; + dlascl_((char *)"G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv], n, info, (ftnlen)1); + i__1 = lendsv - lsv; + dlascl_((char *)"G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n, info, (ftnlen)1); + } + if (jtot == nmaxit) { + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + if (e[i__] != 0.) { + ++(*info); + } + } + return 0; + } + goto L10; +L160: + if (icompz == 0) { + dlasrt_((char *)"I", n, &d__[1], info, (ftnlen)1); + } else { + i__1 = *n; + for (ii = 2; ii <= i__1; ++ii) { + i__ = ii - 1; + k = i__; + p = d__[i__]; + i__2 = *n; + for (j = ii; j <= i__2; ++j) { + if (d__[j] < p) { + k = j; + p = d__[j]; + } + } + if (k != i__) { + d__[k] = d__[i__]; + d__[i__] = p; + zswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1], &c__1); + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zsteqr.f b/lib/linalg/zsteqr.f deleted file mode 100644 index 47f4004e8d..0000000000 --- a/lib/linalg/zsteqr.f +++ /dev/null @@ -1,573 +0,0 @@ -*> \brief \b ZSTEQR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZSTEQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER COMPZ -* INTEGER INFO, LDZ, N -* .. -* .. Array Arguments .. -* DOUBLE PRECISION D( * ), E( * ), WORK( * ) -* COMPLEX*16 Z( LDZ, * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZSTEQR computes all eigenvalues and, optionally, eigenvectors of a -*> symmetric tridiagonal matrix using the implicit QL or QR method. -*> The eigenvectors of a full or band complex Hermitian matrix can also -*> be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this -*> matrix to tridiagonal form. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] COMPZ -*> \verbatim -*> COMPZ is CHARACTER*1 -*> = 'N': Compute eigenvalues only. -*> = 'V': Compute eigenvalues and eigenvectors of the original -*> Hermitian matrix. On entry, Z must contain the -*> unitary matrix used to reduce the original matrix -*> to tridiagonal form. -*> = 'I': Compute eigenvalues and eigenvectors of the -*> tridiagonal matrix. Z is initialized to the identity -*> matrix. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix. N >= 0. -*> \endverbatim -*> -*> \param[in,out] D -*> \verbatim -*> D is DOUBLE PRECISION array, dimension (N) -*> On entry, the diagonal elements of the tridiagonal matrix. -*> On exit, if INFO = 0, the eigenvalues in ascending order. -*> \endverbatim -*> -*> \param[in,out] E -*> \verbatim -*> E is DOUBLE PRECISION array, dimension (N-1) -*> On entry, the (n-1) subdiagonal elements of the tridiagonal -*> matrix. -*> On exit, E has been destroyed. -*> \endverbatim -*> -*> \param[in,out] Z -*> \verbatim -*> Z is COMPLEX*16 array, dimension (LDZ, N) -*> On entry, if COMPZ = 'V', then Z contains the unitary -*> matrix used in the reduction to tridiagonal form. -*> On exit, if INFO = 0, then if COMPZ = 'V', Z contains the -*> orthonormal eigenvectors of the original Hermitian matrix, -*> and if COMPZ = 'I', Z contains the orthonormal eigenvectors -*> of the symmetric tridiagonal matrix. -*> If COMPZ = 'N', then Z is not referenced. -*> \endverbatim -*> -*> \param[in] LDZ -*> \verbatim -*> LDZ is INTEGER -*> The leading dimension of the array Z. LDZ >= 1, and if -*> eigenvectors are desired, then LDZ >= max(1,N). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (max(1,2*N-2)) -*> If COMPZ = 'N', then WORK is not referenced. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> > 0: the algorithm has failed to find all the eigenvalues in -*> a total of 30*N iterations; if INFO = i, then i -*> elements of E have not converged to zero; on exit, D -*> and E contain the elements of a symmetric tridiagonal -*> matrix which is unitarily similar to the original -*> matrix. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER COMPZ - INTEGER INFO, LDZ, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), E( * ), WORK( * ) - COMPLEX*16 Z( LDZ, * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ THREE = 3.0D0 ) - COMPLEX*16 CZERO, CONE - PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), - $ CONE = ( 1.0D0, 0.0D0 ) ) - INTEGER MAXIT - PARAMETER ( MAXIT = 30 ) -* .. -* .. Local Scalars .. - INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND, - $ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1, - $ NM1, NMAXIT - DOUBLE PRECISION ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2, - $ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANST, DLAPY2 - EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2 -* .. -* .. External Subroutines .. - EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASRT, XERBLA, - $ ZLASET, ZLASR, ZSWAP -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SIGN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 -* - IF( LSAME( COMPZ, 'N' ) ) THEN - ICOMPZ = 0 - ELSE IF( LSAME( COMPZ, 'V' ) ) THEN - ICOMPZ = 1 - ELSE IF( LSAME( COMPZ, 'I' ) ) THEN - ICOMPZ = 2 - ELSE - ICOMPZ = -1 - END IF - IF( ICOMPZ.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, - $ N ) ) ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZSTEQR', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( N.EQ.1 ) THEN - IF( ICOMPZ.EQ.2 ) - $ Z( 1, 1 ) = CONE - RETURN - END IF -* -* Determine the unit roundoff and over/underflow thresholds. -* - EPS = DLAMCH( 'E' ) - EPS2 = EPS**2 - SAFMIN = DLAMCH( 'S' ) - SAFMAX = ONE / SAFMIN - SSFMAX = SQRT( SAFMAX ) / THREE - SSFMIN = SQRT( SAFMIN ) / EPS2 -* -* Compute the eigenvalues and eigenvectors of the tridiagonal -* matrix. -* - IF( ICOMPZ.EQ.2 ) - $ CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDZ ) -* - NMAXIT = N*MAXIT - JTOT = 0 -* -* Determine where the matrix splits and choose QL or QR iteration -* for each block, according to whether top or bottom diagonal -* element is smaller. -* - L1 = 1 - NM1 = N - 1 -* - 10 CONTINUE - IF( L1.GT.N ) - $ GO TO 160 - IF( L1.GT.1 ) - $ E( L1-1 ) = ZERO - IF( L1.LE.NM1 ) THEN - DO 20 M = L1, NM1 - TST = ABS( E( M ) ) - IF( TST.EQ.ZERO ) - $ GO TO 30 - IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ - $ 1 ) ) ) )*EPS ) THEN - E( M ) = ZERO - GO TO 30 - END IF - 20 CONTINUE - END IF - M = N -* - 30 CONTINUE - L = L1 - LSV = L - LEND = M - LENDSV = LEND - L1 = M + 1 - IF( LEND.EQ.L ) - $ GO TO 10 -* -* Scale submatrix in rows and columns L to LEND -* - ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) ) - ISCALE = 0 - IF( ANORM.EQ.ZERO ) - $ GO TO 10 - IF( ANORM.GT.SSFMAX ) THEN - ISCALE = 1 - CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, - $ INFO ) - CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, - $ INFO ) - ELSE IF( ANORM.LT.SSFMIN ) THEN - ISCALE = 2 - CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, - $ INFO ) - CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, - $ INFO ) - END IF -* -* Choose between QL and QR iteration -* - IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN - LEND = LSV - L = LENDSV - END IF -* - IF( LEND.GT.L ) THEN -* -* QL Iteration -* -* Look for small subdiagonal element. -* - 40 CONTINUE - IF( L.NE.LEND ) THEN - LENDM1 = LEND - 1 - DO 50 M = L, LENDM1 - TST = ABS( E( M ) )**2 - IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+ - $ SAFMIN )GO TO 60 - 50 CONTINUE - END IF -* - M = LEND -* - 60 CONTINUE - IF( M.LT.LEND ) - $ E( M ) = ZERO - P = D( L ) - IF( M.EQ.L ) - $ GO TO 80 -* -* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 -* to compute its eigensystem. -* - IF( M.EQ.L+1 ) THEN - IF( ICOMPZ.GT.0 ) THEN - CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S ) - WORK( L ) = C - WORK( N-1+L ) = S - CALL ZLASR( 'R', 'V', 'B', N, 2, WORK( L ), - $ WORK( N-1+L ), Z( 1, L ), LDZ ) - ELSE - CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 ) - END IF - D( L ) = RT1 - D( L+1 ) = RT2 - E( L ) = ZERO - L = L + 2 - IF( L.LE.LEND ) - $ GO TO 40 - GO TO 140 - END IF -* - IF( JTOT.EQ.NMAXIT ) - $ GO TO 140 - JTOT = JTOT + 1 -* -* Form shift. -* - G = ( D( L+1 )-P ) / ( TWO*E( L ) ) - R = DLAPY2( G, ONE ) - G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) ) -* - S = ONE - C = ONE - P = ZERO -* -* Inner loop -* - MM1 = M - 1 - DO 70 I = MM1, L, -1 - F = S*E( I ) - B = C*E( I ) - CALL DLARTG( G, F, C, S, R ) - IF( I.NE.M-1 ) - $ E( I+1 ) = R - G = D( I+1 ) - P - R = ( D( I )-G )*S + TWO*C*B - P = S*R - D( I+1 ) = G + P - G = C*R - B -* -* If eigenvectors are desired, then save rotations. -* - IF( ICOMPZ.GT.0 ) THEN - WORK( I ) = C - WORK( N-1+I ) = -S - END IF -* - 70 CONTINUE -* -* If eigenvectors are desired, then apply saved rotations. -* - IF( ICOMPZ.GT.0 ) THEN - MM = M - L + 1 - CALL ZLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ), - $ Z( 1, L ), LDZ ) - END IF -* - D( L ) = D( L ) - P - E( L ) = G - GO TO 40 -* -* Eigenvalue found. -* - 80 CONTINUE - D( L ) = P -* - L = L + 1 - IF( L.LE.LEND ) - $ GO TO 40 - GO TO 140 -* - ELSE -* -* QR Iteration -* -* Look for small superdiagonal element. -* - 90 CONTINUE - IF( L.NE.LEND ) THEN - LENDP1 = LEND + 1 - DO 100 M = L, LENDP1, -1 - TST = ABS( E( M-1 ) )**2 - IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+ - $ SAFMIN )GO TO 110 - 100 CONTINUE - END IF -* - M = LEND -* - 110 CONTINUE - IF( M.GT.LEND ) - $ E( M-1 ) = ZERO - P = D( L ) - IF( M.EQ.L ) - $ GO TO 130 -* -* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 -* to compute its eigensystem. -* - IF( M.EQ.L-1 ) THEN - IF( ICOMPZ.GT.0 ) THEN - CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S ) - WORK( M ) = C - WORK( N-1+M ) = S - CALL ZLASR( 'R', 'V', 'F', N, 2, WORK( M ), - $ WORK( N-1+M ), Z( 1, L-1 ), LDZ ) - ELSE - CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 ) - END IF - D( L-1 ) = RT1 - D( L ) = RT2 - E( L-1 ) = ZERO - L = L - 2 - IF( L.GE.LEND ) - $ GO TO 90 - GO TO 140 - END IF -* - IF( JTOT.EQ.NMAXIT ) - $ GO TO 140 - JTOT = JTOT + 1 -* -* Form shift. -* - G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) ) - R = DLAPY2( G, ONE ) - G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) ) -* - S = ONE - C = ONE - P = ZERO -* -* Inner loop -* - LM1 = L - 1 - DO 120 I = M, LM1 - F = S*E( I ) - B = C*E( I ) - CALL DLARTG( G, F, C, S, R ) - IF( I.NE.M ) - $ E( I-1 ) = R - G = D( I ) - P - R = ( D( I+1 )-G )*S + TWO*C*B - P = S*R - D( I ) = G + P - G = C*R - B -* -* If eigenvectors are desired, then save rotations. -* - IF( ICOMPZ.GT.0 ) THEN - WORK( I ) = C - WORK( N-1+I ) = S - END IF -* - 120 CONTINUE -* -* If eigenvectors are desired, then apply saved rotations. -* - IF( ICOMPZ.GT.0 ) THEN - MM = L - M + 1 - CALL ZLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ), - $ Z( 1, M ), LDZ ) - END IF -* - D( L ) = D( L ) - P - E( LM1 ) = G - GO TO 90 -* -* Eigenvalue found. -* - 130 CONTINUE - D( L ) = P -* - L = L - 1 - IF( L.GE.LEND ) - $ GO TO 90 - GO TO 140 -* - END IF -* -* Undo scaling if necessary -* - 140 CONTINUE - IF( ISCALE.EQ.1 ) THEN - CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, - $ D( LSV ), N, INFO ) - CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ), - $ N, INFO ) - ELSE IF( ISCALE.EQ.2 ) THEN - CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, - $ D( LSV ), N, INFO ) - CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ), - $ N, INFO ) - END IF -* -* Check for no convergence to an eigenvalue after a total -* of N*MAXIT iterations. -* - IF( JTOT.EQ.NMAXIT ) THEN - DO 150 I = 1, N - 1 - IF( E( I ).NE.ZERO ) - $ INFO = INFO + 1 - 150 CONTINUE - RETURN - END IF - GO TO 10 -* -* Order eigenvalues and eigenvectors. -* - 160 CONTINUE - IF( ICOMPZ.EQ.0 ) THEN -* -* Use Quick Sort -* - CALL DLASRT( 'I', N, D, INFO ) -* - ELSE -* -* Use Selection Sort to minimize swaps of eigenvectors -* - DO 180 II = 2, N - I = II - 1 - K = I - P = D( I ) - DO 170 J = II, N - IF( D( J ).LT.P ) THEN - K = J - P = D( J ) - END IF - 170 CONTINUE - IF( K.NE.I ) THEN - D( K ) = D( I ) - D( I ) = P - CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) - END IF - 180 CONTINUE - END IF - RETURN -* -* End of ZSTEQR -* - END diff --git a/lib/linalg/zswap.cpp b/lib/linalg/zswap.cpp new file mode 100644 index 0000000000..1ead5a7262 --- /dev/null +++ b/lib/linalg/zswap.cpp @@ -0,0 +1,52 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int zswap_(integer *n, doublecomplex *zx, integer *incx, doublecomplex *zy, integer *incy) +{ + integer i__1, i__2, i__3; + integer i__, ix, iy; + doublecomplex ztemp; + --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__; + ztemp.r = zx[i__2].r, ztemp.i = zx[i__2].i; + i__2 = i__; + i__3 = i__; + zx[i__2].r = zy[i__3].r, zx[i__2].i = zy[i__3].i; + i__2 = i__; + zy[i__2].r = ztemp.r, zy[i__2].i = ztemp.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; + ztemp.r = zx[i__2].r, ztemp.i = zx[i__2].i; + i__2 = ix; + i__3 = iy; + zx[i__2].r = zy[i__3].r, zx[i__2].i = zy[i__3].i; + i__2 = iy; + zy[i__2].r = ztemp.r, zy[i__2].i = ztemp.i; + ix += *incx; + iy += *incy; + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zswap.f b/lib/linalg/zswap.f deleted file mode 100644 index 93f8fc52d0..0000000000 --- a/lib/linalg/zswap.f +++ /dev/null @@ -1,129 +0,0 @@ -*> \brief \b ZSWAP -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE ZSWAP(N,ZX,INCX,ZY,INCY) -* -* .. Scalar Arguments .. -* INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. -* COMPLEX*16 ZX(*),ZY(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZSWAP interchanges two vectors. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> number of elements in input vector(s) -*> \endverbatim -*> -*> \param[in,out] ZX -*> \verbatim -*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> storage spacing between elements of ZX -*> \endverbatim -*> -*> \param[in,out] ZY -*> \verbatim -*> ZY is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) -*> \endverbatim -*> -*> \param[in] INCY -*> \verbatim -*> INCY is INTEGER -*> storage spacing between elements of ZY -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16_blas_level1 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> jack dongarra, 3/11/78. -*> modified 12/3/93, array(1) declarations changed to array(*) -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZSWAP(N,ZX,INCX,ZY,INCY) -* -* -- Reference BLAS level1 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX,INCY,N -* .. -* .. Array Arguments .. - COMPLEX*16 ZX(*),ZY(*) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - COMPLEX*16 ZTEMP - INTEGER I,IX,IY -* .. - IF (N.LE.0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN -* -* code for both increments equal to 1 - DO I = 1,N - ZTEMP = ZX(I) - ZX(I) = ZY(I) - ZY(I) = ZTEMP - END DO - ELSE -* -* code for unequal increments or equal increments not equal -* to 1 -* - IX = 1 - IY = 1 - IF (INCX.LT.0) IX = (-N+1)*INCX + 1 - IF (INCY.LT.0) IY = (-N+1)*INCY + 1 - DO I = 1,N - ZTEMP = ZX(IX) - ZX(IX) = ZY(IY) - ZY(IY) = ZTEMP - IX = IX + INCX - IY = IY + INCY - END DO - END IF - RETURN -* -* End of ZSWAP -* - END diff --git a/lib/linalg/ztpmv.cpp b/lib/linalg/ztpmv.cpp new file mode 100644 index 0000000000..41c8602cea --- /dev/null +++ b/lib/linalg/ztpmv.cpp @@ -0,0 +1,371 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int ztpmv_(char *uplo, char *trans, char *diag, integer *n, doublecomplex *ap, doublecomplex *x, + integer *incx, ftnlen uplo_len, ftnlen trans_len, ftnlen diag_len) +{ + integer i__1, i__2, i__3, i__4, i__5; + doublecomplex z__1, z__2, z__3; + void d_lmp_cnjg(doublecomplex *, doublecomplex *); + integer i__, j, k, kk, ix, jx, kx, info; + doublecomplex temp; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern int xerbla_(char *, integer *, ftnlen); + logical noconj, nounit; + --x; + --ap; + info = 0; + 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 (!lsame_(diag, (char *)"U", (ftnlen)1, (ftnlen)1) && + !lsame_(diag, (char *)"N", (ftnlen)1, (ftnlen)1)) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*incx == 0) { + info = 7; + } + if (info != 0) { + xerbla_((char *)"ZTPMV ", &info, (ftnlen)6); + return 0; + } + if (*n == 0) { + return 0; + } + noconj = lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1); + nounit = lsame_(diag, (char *)"N", (ftnlen)1, (ftnlen)1); + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + if (lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1)) { + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + kk = 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; + temp.r = x[i__2].r, temp.i = x[i__2].i; + k = kk; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = k; + z__2.r = temp.r * ap[i__5].r - temp.i * ap[i__5].i, + z__2.i = temp.r * ap[i__5].i + temp.i * ap[i__5].r; + z__1.r = x[i__4].r + z__2.r, z__1.i = x[i__4].i + z__2.i; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; + ++k; + } + if (nounit) { + i__2 = j; + i__3 = j; + i__4 = kk + j - 1; + z__1.r = x[i__3].r * ap[i__4].r - x[i__3].i * ap[i__4].i, + z__1.i = x[i__3].r * ap[i__4].i + x[i__3].i * ap[i__4].r; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + } + } + kk += j; + } + } 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; + temp.r = x[i__2].r, temp.i = x[i__2].i; + ix = kx; + i__2 = kk + j - 2; + for (k = kk; k <= i__2; ++k) { + i__3 = ix; + i__4 = ix; + i__5 = k; + z__2.r = temp.r * ap[i__5].r - temp.i * ap[i__5].i, + z__2.i = temp.r * ap[i__5].i + temp.i * ap[i__5].r; + z__1.r = x[i__4].r + z__2.r, z__1.i = x[i__4].i + z__2.i; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; + ix += *incx; + } + if (nounit) { + i__2 = jx; + i__3 = jx; + i__4 = kk + j - 1; + z__1.r = x[i__3].r * ap[i__4].r - x[i__3].i * ap[i__4].i, + z__1.i = x[i__3].r * ap[i__4].i + x[i__3].i * ap[i__4].r; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + } + } + jx += *incx; + kk += j; + } + } + } else { + kk = *n * (*n + 1) / 2; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + if (x[i__1].r != 0. || x[i__1].i != 0.) { + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; + k = kk; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + i__2 = i__; + i__3 = i__; + i__4 = k; + z__2.r = temp.r * ap[i__4].r - temp.i * ap[i__4].i, + z__2.i = temp.r * ap[i__4].i + temp.i * ap[i__4].r; + z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i + z__2.i; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + --k; + } + if (nounit) { + i__1 = j; + i__2 = j; + i__3 = kk - *n + j; + z__1.r = x[i__2].r * ap[i__3].r - x[i__2].i * ap[i__3].i, + z__1.i = x[i__2].r * ap[i__3].i + x[i__2].i * ap[i__3].r; + x[i__1].r = z__1.r, x[i__1].i = z__1.i; + } + } + kk -= *n - j + 1; + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + i__1 = jx; + if (x[i__1].r != 0. || x[i__1].i != 0.) { + i__1 = jx; + temp.r = x[i__1].r, temp.i = x[i__1].i; + ix = kx; + i__1 = kk - (*n - (j + 1)); + for (k = kk; k >= i__1; --k) { + i__2 = ix; + i__3 = ix; + i__4 = k; + z__2.r = temp.r * ap[i__4].r - temp.i * ap[i__4].i, + z__2.i = temp.r * ap[i__4].i + temp.i * ap[i__4].r; + z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i + z__2.i; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + ix -= *incx; + } + if (nounit) { + i__1 = jx; + i__2 = jx; + i__3 = kk - *n + j; + z__1.r = x[i__2].r * ap[i__3].r - x[i__2].i * ap[i__3].i, + z__1.i = x[i__2].r * ap[i__3].i + x[i__2].i * ap[i__3].r; + x[i__1].r = z__1.r, x[i__1].i = z__1.i; + } + } + jx -= *incx; + kk -= *n - j + 1; + } + } + } + } else { + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + kk = *n * (*n + 1) / 2; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; + k = kk - 1; + if (noconj) { + if (nounit) { + i__1 = kk; + z__1.r = temp.r * ap[i__1].r - temp.i * ap[i__1].i, + z__1.i = temp.r * ap[i__1].i + temp.i * ap[i__1].r; + temp.r = z__1.r, temp.i = z__1.i; + } + for (i__ = j - 1; i__ >= 1; --i__) { + i__1 = k; + i__2 = i__; + z__2.r = ap[i__1].r * x[i__2].r - ap[i__1].i * x[i__2].i, + z__2.i = ap[i__1].r * x[i__2].i + ap[i__1].i * x[i__2].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; + --k; + } + } else { + if (nounit) { + d_lmp_cnjg(&z__2, &ap[kk]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + for (i__ = j - 1; i__ >= 1; --i__) { + d_lmp_cnjg(&z__3, &ap[k]); + i__1 = i__; + z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i, + z__2.i = z__3.r * x[i__1].i + z__3.i * x[i__1].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; + --k; + } + } + i__1 = j; + x[i__1].r = temp.r, x[i__1].i = temp.i; + kk -= j; + } + } else { + jx = kx + (*n - 1) * *incx; + for (j = *n; j >= 1; --j) { + i__1 = jx; + temp.r = x[i__1].r, temp.i = x[i__1].i; + ix = jx; + if (noconj) { + if (nounit) { + i__1 = kk; + z__1.r = temp.r * ap[i__1].r - temp.i * ap[i__1].i, + z__1.i = temp.r * ap[i__1].i + temp.i * ap[i__1].r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__1 = kk - j + 1; + for (k = kk - 1; k >= i__1; --k) { + ix -= *incx; + i__2 = k; + i__3 = ix; + z__2.r = ap[i__2].r * x[i__3].r - ap[i__2].i * x[i__3].i, + z__2.i = ap[i__2].r * x[i__3].i + ap[i__2].i * x[i__3].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; + } + } else { + if (nounit) { + d_lmp_cnjg(&z__2, &ap[kk]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__1 = kk - j + 1; + for (k = kk - 1; k >= i__1; --k) { + ix -= *incx; + d_lmp_cnjg(&z__3, &ap[k]); + i__2 = ix; + z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i, + z__2.i = z__3.r * x[i__2].i + z__3.i * x[i__2].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; + } + } + i__1 = jx; + x[i__1].r = temp.r, x[i__1].i = temp.i; + jx -= *incx; + kk -= j; + } + } + } else { + kk = 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + temp.r = x[i__2].r, temp.i = x[i__2].i; + k = kk + 1; + if (noconj) { + if (nounit) { + i__2 = kk; + z__1.r = temp.r * ap[i__2].r - temp.i * ap[i__2].i, + z__1.i = temp.r * ap[i__2].i + temp.i * ap[i__2].r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = k; + i__4 = i__; + z__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[i__4].i, + z__2.i = ap[i__3].r * x[i__4].i + ap[i__3].i * x[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; + ++k; + } + } else { + if (nounit) { + d_lmp_cnjg(&z__2, &ap[kk]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + d_lmp_cnjg(&z__3, &ap[k]); + i__3 = i__; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, + z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__3].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; + ++k; + } + } + i__2 = j; + x[i__2].r = temp.r, x[i__2].i = temp.i; + kk += *n - j + 1; + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + temp.r = x[i__2].r, temp.i = x[i__2].i; + ix = jx; + if (noconj) { + if (nounit) { + i__2 = kk; + z__1.r = temp.r * ap[i__2].r - temp.i * ap[i__2].i, + z__1.i = temp.r * ap[i__2].i + temp.i * ap[i__2].r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = kk + *n - j; + for (k = kk + 1; k <= i__2; ++k) { + ix += *incx; + i__3 = k; + i__4 = ix; + z__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[i__4].i, + z__2.i = ap[i__3].r * x[i__4].i + ap[i__3].i * x[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; + } + } else { + if (nounit) { + d_lmp_cnjg(&z__2, &ap[kk]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = kk + *n - j; + for (k = kk + 1; k <= i__2; ++k) { + ix += *incx; + d_lmp_cnjg(&z__3, &ap[k]); + i__3 = ix; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, + z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__3].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; + } + } + i__2 = jx; + x[i__2].r = temp.r, x[i__2].i = temp.i; + jx += *incx; + kk += *n - j + 1; + } + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/ztpmv.f b/lib/linalg/ztpmv.f deleted file mode 100644 index 363fd5a2ac..0000000000 --- a/lib/linalg/ztpmv.f +++ /dev/null @@ -1,385 +0,0 @@ -*> \brief \b ZTPMV -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE ZTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) -* -* .. Scalar Arguments .. -* INTEGER INCX,N -* CHARACTER DIAG,TRANS,UPLO -* .. -* .. Array Arguments .. -* COMPLEX*16 AP(*),X(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZTPMV performs one of the matrix-vector operations -*> -*> x := A*x, or x := A**T*x, or x := A**H*x, -*> -*> where x is an n element vector and A is an n by n unit, or non-unit, -*> upper or lower triangular matrix, supplied in packed form. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the matrix is an upper or -*> lower triangular matrix as follows: -*> -*> UPLO = 'U' or 'u' A is an upper triangular matrix. -*> -*> UPLO = 'L' or 'l' A is a lower triangular matrix. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> On entry, TRANS specifies the operation to be performed as -*> follows: -*> -*> TRANS = 'N' or 'n' x := A*x. -*> -*> TRANS = 'T' or 't' x := A**T*x. -*> -*> TRANS = 'C' or 'c' x := A**H*x. -*> \endverbatim -*> -*> \param[in] DIAG -*> \verbatim -*> DIAG is CHARACTER*1 -*> On entry, DIAG specifies whether or not A is unit -*> triangular as follows: -*> -*> DIAG = 'U' or 'u' A is assumed to be unit triangular. -*> -*> DIAG = 'N' or 'n' A is not assumed to be unit -*> triangular. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the order of the matrix A. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] AP -*> \verbatim -*> AP is COMPLEX*16 array, dimension at least -*> ( ( n*( n + 1 ) )/2 ). -*> Before entry with UPLO = 'U' or 'u', the array AP must -*> contain the upper triangular matrix packed sequentially, -*> column by column, so that AP( 1 ) contains a( 1, 1 ), -*> AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) -*> respectively, and so on. -*> Before entry with UPLO = 'L' or 'l', the array AP must -*> contain the lower triangular matrix packed sequentially, -*> column by column, so that AP( 1 ) contains a( 1, 1 ), -*> AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) -*> respectively, and so on. -*> Note that when DIAG = 'U' or 'u', the diagonal elements of -*> A are not referenced, but are assumed to be unity. -*> \endverbatim -*> -*> \param[in,out] X -*> \verbatim -*> X is COMPLEX*16 array, dimension at least -*> ( 1 + ( n - 1 )*abs( INCX ) ). -*> Before entry, the incremented array X must contain the n -*> element vector x. On exit, X is overwritten with the -*> transformed vector x. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> On entry, INCX specifies the increment for the elements of -*> X. INCX must not be zero. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16_blas_level2 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 2 Blas routine. -*> The vector and matrix arguments are not referenced when N = 0, or M = 0 -*> -*> -- Written on 22-October-1986. -*> Jack Dongarra, Argonne National Lab. -*> Jeremy Du Croz, Nag Central Office. -*> Sven Hammarling, Nag Central Office. -*> Richard Hanson, Sandia National Labs. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) -* -* -- Reference BLAS level2 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX,N - CHARACTER DIAG,TRANS,UPLO -* .. -* .. Array Arguments .. - COMPLEX*16 AP(*),X(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER (ZERO= (0.0D+0,0.0D+0)) -* .. -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I,INFO,IX,J,JX,K,KK,KX - LOGICAL NOCONJ,NOUNIT -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN - INFO = 1 - ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. - + .NOT.LSAME(TRANS,'C')) THEN - INFO = 2 - ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN - INFO = 3 - ELSE IF (N.LT.0) THEN - INFO = 4 - ELSE IF (INCX.EQ.0) THEN - INFO = 7 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('ZTPMV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (N.EQ.0) RETURN -* - NOCONJ = LSAME(TRANS,'T') - NOUNIT = LSAME(DIAG,'N') -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF (INCX.LE.0) THEN - KX = 1 - (N-1)*INCX - ELSE IF (INCX.NE.1) THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of AP are -* accessed sequentially with one pass through AP. -* - IF (LSAME(TRANS,'N')) THEN -* -* Form x:= A*x. -* - IF (LSAME(UPLO,'U')) THEN - KK = 1 - IF (INCX.EQ.1) THEN - DO 20 J = 1,N - IF (X(J).NE.ZERO) THEN - TEMP = X(J) - K = KK - DO 10 I = 1,J - 1 - X(I) = X(I) + TEMP*AP(K) - K = K + 1 - 10 CONTINUE - IF (NOUNIT) X(J) = X(J)*AP(KK+J-1) - END IF - KK = KK + J - 20 CONTINUE - ELSE - JX = KX - DO 40 J = 1,N - IF (X(JX).NE.ZERO) THEN - TEMP = X(JX) - IX = KX - DO 30 K = KK,KK + J - 2 - X(IX) = X(IX) + TEMP*AP(K) - IX = IX + INCX - 30 CONTINUE - IF (NOUNIT) X(JX) = X(JX)*AP(KK+J-1) - END IF - JX = JX + INCX - KK = KK + J - 40 CONTINUE - END IF - ELSE - KK = (N* (N+1))/2 - IF (INCX.EQ.1) THEN - DO 60 J = N,1,-1 - IF (X(J).NE.ZERO) THEN - TEMP = X(J) - K = KK - DO 50 I = N,J + 1,-1 - X(I) = X(I) + TEMP*AP(K) - K = K - 1 - 50 CONTINUE - IF (NOUNIT) X(J) = X(J)*AP(KK-N+J) - END IF - KK = KK - (N-J+1) - 60 CONTINUE - ELSE - KX = KX + (N-1)*INCX - JX = KX - DO 80 J = N,1,-1 - IF (X(JX).NE.ZERO) THEN - TEMP = X(JX) - IX = KX - DO 70 K = KK,KK - (N- (J+1)),-1 - X(IX) = X(IX) + TEMP*AP(K) - IX = IX - INCX - 70 CONTINUE - IF (NOUNIT) X(JX) = X(JX)*AP(KK-N+J) - END IF - JX = JX - INCX - KK = KK - (N-J+1) - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A**T*x or x := A**H*x. -* - IF (LSAME(UPLO,'U')) THEN - KK = (N* (N+1))/2 - IF (INCX.EQ.1) THEN - DO 110 J = N,1,-1 - TEMP = X(J) - K = KK - 1 - IF (NOCONJ) THEN - IF (NOUNIT) TEMP = TEMP*AP(KK) - DO 90 I = J - 1,1,-1 - TEMP = TEMP + AP(K)*X(I) - K = K - 1 - 90 CONTINUE - ELSE - IF (NOUNIT) TEMP = TEMP*DCONJG(AP(KK)) - DO 100 I = J - 1,1,-1 - TEMP = TEMP + DCONJG(AP(K))*X(I) - K = K - 1 - 100 CONTINUE - END IF - X(J) = TEMP - KK = KK - J - 110 CONTINUE - ELSE - JX = KX + (N-1)*INCX - DO 140 J = N,1,-1 - TEMP = X(JX) - IX = JX - IF (NOCONJ) THEN - IF (NOUNIT) TEMP = TEMP*AP(KK) - DO 120 K = KK - 1,KK - J + 1,-1 - IX = IX - INCX - TEMP = TEMP + AP(K)*X(IX) - 120 CONTINUE - ELSE - IF (NOUNIT) TEMP = TEMP*DCONJG(AP(KK)) - DO 130 K = KK - 1,KK - J + 1,-1 - IX = IX - INCX - TEMP = TEMP + DCONJG(AP(K))*X(IX) - 130 CONTINUE - END IF - X(JX) = TEMP - JX = JX - INCX - KK = KK - J - 140 CONTINUE - END IF - ELSE - KK = 1 - IF (INCX.EQ.1) THEN - DO 170 J = 1,N - TEMP = X(J) - K = KK + 1 - IF (NOCONJ) THEN - IF (NOUNIT) TEMP = TEMP*AP(KK) - DO 150 I = J + 1,N - TEMP = TEMP + AP(K)*X(I) - K = K + 1 - 150 CONTINUE - ELSE - IF (NOUNIT) TEMP = TEMP*DCONJG(AP(KK)) - DO 160 I = J + 1,N - TEMP = TEMP + DCONJG(AP(K))*X(I) - K = K + 1 - 160 CONTINUE - END IF - X(J) = TEMP - KK = KK + (N-J+1) - 170 CONTINUE - ELSE - JX = KX - DO 200 J = 1,N - TEMP = X(JX) - IX = JX - IF (NOCONJ) THEN - IF (NOUNIT) TEMP = TEMP*AP(KK) - DO 180 K = KK + 1,KK + N - J - IX = IX + INCX - TEMP = TEMP + AP(K)*X(IX) - 180 CONTINUE - ELSE - IF (NOUNIT) TEMP = TEMP*DCONJG(AP(KK)) - DO 190 K = KK + 1,KK + N - J - IX = IX + INCX - TEMP = TEMP + DCONJG(AP(K))*X(IX) - 190 CONTINUE - END IF - X(JX) = TEMP - JX = JX + INCX - KK = KK + (N-J+1) - 200 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZTPMV -* - END diff --git a/lib/linalg/ztpsv.cpp b/lib/linalg/ztpsv.cpp new file mode 100644 index 0000000000..483dcc4513 --- /dev/null +++ b/lib/linalg/ztpsv.cpp @@ -0,0 +1,349 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int ztpsv_(char *uplo, char *trans, char *diag, integer *n, doublecomplex *ap, doublecomplex *x, + integer *incx, ftnlen uplo_len, ftnlen trans_len, ftnlen diag_len) +{ + integer i__1, i__2, i__3, i__4, i__5; + doublecomplex z__1, z__2, z__3; + void z_lmp_div(doublecomplex *, doublecomplex *, doublecomplex *), + d_lmp_cnjg(doublecomplex *, doublecomplex *); + integer i__, j, k, kk, ix, jx, kx, info; + doublecomplex temp; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern int xerbla_(char *, integer *, ftnlen); + logical noconj, nounit; + --x; + --ap; + info = 0; + 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 (!lsame_(diag, (char *)"U", (ftnlen)1, (ftnlen)1) && + !lsame_(diag, (char *)"N", (ftnlen)1, (ftnlen)1)) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*incx == 0) { + info = 7; + } + if (info != 0) { + xerbla_((char *)"ZTPSV ", &info, (ftnlen)6); + return 0; + } + if (*n == 0) { + return 0; + } + noconj = lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1); + nounit = lsame_(diag, (char *)"N", (ftnlen)1, (ftnlen)1); + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + if (lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1)) { + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + kk = *n * (*n + 1) / 2; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + if (x[i__1].r != 0. || x[i__1].i != 0.) { + if (nounit) { + i__1 = j; + z_lmp_div(&z__1, &x[j], &ap[kk]); + x[i__1].r = z__1.r, x[i__1].i = z__1.i; + } + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; + k = kk - 1; + for (i__ = j - 1; i__ >= 1; --i__) { + i__1 = i__; + i__2 = i__; + i__3 = k; + z__2.r = temp.r * ap[i__3].r - temp.i * ap[i__3].i, + z__2.i = temp.r * ap[i__3].i + temp.i * ap[i__3].r; + z__1.r = x[i__2].r - z__2.r, z__1.i = x[i__2].i - z__2.i; + x[i__1].r = z__1.r, x[i__1].i = z__1.i; + --k; + } + } + kk -= j; + } + } else { + jx = kx + (*n - 1) * *incx; + for (j = *n; j >= 1; --j) { + i__1 = jx; + if (x[i__1].r != 0. || x[i__1].i != 0.) { + if (nounit) { + i__1 = jx; + z_lmp_div(&z__1, &x[jx], &ap[kk]); + x[i__1].r = z__1.r, x[i__1].i = z__1.i; + } + i__1 = jx; + temp.r = x[i__1].r, temp.i = x[i__1].i; + ix = jx; + i__1 = kk - j + 1; + for (k = kk - 1; k >= i__1; --k) { + ix -= *incx; + i__2 = ix; + i__3 = ix; + i__4 = k; + z__2.r = temp.r * ap[i__4].r - temp.i * ap[i__4].i, + z__2.i = temp.r * ap[i__4].i + temp.i * ap[i__4].r; + z__1.r = x[i__3].r - z__2.r, z__1.i = x[i__3].i - z__2.i; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + } + } + jx -= *incx; + kk -= j; + } + } + } else { + kk = 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.) { + if (nounit) { + i__2 = j; + z_lmp_div(&z__1, &x[j], &ap[kk]); + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + } + i__2 = j; + temp.r = x[i__2].r, temp.i = x[i__2].i; + k = kk + 1; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = k; + z__2.r = temp.r * ap[i__5].r - temp.i * ap[i__5].i, + z__2.i = temp.r * ap[i__5].i + temp.i * ap[i__5].r; + z__1.r = x[i__4].r - z__2.r, z__1.i = x[i__4].i - z__2.i; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; + ++k; + } + } + kk += *n - j + 1; + } + } 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.) { + if (nounit) { + i__2 = jx; + z_lmp_div(&z__1, &x[jx], &ap[kk]); + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + } + i__2 = jx; + temp.r = x[i__2].r, temp.i = x[i__2].i; + ix = jx; + i__2 = kk + *n - j; + for (k = kk + 1; k <= i__2; ++k) { + ix += *incx; + i__3 = ix; + i__4 = ix; + i__5 = k; + z__2.r = temp.r * ap[i__5].r - temp.i * ap[i__5].i, + z__2.i = temp.r * ap[i__5].i + temp.i * ap[i__5].r; + z__1.r = x[i__4].r - z__2.r, z__1.i = x[i__4].i - z__2.i; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; + } + } + jx += *incx; + kk += *n - j + 1; + } + } + } + } else { + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + kk = 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + temp.r = x[i__2].r, temp.i = x[i__2].i; + k = kk; + if (noconj) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = k; + i__4 = i__; + z__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[i__4].i, + z__2.i = ap[i__3].r * x[i__4].i + ap[i__3].i * x[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; + ++k; + } + if (nounit) { + z_lmp_div(&z__1, &temp, &ap[kk + j - 1]); + temp.r = z__1.r, temp.i = z__1.i; + } + } else { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + d_lmp_cnjg(&z__3, &ap[k]); + i__3 = i__; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, + z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__3].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; + ++k; + } + if (nounit) { + d_lmp_cnjg(&z__2, &ap[kk + j - 1]); + z_lmp_div(&z__1, &temp, &z__2); + temp.r = z__1.r, temp.i = z__1.i; + } + } + i__2 = j; + x[i__2].r = temp.r, x[i__2].i = temp.i; + kk += j; + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + temp.r = x[i__2].r, temp.i = x[i__2].i; + ix = kx; + if (noconj) { + i__2 = kk + j - 2; + for (k = kk; k <= i__2; ++k) { + i__3 = k; + i__4 = ix; + z__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[i__4].i, + z__2.i = ap[i__3].r * x[i__4].i + ap[i__3].i * x[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; + ix += *incx; + } + if (nounit) { + z_lmp_div(&z__1, &temp, &ap[kk + j - 1]); + temp.r = z__1.r, temp.i = z__1.i; + } + } else { + i__2 = kk + j - 2; + for (k = kk; k <= i__2; ++k) { + d_lmp_cnjg(&z__3, &ap[k]); + i__3 = ix; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, + z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__3].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; + ix += *incx; + } + if (nounit) { + d_lmp_cnjg(&z__2, &ap[kk + j - 1]); + z_lmp_div(&z__1, &temp, &z__2); + temp.r = z__1.r, temp.i = z__1.i; + } + } + i__2 = jx; + x[i__2].r = temp.r, x[i__2].i = temp.i; + jx += *incx; + kk += j; + } + } + } else { + kk = *n * (*n + 1) / 2; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; + k = kk; + if (noconj) { + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + i__2 = k; + i__3 = i__; + z__2.r = ap[i__2].r * x[i__3].r - ap[i__2].i * x[i__3].i, + z__2.i = ap[i__2].r * x[i__3].i + ap[i__2].i * x[i__3].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; + --k; + } + if (nounit) { + z_lmp_div(&z__1, &temp, &ap[kk - *n + j]); + temp.r = z__1.r, temp.i = z__1.i; + } + } else { + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + d_lmp_cnjg(&z__3, &ap[k]); + i__2 = i__; + z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i, + z__2.i = z__3.r * x[i__2].i + z__3.i * x[i__2].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; + --k; + } + if (nounit) { + d_lmp_cnjg(&z__2, &ap[kk - *n + j]); + z_lmp_div(&z__1, &temp, &z__2); + temp.r = z__1.r, temp.i = z__1.i; + } + } + i__1 = j; + x[i__1].r = temp.r, x[i__1].i = temp.i; + kk -= *n - j + 1; + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + i__1 = jx; + temp.r = x[i__1].r, temp.i = x[i__1].i; + ix = kx; + if (noconj) { + i__1 = kk - (*n - (j + 1)); + for (k = kk; k >= i__1; --k) { + i__2 = k; + i__3 = ix; + z__2.r = ap[i__2].r * x[i__3].r - ap[i__2].i * x[i__3].i, + z__2.i = ap[i__2].r * x[i__3].i + ap[i__2].i * x[i__3].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; + ix -= *incx; + } + if (nounit) { + z_lmp_div(&z__1, &temp, &ap[kk - *n + j]); + temp.r = z__1.r, temp.i = z__1.i; + } + } else { + i__1 = kk - (*n - (j + 1)); + for (k = kk; k >= i__1; --k) { + d_lmp_cnjg(&z__3, &ap[k]); + i__2 = ix; + z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i, + z__2.i = z__3.r * x[i__2].i + z__3.i * x[i__2].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; + ix -= *incx; + } + if (nounit) { + d_lmp_cnjg(&z__2, &ap[kk - *n + j]); + z_lmp_div(&z__1, &temp, &z__2); + temp.r = z__1.r, temp.i = z__1.i; + } + } + i__1 = jx; + x[i__1].r = temp.r, x[i__1].i = temp.i; + jx -= *incx; + kk -= *n - j + 1; + } + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/ztpsv.f b/lib/linalg/ztpsv.f deleted file mode 100644 index c6f24d0b27..0000000000 --- a/lib/linalg/ztpsv.f +++ /dev/null @@ -1,387 +0,0 @@ -*> \brief \b ZTPSV -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE ZTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) -* -* .. Scalar Arguments .. -* INTEGER INCX,N -* CHARACTER DIAG,TRANS,UPLO -* .. -* .. Array Arguments .. -* COMPLEX*16 AP(*),X(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZTPSV solves one of the systems of equations -*> -*> A*x = b, or A**T*x = b, or A**H*x = b, -*> -*> where b and x are n element vectors and A is an n by n unit, or -*> non-unit, upper or lower triangular matrix, supplied in packed form. -*> -*> No test for singularity or near-singularity is included in this -*> routine. Such tests must be performed before calling this routine. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the matrix is an upper or -*> lower triangular matrix as follows: -*> -*> UPLO = 'U' or 'u' A is an upper triangular matrix. -*> -*> UPLO = 'L' or 'l' A is a lower triangular matrix. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> On entry, TRANS specifies the equations to be solved as -*> follows: -*> -*> TRANS = 'N' or 'n' A*x = b. -*> -*> TRANS = 'T' or 't' A**T*x = b. -*> -*> TRANS = 'C' or 'c' A**H*x = b. -*> \endverbatim -*> -*> \param[in] DIAG -*> \verbatim -*> DIAG is CHARACTER*1 -*> On entry, DIAG specifies whether or not A is unit -*> triangular as follows: -*> -*> DIAG = 'U' or 'u' A is assumed to be unit triangular. -*> -*> DIAG = 'N' or 'n' A is not assumed to be unit -*> triangular. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the order of the matrix A. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] AP -*> \verbatim -*> AP is COMPLEX*16 array, dimension at least -*> ( ( n*( n + 1 ) )/2 ). -*> Before entry with UPLO = 'U' or 'u', the array AP must -*> contain the upper triangular matrix packed sequentially, -*> column by column, so that AP( 1 ) contains a( 1, 1 ), -*> AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) -*> respectively, and so on. -*> Before entry with UPLO = 'L' or 'l', the array AP must -*> contain the lower triangular matrix packed sequentially, -*> column by column, so that AP( 1 ) contains a( 1, 1 ), -*> AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) -*> respectively, and so on. -*> Note that when DIAG = 'U' or 'u', the diagonal elements of -*> A are not referenced, but are assumed to be unity. -*> \endverbatim -*> -*> \param[in,out] X -*> \verbatim -*> X is COMPLEX*16 array, dimension at least -*> ( 1 + ( n - 1 )*abs( INCX ) ). -*> Before entry, the incremented array X must contain the n -*> element right-hand side vector b. On exit, X is overwritten -*> with the solution vector x. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> On entry, INCX specifies the increment for the elements of -*> X. INCX must not be zero. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16_blas_level2 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 2 Blas routine. -*> -*> -- Written on 22-October-1986. -*> Jack Dongarra, Argonne National Lab. -*> Jeremy Du Croz, Nag Central Office. -*> Sven Hammarling, Nag Central Office. -*> Richard Hanson, Sandia National Labs. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) -* -* -- Reference BLAS level2 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX,N - CHARACTER DIAG,TRANS,UPLO -* .. -* .. Array Arguments .. - COMPLEX*16 AP(*),X(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER (ZERO= (0.0D+0,0.0D+0)) -* .. -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I,INFO,IX,J,JX,K,KK,KX - LOGICAL NOCONJ,NOUNIT -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN - INFO = 1 - ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. - + .NOT.LSAME(TRANS,'C')) THEN - INFO = 2 - ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN - INFO = 3 - ELSE IF (N.LT.0) THEN - INFO = 4 - ELSE IF (INCX.EQ.0) THEN - INFO = 7 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('ZTPSV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (N.EQ.0) RETURN -* - NOCONJ = LSAME(TRANS,'T') - NOUNIT = LSAME(DIAG,'N') -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF (INCX.LE.0) THEN - KX = 1 - (N-1)*INCX - ELSE IF (INCX.NE.1) THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of AP are -* accessed sequentially with one pass through AP. -* - IF (LSAME(TRANS,'N')) THEN -* -* Form x := inv( A )*x. -* - IF (LSAME(UPLO,'U')) THEN - KK = (N* (N+1))/2 - IF (INCX.EQ.1) THEN - DO 20 J = N,1,-1 - IF (X(J).NE.ZERO) THEN - IF (NOUNIT) X(J) = X(J)/AP(KK) - TEMP = X(J) - K = KK - 1 - DO 10 I = J - 1,1,-1 - X(I) = X(I) - TEMP*AP(K) - K = K - 1 - 10 CONTINUE - END IF - KK = KK - J - 20 CONTINUE - ELSE - JX = KX + (N-1)*INCX - DO 40 J = N,1,-1 - IF (X(JX).NE.ZERO) THEN - IF (NOUNIT) X(JX) = X(JX)/AP(KK) - TEMP = X(JX) - IX = JX - DO 30 K = KK - 1,KK - J + 1,-1 - IX = IX - INCX - X(IX) = X(IX) - TEMP*AP(K) - 30 CONTINUE - END IF - JX = JX - INCX - KK = KK - J - 40 CONTINUE - END IF - ELSE - KK = 1 - IF (INCX.EQ.1) THEN - DO 60 J = 1,N - IF (X(J).NE.ZERO) THEN - IF (NOUNIT) X(J) = X(J)/AP(KK) - TEMP = X(J) - K = KK + 1 - DO 50 I = J + 1,N - X(I) = X(I) - TEMP*AP(K) - K = K + 1 - 50 CONTINUE - END IF - KK = KK + (N-J+1) - 60 CONTINUE - ELSE - JX = KX - DO 80 J = 1,N - IF (X(JX).NE.ZERO) THEN - IF (NOUNIT) X(JX) = X(JX)/AP(KK) - TEMP = X(JX) - IX = JX - DO 70 K = KK + 1,KK + N - J - IX = IX + INCX - X(IX) = X(IX) - TEMP*AP(K) - 70 CONTINUE - END IF - JX = JX + INCX - KK = KK + (N-J+1) - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := inv( A**T )*x or x := inv( A**H )*x. -* - IF (LSAME(UPLO,'U')) THEN - KK = 1 - IF (INCX.EQ.1) THEN - DO 110 J = 1,N - TEMP = X(J) - K = KK - IF (NOCONJ) THEN - DO 90 I = 1,J - 1 - TEMP = TEMP - AP(K)*X(I) - K = K + 1 - 90 CONTINUE - IF (NOUNIT) TEMP = TEMP/AP(KK+J-1) - ELSE - DO 100 I = 1,J - 1 - TEMP = TEMP - DCONJG(AP(K))*X(I) - K = K + 1 - 100 CONTINUE - IF (NOUNIT) TEMP = TEMP/DCONJG(AP(KK+J-1)) - END IF - X(J) = TEMP - KK = KK + J - 110 CONTINUE - ELSE - JX = KX - DO 140 J = 1,N - TEMP = X(JX) - IX = KX - IF (NOCONJ) THEN - DO 120 K = KK,KK + J - 2 - TEMP = TEMP - AP(K)*X(IX) - IX = IX + INCX - 120 CONTINUE - IF (NOUNIT) TEMP = TEMP/AP(KK+J-1) - ELSE - DO 130 K = KK,KK + J - 2 - TEMP = TEMP - DCONJG(AP(K))*X(IX) - IX = IX + INCX - 130 CONTINUE - IF (NOUNIT) TEMP = TEMP/DCONJG(AP(KK+J-1)) - END IF - X(JX) = TEMP - JX = JX + INCX - KK = KK + J - 140 CONTINUE - END IF - ELSE - KK = (N* (N+1))/2 - IF (INCX.EQ.1) THEN - DO 170 J = N,1,-1 - TEMP = X(J) - K = KK - IF (NOCONJ) THEN - DO 150 I = N,J + 1,-1 - TEMP = TEMP - AP(K)*X(I) - K = K - 1 - 150 CONTINUE - IF (NOUNIT) TEMP = TEMP/AP(KK-N+J) - ELSE - DO 160 I = N,J + 1,-1 - TEMP = TEMP - DCONJG(AP(K))*X(I) - K = K - 1 - 160 CONTINUE - IF (NOUNIT) TEMP = TEMP/DCONJG(AP(KK-N+J)) - END IF - X(J) = TEMP - KK = KK - (N-J+1) - 170 CONTINUE - ELSE - KX = KX + (N-1)*INCX - JX = KX - DO 200 J = N,1,-1 - TEMP = X(JX) - IX = KX - IF (NOCONJ) THEN - DO 180 K = KK,KK - (N- (J+1)),-1 - TEMP = TEMP - AP(K)*X(IX) - IX = IX - INCX - 180 CONTINUE - IF (NOUNIT) TEMP = TEMP/AP(KK-N+J) - ELSE - DO 190 K = KK,KK - (N- (J+1)),-1 - TEMP = TEMP - DCONJG(AP(K))*X(IX) - IX = IX - INCX - 190 CONTINUE - IF (NOUNIT) TEMP = TEMP/DCONJG(AP(KK-N+J)) - END IF - X(JX) = TEMP - JX = JX - INCX - KK = KK - (N-J+1) - 200 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZTPSV -* - END diff --git a/lib/linalg/ztptri.cpp b/lib/linalg/ztptri.cpp new file mode 100644 index 0000000000..86129d42d3 --- /dev/null +++ b/lib/linalg/ztptri.cpp @@ -0,0 +1,114 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static doublecomplex c_b1 = {1., 0.}; +static integer c__1 = 1; +int ztptri_(char *uplo, char *diag, integer *n, doublecomplex *ap, integer *info, ftnlen uplo_len, + ftnlen diag_len) +{ + integer i__1, i__2; + doublecomplex z__1; + void z_lmp_div(doublecomplex *, doublecomplex *, doublecomplex *); + integer j, jc, jj; + doublecomplex ajj; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern int zscal_(integer *, doublecomplex *, doublecomplex *, integer *); + logical upper; + extern int ztpmv_(char *, char *, char *, integer *, doublecomplex *, doublecomplex *, + integer *, ftnlen, ftnlen, ftnlen), + xerbla_(char *, integer *, ftnlen); + integer jclast; + logical nounit; + --ap; + *info = 0; + upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); + nounit = lsame_(diag, (char *)"N", (ftnlen)1, (ftnlen)1); + if (!upper && !lsame_(uplo, (char *)"L", (ftnlen)1, (ftnlen)1)) { + *info = -1; + } else if (!nounit && !lsame_(diag, (char *)"U", (ftnlen)1, (ftnlen)1)) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"ZTPTRI", &i__1, (ftnlen)6); + return 0; + } + if (nounit) { + if (upper) { + jj = 0; + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + jj += *info; + i__2 = jj; + if (ap[i__2].r == 0. && ap[i__2].i == 0.) { + return 0; + } + } + } else { + jj = 1; + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + i__2 = jj; + if (ap[i__2].r == 0. && ap[i__2].i == 0.) { + return 0; + } + jj = jj + *n - *info + 1; + } + } + *info = 0; + } + if (upper) { + jc = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (nounit) { + i__2 = jc + j - 1; + z_lmp_div(&z__1, &c_b1, &ap[jc + j - 1]); + ap[i__2].r = z__1.r, ap[i__2].i = z__1.i; + i__2 = jc + j - 1; + z__1.r = -ap[i__2].r, z__1.i = -ap[i__2].i; + ajj.r = z__1.r, ajj.i = z__1.i; + } else { + z__1.r = -1., z__1.i = -0.; + ajj.r = z__1.r, ajj.i = z__1.i; + } + i__2 = j - 1; + ztpmv_((char *)"Upper", (char *)"No transpose", diag, &i__2, &ap[1], &ap[jc], &c__1, (ftnlen)5, + (ftnlen)12, (ftnlen)1); + i__2 = j - 1; + zscal_(&i__2, &ajj, &ap[jc], &c__1); + jc += j; + } + } else { + jc = *n * (*n + 1) / 2; + for (j = *n; j >= 1; --j) { + if (nounit) { + i__1 = jc; + z_lmp_div(&z__1, &c_b1, &ap[jc]); + ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; + i__1 = jc; + z__1.r = -ap[i__1].r, z__1.i = -ap[i__1].i; + ajj.r = z__1.r, ajj.i = z__1.i; + } else { + z__1.r = -1., z__1.i = -0.; + ajj.r = z__1.r, ajj.i = z__1.i; + } + if (j < *n) { + i__1 = *n - j; + ztpmv_((char *)"Lower", (char *)"No transpose", diag, &i__1, &ap[jclast], &ap[jc + 1], &c__1, + (ftnlen)5, (ftnlen)12, (ftnlen)1); + i__1 = *n - j; + zscal_(&i__1, &ajj, &ap[jc + 1], &c__1); + } + jclast = jc; + jc = jc - *n + j - 2; + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/ztptri.f b/lib/linalg/ztptri.f deleted file mode 100644 index 31284ad637..0000000000 --- a/lib/linalg/ztptri.f +++ /dev/null @@ -1,239 +0,0 @@ -*> \brief \b ZTPTRI -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZTPTRI + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZTPTRI( UPLO, DIAG, N, AP, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER DIAG, UPLO -* INTEGER INFO, N -* .. -* .. Array Arguments .. -* COMPLEX*16 AP( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZTPTRI computes the inverse of a complex upper or lower triangular -*> matrix A stored in packed format. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': A is upper triangular; -*> = 'L': A is lower triangular. -*> \endverbatim -*> -*> \param[in] DIAG -*> \verbatim -*> DIAG is CHARACTER*1 -*> = 'N': A is non-unit triangular; -*> = 'U': A is unit triangular. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in,out] AP -*> \verbatim -*> AP is COMPLEX*16 array, dimension (N*(N+1)/2) -*> On entry, the upper or lower triangular matrix A, stored -*> columnwise in a linear array. The j-th column of A is stored -*> in the array AP as follows: -*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; -*> if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n. -*> See below for further details. -*> On exit, the (triangular) inverse of the original matrix, in -*> the same packed storage format. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> > 0: if INFO = i, A(i,i) is exactly zero. The triangular -*> matrix is singular and its inverse can not be computed. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> A triangular matrix A can be transferred to packed storage using one -*> of the following program segments: -*> -*> UPLO = 'U': UPLO = 'L': -*> -*> JC = 1 JC = 1 -*> DO 2 J = 1, N DO 2 J = 1, N -*> DO 1 I = 1, J DO 1 I = J, N -*> AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J) -*> 1 CONTINUE 1 CONTINUE -*> JC = JC + J JC = JC + N - J + 1 -*> 2 CONTINUE 2 CONTINUE -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZTPTRI( UPLO, DIAG, N, AP, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER DIAG, UPLO - INTEGER INFO, N -* .. -* .. Array Arguments .. - COMPLEX*16 AP( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE, ZERO - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL NOUNIT, UPPER - INTEGER J, JC, JCLAST, JJ - COMPLEX*16 AJJ -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZSCAL, ZTPMV -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - NOUNIT = LSAME( DIAG, 'N' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZTPTRI', -INFO ) - RETURN - END IF -* -* Check for singularity if non-unit. -* - IF( NOUNIT ) THEN - IF( UPPER ) THEN - JJ = 0 - DO 10 INFO = 1, N - JJ = JJ + INFO - IF( AP( JJ ).EQ.ZERO ) - $ RETURN - 10 CONTINUE - ELSE - JJ = 1 - DO 20 INFO = 1, N - IF( AP( JJ ).EQ.ZERO ) - $ RETURN - JJ = JJ + N - INFO + 1 - 20 CONTINUE - END IF - INFO = 0 - END IF -* - IF( UPPER ) THEN -* -* Compute inverse of upper triangular matrix. -* - JC = 1 - DO 30 J = 1, N - IF( NOUNIT ) THEN - AP( JC+J-1 ) = ONE / AP( JC+J-1 ) - AJJ = -AP( JC+J-1 ) - ELSE - AJJ = -ONE - END IF -* -* Compute elements 1:j-1 of j-th column. -* - CALL ZTPMV( 'Upper', 'No transpose', DIAG, J-1, AP, - $ AP( JC ), 1 ) - CALL ZSCAL( J-1, AJJ, AP( JC ), 1 ) - JC = JC + J - 30 CONTINUE -* - ELSE -* -* Compute inverse of lower triangular matrix. -* - JC = N*( N+1 ) / 2 - DO 40 J = N, 1, -1 - IF( NOUNIT ) THEN - AP( JC ) = ONE / AP( JC ) - AJJ = -AP( JC ) - ELSE - AJJ = -ONE - END IF - IF( J.LT.N ) THEN -* -* Compute elements j+1:n of j-th column. -* - CALL ZTPMV( 'Lower', 'No transpose', DIAG, N-J, - $ AP( JCLAST ), AP( JC+1 ), 1 ) - CALL ZSCAL( N-J, AJJ, AP( JC+1 ), 1 ) - END IF - JCLAST = JC - JC = JC - N + J - 2 - 40 CONTINUE - END IF -* - RETURN -* -* End of ZTPTRI -* - END diff --git a/lib/linalg/ztrmm.cpp b/lib/linalg/ztrmm.cpp new file mode 100644 index 0000000000..579080dce5 --- /dev/null +++ b/lib/linalg/ztrmm.cpp @@ -0,0 +1,433 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int ztrmm_(char *side, char *uplo, char *transa, char *diag, integer *m, integer *n, + doublecomplex *alpha, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, + ftnlen side_len, ftnlen uplo_len, ftnlen transa_len, ftnlen diag_len) +{ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, i__6; + doublecomplex z__1, z__2, z__3; + void d_lmp_cnjg(doublecomplex *, doublecomplex *); + integer i__, j, k, info; + doublecomplex temp; + logical lside; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + integer nrowa; + logical upper; + extern int xerbla_(char *, integer *, ftnlen); + logical noconj, nounit; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + lside = lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1); + if (lside) { + nrowa = *m; + } else { + nrowa = *n; + } + noconj = lsame_(transa, (char *)"T", (ftnlen)1, (ftnlen)1); + nounit = lsame_(diag, (char *)"N", (ftnlen)1, (ftnlen)1); + upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); + info = 0; + if (!lside && !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 (!lsame_(transa, (char *)"N", (ftnlen)1, (ftnlen)1) && + !lsame_(transa, (char *)"T", (ftnlen)1, (ftnlen)1) && + !lsame_(transa, (char *)"C", (ftnlen)1, (ftnlen)1)) { + info = 3; + } else if (!lsame_(diag, (char *)"U", (ftnlen)1, (ftnlen)1) && + !lsame_(diag, (char *)"N", (ftnlen)1, (ftnlen)1)) { + info = 4; + } else if (*m < 0) { + info = 5; + } else if (*n < 0) { + info = 6; + } else if (*lda < max(1, nrowa)) { + info = 9; + } else if (*ldb < max(1, *m)) { + info = 11; + } + if (info != 0) { + xerbla_((char *)"ZTRMM ", &info, (ftnlen)6); + return 0; + } + if (*m == 0 || *n == 0) { + return 0; + } + if (alpha->r == 0. && alpha->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 * b_dim1; + b[i__3].r = 0., b[i__3].i = 0.; + } + } + return 0; + } + if (lside) { + if (lsame_(transa, (char *)"N", (ftnlen)1, (ftnlen)1)) { + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (k = 1; k <= i__2; ++k) { + i__3 = k + j * b_dim1; + if (b[i__3].r != 0. || b[i__3].i != 0.) { + i__3 = k + 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; + temp.r = z__1.r, temp.i = z__1.i; + i__3 = k - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * b_dim1; + i__5 = i__ + j * b_dim1; + i__6 = i__ + k * 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 = b[i__5].r + z__2.r, z__1.i = b[i__5].i + z__2.i; + b[i__4].r = z__1.r, b[i__4].i = z__1.i; + } + if (nounit) { + i__3 = k + k * a_dim1; + z__1.r = temp.r * a[i__3].r - temp.i * a[i__3].i, + z__1.i = temp.r * a[i__3].i + temp.i * a[i__3].r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__3 = k + j * b_dim1; + b[i__3].r = temp.r, b[i__3].i = temp.i; + } + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (k = *m; k >= 1; --k) { + i__2 = k + j * b_dim1; + if (b[i__2].r != 0. || b[i__2].i != 0.) { + i__2 = k + 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; + temp.r = z__1.r, temp.i = z__1.i; + i__2 = k + j * b_dim1; + b[i__2].r = temp.r, b[i__2].i = temp.i; + if (nounit) { + i__2 = k + j * b_dim1; + i__3 = k + j * b_dim1; + i__4 = k + k * a_dim1; + z__1.r = b[i__3].r * a[i__4].r - b[i__3].i * a[i__4].i, + z__1.i = b[i__3].r * a[i__4].i + b[i__3].i * a[i__4].r; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + } + i__2 = *m; + for (i__ = k + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + i__5 = i__ + k * a_dim1; + z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + z__2.i = temp.r * a[i__5].i + temp.i * a[i__5].r; + z__1.r = b[i__4].r + z__2.r, z__1.i = b[i__4].i + z__2.i; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; + } + } + } + } + } + } else { + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (i__ = *m; i__ >= 1; --i__) { + i__2 = i__ + j * b_dim1; + temp.r = b[i__2].r, temp.i = b[i__2].i; + if (noconj) { + if (nounit) { + i__2 = i__ + i__ * a_dim1; + z__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i, + z__1.i = temp.r * a[i__2].i + temp.i * a[i__2].r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = i__ - 1; + for (k = 1; k <= i__2; ++k) { + i__3 = k + i__ * a_dim1; + i__4 = k + j * b_dim1; + z__2.r = a[i__3].r * b[i__4].r - a[i__3].i * b[i__4].i, + z__2.i = a[i__3].r * b[i__4].i + a[i__3].i * b[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; + } + } else { + if (nounit) { + d_lmp_cnjg(&z__2, &a[i__ + i__ * a_dim1]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = i__ - 1; + for (k = 1; k <= i__2; ++k) { + d_lmp_cnjg(&z__3, &a[k + i__ * a_dim1]); + i__3 = k + j * b_dim1; + z__2.r = z__3.r * b[i__3].r - z__3.i * b[i__3].i, + z__2.i = z__3.r * b[i__3].i + z__3.i * b[i__3].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; + } + } + i__2 = i__ + j * b_dim1; + z__1.r = alpha->r * temp.r - alpha->i * temp.i, + z__1.i = alpha->r * temp.i + alpha->i * temp.r; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + } + } + } 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 * b_dim1; + temp.r = b[i__3].r, temp.i = b[i__3].i; + if (noconj) { + if (nounit) { + i__3 = i__ + i__ * a_dim1; + z__1.r = temp.r * a[i__3].r - temp.i * a[i__3].i, + z__1.i = temp.r * a[i__3].i + temp.i * a[i__3].r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__3 = *m; + for (k = i__ + 1; k <= i__3; ++k) { + i__4 = k + i__ * a_dim1; + i__5 = k + j * b_dim1; + z__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5].i, + z__2.i = a[i__4].r * b[i__5].i + a[i__4].i * b[i__5].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; + } + } else { + if (nounit) { + d_lmp_cnjg(&z__2, &a[i__ + i__ * a_dim1]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__3 = *m; + for (k = i__ + 1; k <= i__3; ++k) { + d_lmp_cnjg(&z__3, &a[k + i__ * a_dim1]); + i__4 = k + j * b_dim1; + z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4].i, + z__2.i = z__3.r * b[i__4].i + z__3.i * b[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; + } + } + i__3 = i__ + j * b_dim1; + z__1.r = alpha->r * temp.r - alpha->i * temp.i, + z__1.i = alpha->r * temp.i + alpha->i * temp.r; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; + } + } + } + } + } else { + if (lsame_(transa, (char *)"N", (ftnlen)1, (ftnlen)1)) { + if (upper) { + for (j = *n; j >= 1; --j) { + temp.r = alpha->r, temp.i = alpha->i; + if (nounit) { + i__1 = j + j * a_dim1; + z__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i, + z__1.i = temp.r * a[i__1].i + temp.i * a[i__1].r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + j * b_dim1; + i__3 = i__ + j * b_dim1; + z__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i, + z__1.i = temp.r * b[i__3].i + temp.i * b[i__3].r; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + } + i__1 = j - 1; + for (k = 1; k <= i__1; ++k) { + i__2 = k + j * a_dim1; + if (a[i__2].r != 0. || a[i__2].i != 0.) { + i__2 = k + j * a_dim1; + z__1.r = alpha->r * a[i__2].r - alpha->i * a[i__2].i, + z__1.i = alpha->r * a[i__2].i + alpha->i * a[i__2].r; + temp.r = z__1.r, temp.i = z__1.i; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + i__5 = i__ + k * b_dim1; + z__2.r = temp.r * b[i__5].r - temp.i * b[i__5].i, + z__2.i = temp.r * b[i__5].i + temp.i * b[i__5].r; + z__1.r = b[i__4].r + z__2.r, z__1.i = b[i__4].i + z__2.i; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; + } + } + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp.r = alpha->r, temp.i = alpha->i; + if (nounit) { + i__2 = j + j * a_dim1; + z__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i, + z__1.i = temp.r * a[i__2].i + temp.i * a[i__2].r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + z__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i, + z__1.i = temp.r * b[i__4].i + temp.i * b[i__4].r; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; + } + i__2 = *n; + for (k = j + 1; k <= i__2; ++k) { + i__3 = k + j * a_dim1; + if (a[i__3].r != 0. || a[i__3].i != 0.) { + 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; + temp.r = z__1.r, temp.i = z__1.i; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * b_dim1; + i__5 = i__ + j * b_dim1; + i__6 = i__ + k * b_dim1; + z__2.r = temp.r * b[i__6].r - temp.i * b[i__6].i, + z__2.i = temp.r * b[i__6].i + temp.i * b[i__6].r; + z__1.r = b[i__5].r + z__2.r, z__1.i = b[i__5].i + z__2.i; + b[i__4].r = z__1.r, b[i__4].i = z__1.i; + } + } + } + } + } + } else { + if (upper) { + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + i__2 = k - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = j + k * a_dim1; + if (a[i__3].r != 0. || a[i__3].i != 0.) { + if (noconj) { + i__3 = j + k * 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; + temp.r = z__1.r, temp.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; + temp.r = z__1.r, temp.i = z__1.i; + } + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * b_dim1; + i__5 = i__ + j * b_dim1; + i__6 = i__ + k * b_dim1; + z__2.r = temp.r * b[i__6].r - temp.i * b[i__6].i, + z__2.i = temp.r * b[i__6].i + temp.i * b[i__6].r; + z__1.r = b[i__5].r + z__2.r, z__1.i = b[i__5].i + z__2.i; + b[i__4].r = z__1.r, b[i__4].i = z__1.i; + } + } + } + temp.r = alpha->r, temp.i = alpha->i; + if (nounit) { + if (noconj) { + i__2 = k + k * a_dim1; + z__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i, + z__1.i = temp.r * a[i__2].i + temp.i * a[i__2].r; + temp.r = z__1.r, temp.i = z__1.i; + } else { + d_lmp_cnjg(&z__2, &a[k + k * a_dim1]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + } + if (temp.r != 1. || temp.i != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + k * b_dim1; + i__4 = i__ + k * b_dim1; + z__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i, + z__1.i = temp.r * b[i__4].i + temp.i * b[i__4].r; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; + } + } + } + } else { + for (k = *n; k >= 1; --k) { + i__1 = *n; + for (j = k + 1; j <= i__1; ++j) { + i__2 = j + k * a_dim1; + if (a[i__2].r != 0. || a[i__2].i != 0.) { + if (noconj) { + i__2 = j + k * a_dim1; + z__1.r = alpha->r * a[i__2].r - alpha->i * a[i__2].i, + z__1.i = alpha->r * a[i__2].i + alpha->i * a[i__2].r; + temp.r = z__1.r, temp.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; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + i__5 = i__ + k * b_dim1; + z__2.r = temp.r * b[i__5].r - temp.i * b[i__5].i, + z__2.i = temp.r * b[i__5].i + temp.i * b[i__5].r; + z__1.r = b[i__4].r + z__2.r, z__1.i = b[i__4].i + z__2.i; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; + } + } + } + temp.r = alpha->r, temp.i = alpha->i; + if (nounit) { + if (noconj) { + i__1 = k + k * a_dim1; + z__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i, + z__1.i = temp.r * a[i__1].i + temp.i * a[i__1].r; + temp.r = z__1.r, temp.i = z__1.i; + } else { + d_lmp_cnjg(&z__2, &a[k + k * a_dim1]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + } + if (temp.r != 1. || temp.i != 0.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + k * b_dim1; + i__3 = i__ + k * b_dim1; + z__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i, + z__1.i = temp.r * b[i__3].i + temp.i * b[i__3].r; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + } + } + } + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/ztrmm.f b/lib/linalg/ztrmm.f deleted file mode 100644 index c59c367cee..0000000000 --- a/lib/linalg/ztrmm.f +++ /dev/null @@ -1,449 +0,0 @@ -*> \brief \b ZTRMM -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE ZTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* -* .. Scalar Arguments .. -* COMPLEX*16 ALPHA -* INTEGER LDA,LDB,M,N -* CHARACTER DIAG,SIDE,TRANSA,UPLO -* .. -* .. Array Arguments .. -* COMPLEX*16 A(LDA,*),B(LDB,*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZTRMM performs one of the matrix-matrix operations -*> -*> B := alpha*op( A )*B, or B := alpha*B*op( A ) -*> -*> where alpha is a scalar, B is an m by n matrix, A is a unit, or -*> non-unit, upper or lower triangular matrix and op( A ) is one of -*> -*> op( A ) = A or op( A ) = A**T or op( A ) = A**H. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> On entry, SIDE specifies whether op( A ) multiplies B from -*> the left or right as follows: -*> -*> SIDE = 'L' or 'l' B := alpha*op( A )*B. -*> -*> SIDE = 'R' or 'r' B := alpha*B*op( A ). -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the matrix A is an upper or -*> lower triangular matrix as follows: -*> -*> UPLO = 'U' or 'u' A is an upper triangular matrix. -*> -*> UPLO = 'L' or 'l' A is a lower triangular matrix. -*> \endverbatim -*> -*> \param[in] TRANSA -*> \verbatim -*> TRANSA is CHARACTER*1 -*> On entry, TRANSA specifies the form of op( A ) to be used in -*> the matrix multiplication as follows: -*> -*> TRANSA = 'N' or 'n' op( A ) = A. -*> -*> TRANSA = 'T' or 't' op( A ) = A**T. -*> -*> TRANSA = 'C' or 'c' op( A ) = A**H. -*> \endverbatim -*> -*> \param[in] DIAG -*> \verbatim -*> DIAG is CHARACTER*1 -*> On entry, DIAG specifies whether or not A is unit triangular -*> as follows: -*> -*> DIAG = 'U' or 'u' A is assumed to be unit triangular. -*> -*> DIAG = 'N' or 'n' A is not assumed to be unit -*> triangular. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> On entry, M specifies the number of rows of B. M must be at -*> least zero. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the number of columns of B. N must be -*> at least zero. -*> \endverbatim -*> -*> \param[in] ALPHA -*> \verbatim -*> ALPHA is COMPLEX*16 -*> On entry, ALPHA specifies the scalar alpha. When alpha is -*> zero then A is not referenced and B need not be set before -*> entry. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is COMPLEX*16 array, dimension ( LDA, k ), where k is m -*> when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. -*> Before entry with UPLO = 'U' or 'u', the leading k by k -*> upper triangular part of the array A must contain the upper -*> triangular matrix and the strictly lower triangular part of -*> A is not referenced. -*> Before entry with UPLO = 'L' or 'l', the leading k by k -*> lower triangular part of the array A must contain the lower -*> triangular matrix and the strictly upper triangular part of -*> A is not referenced. -*> Note that when DIAG = 'U' or 'u', the diagonal elements of -*> A are not referenced either, but are assumed to be unity. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. When SIDE = 'L' or 'l' then -*> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -*> then LDA must be at least max( 1, n ). -*> \endverbatim -*> -*> \param[in,out] B -*> \verbatim -*> B is COMPLEX*16 array, dimension ( LDB, N ). -*> Before entry, the leading m by n part of the array B must -*> contain the matrix B, and on exit is overwritten by the -*> transformed matrix. -*> \endverbatim -*> -*> \param[in] LDB -*> \verbatim -*> LDB is INTEGER -*> On entry, LDB specifies the first dimension of B as declared -*> in the calling (sub) program. LDB must be at least -*> max( 1, m ). -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16_blas_level3 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 3 Blas routine. -*> -*> -- Written on 8-February-1989. -*> Jack Dongarra, Argonne National Laboratory. -*> Iain Duff, AERE Harwell. -*> Jeremy Du Croz, Numerical Algorithms Group Ltd. -*> Sven Hammarling, Numerical Algorithms Group Ltd. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) -* -* -- Reference BLAS level3 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - COMPLEX*16 ALPHA - INTEGER LDA,LDB,M,N - CHARACTER DIAG,SIDE,TRANSA,UPLO -* .. -* .. Array Arguments .. - COMPLEX*16 A(LDA,*),B(LDB,*) -* .. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG,MAX -* .. -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I,INFO,J,K,NROWA - LOGICAL LSIDE,NOCONJ,NOUNIT,UPPER -* .. -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER (ONE= (1.0D+0,0.0D+0)) - COMPLEX*16 ZERO - PARAMETER (ZERO= (0.0D+0,0.0D+0)) -* .. -* -* Test the input parameters. -* - LSIDE = LSAME(SIDE,'L') - IF (LSIDE) THEN - NROWA = M - ELSE - NROWA = N - END IF - NOCONJ = LSAME(TRANSA,'T') - NOUNIT = LSAME(DIAG,'N') - UPPER = LSAME(UPLO,'U') -* - INFO = 0 - IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN - INFO = 1 - ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN - INFO = 2 - ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. - + (.NOT.LSAME(TRANSA,'T')) .AND. - + (.NOT.LSAME(TRANSA,'C'))) THEN - INFO = 3 - ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN - INFO = 4 - ELSE IF (M.LT.0) THEN - INFO = 5 - ELSE IF (N.LT.0) THEN - INFO = 6 - ELSE IF (LDA.LT.MAX(1,NROWA)) THEN - INFO = 9 - ELSE IF (LDB.LT.MAX(1,M)) THEN - INFO = 11 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('ZTRMM ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (M.EQ.0 .OR. N.EQ.0) RETURN -* -* And when alpha.eq.zero. -* - IF (ALPHA.EQ.ZERO) THEN - DO 20 J = 1,N - DO 10 I = 1,M - B(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF (LSIDE) THEN - IF (LSAME(TRANSA,'N')) THEN -* -* Form B := alpha*A*B. -* - IF (UPPER) THEN - DO 50 J = 1,N - DO 40 K = 1,M - IF (B(K,J).NE.ZERO) THEN - TEMP = ALPHA*B(K,J) - DO 30 I = 1,K - 1 - B(I,J) = B(I,J) + TEMP*A(I,K) - 30 CONTINUE - IF (NOUNIT) TEMP = TEMP*A(K,K) - B(K,J) = TEMP - END IF - 40 CONTINUE - 50 CONTINUE - ELSE - DO 80 J = 1,N - DO 70 K = M,1,-1 - IF (B(K,J).NE.ZERO) THEN - TEMP = ALPHA*B(K,J) - B(K,J) = TEMP - IF (NOUNIT) B(K,J) = B(K,J)*A(K,K) - DO 60 I = K + 1,M - B(I,J) = B(I,J) + TEMP*A(I,K) - 60 CONTINUE - END IF - 70 CONTINUE - 80 CONTINUE - END IF - ELSE -* -* Form B := alpha*A**T*B or B := alpha*A**H*B. -* - IF (UPPER) THEN - DO 120 J = 1,N - DO 110 I = M,1,-1 - TEMP = B(I,J) - IF (NOCONJ) THEN - IF (NOUNIT) TEMP = TEMP*A(I,I) - DO 90 K = 1,I - 1 - TEMP = TEMP + A(K,I)*B(K,J) - 90 CONTINUE - ELSE - IF (NOUNIT) TEMP = TEMP*DCONJG(A(I,I)) - DO 100 K = 1,I - 1 - TEMP = TEMP + DCONJG(A(K,I))*B(K,J) - 100 CONTINUE - END IF - B(I,J) = ALPHA*TEMP - 110 CONTINUE - 120 CONTINUE - ELSE - DO 160 J = 1,N - DO 150 I = 1,M - TEMP = B(I,J) - IF (NOCONJ) THEN - IF (NOUNIT) TEMP = TEMP*A(I,I) - DO 130 K = I + 1,M - TEMP = TEMP + A(K,I)*B(K,J) - 130 CONTINUE - ELSE - IF (NOUNIT) TEMP = TEMP*DCONJG(A(I,I)) - DO 140 K = I + 1,M - TEMP = TEMP + DCONJG(A(K,I))*B(K,J) - 140 CONTINUE - END IF - B(I,J) = ALPHA*TEMP - 150 CONTINUE - 160 CONTINUE - END IF - END IF - ELSE - IF (LSAME(TRANSA,'N')) THEN -* -* Form B := alpha*B*A. -* - IF (UPPER) THEN - DO 200 J = N,1,-1 - TEMP = ALPHA - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 170 I = 1,M - B(I,J) = TEMP*B(I,J) - 170 CONTINUE - DO 190 K = 1,J - 1 - IF (A(K,J).NE.ZERO) THEN - TEMP = ALPHA*A(K,J) - DO 180 I = 1,M - B(I,J) = B(I,J) + TEMP*B(I,K) - 180 CONTINUE - END IF - 190 CONTINUE - 200 CONTINUE - ELSE - DO 240 J = 1,N - TEMP = ALPHA - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 210 I = 1,M - B(I,J) = TEMP*B(I,J) - 210 CONTINUE - DO 230 K = J + 1,N - IF (A(K,J).NE.ZERO) THEN - TEMP = ALPHA*A(K,J) - DO 220 I = 1,M - B(I,J) = B(I,J) + TEMP*B(I,K) - 220 CONTINUE - END IF - 230 CONTINUE - 240 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*A**T or B := alpha*B*A**H. -* - IF (UPPER) THEN - DO 280 K = 1,N - DO 260 J = 1,K - 1 - IF (A(J,K).NE.ZERO) THEN - IF (NOCONJ) THEN - TEMP = ALPHA*A(J,K) - ELSE - TEMP = ALPHA*DCONJG(A(J,K)) - END IF - DO 250 I = 1,M - B(I,J) = B(I,J) + TEMP*B(I,K) - 250 CONTINUE - END IF - 260 CONTINUE - TEMP = ALPHA - IF (NOUNIT) THEN - IF (NOCONJ) THEN - TEMP = TEMP*A(K,K) - ELSE - TEMP = TEMP*DCONJG(A(K,K)) - END IF - END IF - IF (TEMP.NE.ONE) THEN - DO 270 I = 1,M - B(I,K) = TEMP*B(I,K) - 270 CONTINUE - END IF - 280 CONTINUE - ELSE - DO 320 K = N,1,-1 - DO 300 J = K + 1,N - IF (A(J,K).NE.ZERO) THEN - IF (NOCONJ) THEN - TEMP = ALPHA*A(J,K) - ELSE - TEMP = ALPHA*DCONJG(A(J,K)) - END IF - DO 290 I = 1,M - B(I,J) = B(I,J) + TEMP*B(I,K) - 290 CONTINUE - END IF - 300 CONTINUE - TEMP = ALPHA - IF (NOUNIT) THEN - IF (NOCONJ) THEN - TEMP = TEMP*A(K,K) - ELSE - TEMP = TEMP*DCONJG(A(K,K)) - END IF - END IF - IF (TEMP.NE.ONE) THEN - DO 310 I = 1,M - B(I,K) = TEMP*B(I,K) - 310 CONTINUE - END IF - 320 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZTRMM -* - END diff --git a/lib/linalg/ztrmv.cpp b/lib/linalg/ztrmv.cpp new file mode 100644 index 0000000000..dff4c36ef6 --- /dev/null +++ b/lib/linalg/ztrmv.cpp @@ -0,0 +1,351 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int ztrmv_(char *uplo, char *trans, char *diag, integer *n, doublecomplex *a, integer *lda, + doublecomplex *x, integer *incx, ftnlen uplo_len, ftnlen trans_len, ftnlen diag_len) +{ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + doublecomplex z__1, z__2, z__3; + 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); + logical noconj, nounit; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + info = 0; + 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 (!lsame_(diag, (char *)"U", (ftnlen)1, (ftnlen)1) && + !lsame_(diag, (char *)"N", (ftnlen)1, (ftnlen)1)) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*lda < max(1, *n)) { + info = 6; + } else if (*incx == 0) { + info = 8; + } + if (info != 0) { + xerbla_((char *)"ZTRMV ", &info, (ftnlen)6); + return 0; + } + if (*n == 0) { + return 0; + } + noconj = lsame_(trans, (char *)"T", (ftnlen)1, (ftnlen)1); + nounit = lsame_(diag, (char *)"N", (ftnlen)1, (ftnlen)1); + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + if (lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)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; + temp.r = x[i__2].r, temp.i = x[i__2].i; + 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 = temp.r * a[i__5].r - temp.i * a[i__5].i, + z__2.i = temp.r * a[i__5].i + temp.i * a[i__5].r; + z__1.r = x[i__4].r + z__2.r, z__1.i = x[i__4].i + z__2.i; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; + } + if (nounit) { + i__2 = j; + i__3 = j; + i__4 = j + j * a_dim1; + z__1.r = x[i__3].r * a[i__4].r - x[i__3].i * a[i__4].i, + z__1.i = x[i__3].r * a[i__4].i + x[i__3].i * a[i__4].r; + x[i__2].r = z__1.r, x[i__2].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; + temp.r = x[i__2].r, temp.i = x[i__2].i; + ix = kx; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = ix; + i__4 = ix; + i__5 = i__ + j * a_dim1; + z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i, + z__2.i = temp.r * a[i__5].i + temp.i * a[i__5].r; + z__1.r = x[i__4].r + z__2.r, z__1.i = x[i__4].i + z__2.i; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; + ix += *incx; + } + if (nounit) { + i__2 = jx; + i__3 = jx; + i__4 = j + j * a_dim1; + z__1.r = x[i__3].r * a[i__4].r - x[i__3].i * a[i__4].i, + z__1.i = x[i__3].r * a[i__4].i + x[i__3].i * a[i__4].r; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + } + } + jx += *incx; + } + } + } else { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + if (x[i__1].r != 0. || x[i__1].i != 0.) { + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__ + j * a_dim1; + z__2.r = temp.r * a[i__4].r - temp.i * a[i__4].i, + z__2.i = temp.r * a[i__4].i + temp.i * a[i__4].r; + z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i + z__2.i; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + } + if (nounit) { + i__1 = j; + i__2 = j; + i__3 = j + j * a_dim1; + z__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[i__3].i, + z__1.i = x[i__2].r * a[i__3].i + x[i__2].i * a[i__3].r; + x[i__1].r = z__1.r, x[i__1].i = z__1.i; + } + } + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + i__1 = jx; + if (x[i__1].r != 0. || x[i__1].i != 0.) { + i__1 = jx; + temp.r = x[i__1].r, temp.i = x[i__1].i; + ix = kx; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + i__2 = ix; + i__3 = ix; + i__4 = i__ + j * a_dim1; + z__2.r = temp.r * a[i__4].r - temp.i * a[i__4].i, + z__2.i = temp.r * a[i__4].i + temp.i * a[i__4].r; + z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i + z__2.i; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + ix -= *incx; + } + if (nounit) { + i__1 = jx; + i__2 = jx; + i__3 = j + j * a_dim1; + z__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[i__3].i, + z__1.i = x[i__2].r * a[i__3].i + x[i__2].i * a[i__3].r; + x[i__1].r = z__1.r, x[i__1].i = z__1.i; + } + } + jx -= *incx; + } + } + } + } else { + if (lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1)) { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + i__1 = j; + temp.r = x[i__1].r, temp.i = x[i__1].i; + if (noconj) { + if (nounit) { + i__1 = j + j * a_dim1; + z__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i, + z__1.i = temp.r * a[i__1].i + temp.i * a[i__1].r; + temp.r = z__1.r, temp.i = z__1.i; + } + for (i__ = j - 1; i__ >= 1; --i__) { + i__1 = i__ + j * a_dim1; + i__2 = i__; + z__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[i__2].i, + z__2.i = a[i__1].r * x[i__2].i + a[i__1].i * x[i__2].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; + } + } else { + if (nounit) { + d_lmp_cnjg(&z__2, &a[j + j * a_dim1]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + for (i__ = j - 1; i__ >= 1; --i__) { + d_lmp_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__1 = i__; + z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i, + z__2.i = z__3.r * x[i__1].i + z__3.i * x[i__1].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; + } + } + i__1 = j; + x[i__1].r = temp.r, x[i__1].i = temp.i; + } + } else { + jx = kx + (*n - 1) * *incx; + for (j = *n; j >= 1; --j) { + i__1 = jx; + temp.r = x[i__1].r, temp.i = x[i__1].i; + ix = jx; + if (noconj) { + if (nounit) { + i__1 = j + j * a_dim1; + z__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i, + z__1.i = temp.r * a[i__1].i + temp.i * a[i__1].r; + temp.r = z__1.r, temp.i = z__1.i; + } + for (i__ = j - 1; i__ >= 1; --i__) { + ix -= *incx; + i__1 = i__ + j * a_dim1; + i__2 = ix; + z__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[i__2].i, + z__2.i = a[i__1].r * x[i__2].i + a[i__1].i * x[i__2].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; + } + } else { + if (nounit) { + d_lmp_cnjg(&z__2, &a[j + j * a_dim1]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + for (i__ = j - 1; i__ >= 1; --i__) { + ix -= *incx; + d_lmp_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__1 = ix; + z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i, + z__2.i = z__3.r * x[i__1].i + z__3.i * x[i__1].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; + } + } + i__1 = jx; + x[i__1].r = temp.r, x[i__1].i = temp.i; + jx -= *incx; + } + } + } else { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + temp.r = x[i__2].r, temp.i = x[i__2].i; + if (noconj) { + if (nounit) { + i__2 = j + j * a_dim1; + z__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i, + z__1.i = temp.r * a[i__2].i + temp.i * a[i__2].r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++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 = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + } + } else { + if (nounit) { + d_lmp_cnjg(&z__2, &a[j + j * a_dim1]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + d_lmp_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__3 = i__; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, + z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__3].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; + } + } + i__2 = j; + x[i__2].r = temp.r, x[i__2].i = temp.i; + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = jx; + temp.r = x[i__2].r, temp.i = x[i__2].i; + ix = jx; + if (noconj) { + if (nounit) { + i__2 = j + j * a_dim1; + z__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i, + z__1.i = temp.r * a[i__2].i + temp.i * a[i__2].r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + 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 = temp.r + z__2.r, z__1.i = temp.i + z__2.i; + temp.r = z__1.r, temp.i = z__1.i; + } + } else { + if (nounit) { + d_lmp_cnjg(&z__2, &a[j + j * a_dim1]); + z__1.r = temp.r * z__2.r - temp.i * z__2.i, + z__1.i = temp.r * z__2.i + temp.i * z__2.r; + temp.r = z__1.r, temp.i = z__1.i; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + d_lmp_cnjg(&z__3, &a[i__ + j * a_dim1]); + i__3 = ix; + z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, + z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__3].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; + } + } + i__2 = jx; + x[i__2].r = temp.r, x[i__2].i = temp.i; + jx += *incx; + } + } + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/ztrmv.f b/lib/linalg/ztrmv.f deleted file mode 100644 index e8314facb7..0000000000 --- a/lib/linalg/ztrmv.f +++ /dev/null @@ -1,370 +0,0 @@ -*> \brief \b ZTRMV -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -* Definition: -* =========== -* -* SUBROUTINE ZTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) -* -* .. Scalar Arguments .. -* INTEGER INCX,LDA,N -* CHARACTER DIAG,TRANS,UPLO -* .. -* .. Array Arguments .. -* COMPLEX*16 A(LDA,*),X(*) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZTRMV performs one of the matrix-vector operations -*> -*> x := A*x, or x := A**T*x, or x := A**H*x, -*> -*> where x is an n element vector and A is an n by n unit, or non-unit, -*> upper or lower triangular matrix. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> On entry, UPLO specifies whether the matrix is an upper or -*> lower triangular matrix as follows: -*> -*> UPLO = 'U' or 'u' A is an upper triangular matrix. -*> -*> UPLO = 'L' or 'l' A is a lower triangular matrix. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> On entry, TRANS specifies the operation to be performed as -*> follows: -*> -*> TRANS = 'N' or 'n' x := A*x. -*> -*> TRANS = 'T' or 't' x := A**T*x. -*> -*> TRANS = 'C' or 'c' x := A**H*x. -*> \endverbatim -*> -*> \param[in] DIAG -*> \verbatim -*> DIAG is CHARACTER*1 -*> On entry, DIAG specifies whether or not A is unit -*> triangular as follows: -*> -*> DIAG = 'U' or 'u' A is assumed to be unit triangular. -*> -*> DIAG = 'N' or 'n' A is not assumed to be unit -*> triangular. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> On entry, N specifies the order of the matrix A. -*> N must be at least zero. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is COMPLEX*16 array, dimension ( LDA, N ). -*> Before entry with UPLO = 'U' or 'u', the leading n by n -*> upper triangular part of the array A must contain the upper -*> triangular matrix and the strictly lower triangular part of -*> A is not referenced. -*> Before entry with UPLO = 'L' or 'l', the leading n by n -*> lower triangular part of the array A must contain the lower -*> triangular matrix and the strictly upper triangular part of -*> A is not referenced. -*> Note that when DIAG = 'U' or 'u', the diagonal elements of -*> A are not referenced either, but are assumed to be unity. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling (sub) program. LDA must be at least -*> max( 1, n ). -*> \endverbatim -*> -*> \param[in,out] X -*> \verbatim -*> X is COMPLEX*16 array, dimension at least -*> ( 1 + ( n - 1 )*abs( INCX ) ). -*> Before entry, the incremented array X must contain the n -*> element vector x. On exit, X is overwritten with the -*> transformed vector x. -*> \endverbatim -*> -*> \param[in] INCX -*> \verbatim -*> INCX is INTEGER -*> On entry, INCX specifies the increment for the elements of -*> X. INCX must not be zero. -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16_blas_level2 -* -*> \par Further Details: -* ===================== -*> -*> \verbatim -*> -*> Level 2 Blas routine. -*> The vector and matrix arguments are not referenced when N = 0, or M = 0 -*> -*> -- Written on 22-October-1986. -*> Jack Dongarra, Argonne National Lab. -*> Jeremy Du Croz, Nag Central Office. -*> Sven Hammarling, Nag Central Office. -*> Richard Hanson, Sandia National Labs. -*> \endverbatim -*> -* ===================================================================== - SUBROUTINE ZTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) -* -* -- Reference BLAS level2 routine -- -* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INCX,LDA,N - CHARACTER DIAG,TRANS,UPLO -* .. -* .. Array Arguments .. - COMPLEX*16 A(LDA,*),X(*) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER (ZERO= (0.0D+0,0.0D+0)) -* .. -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I,INFO,IX,J,JX,KX - LOGICAL NOCONJ,NOUNIT -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG,MAX -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN - INFO = 1 - ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. - + .NOT.LSAME(TRANS,'C')) THEN - INFO = 2 - ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN - INFO = 3 - ELSE IF (N.LT.0) THEN - INFO = 4 - ELSE IF (LDA.LT.MAX(1,N)) THEN - INFO = 6 - ELSE IF (INCX.EQ.0) THEN - INFO = 8 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('ZTRMV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (N.EQ.0) RETURN -* - NOCONJ = LSAME(TRANS,'T') - NOUNIT = LSAME(DIAG,'N') -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF (INCX.LE.0) THEN - KX = 1 - (N-1)*INCX - ELSE IF (INCX.NE.1) THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF (LSAME(TRANS,'N')) THEN -* -* Form x := A*x. -* - IF (LSAME(UPLO,'U')) THEN - IF (INCX.EQ.1) THEN - DO 20 J = 1,N - IF (X(J).NE.ZERO) THEN - TEMP = X(J) - DO 10 I = 1,J - 1 - X(I) = X(I) + TEMP*A(I,J) - 10 CONTINUE - IF (NOUNIT) X(J) = X(J)*A(J,J) - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40 J = 1,N - IF (X(JX).NE.ZERO) THEN - TEMP = X(JX) - IX = KX - DO 30 I = 1,J - 1 - X(IX) = X(IX) + TEMP*A(I,J) - IX = IX + INCX - 30 CONTINUE - IF (NOUNIT) X(JX) = X(JX)*A(J,J) - END IF - JX = JX + INCX - 40 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 60 J = N,1,-1 - IF (X(J).NE.ZERO) THEN - TEMP = X(J) - DO 50 I = N,J + 1,-1 - X(I) = X(I) + TEMP*A(I,J) - 50 CONTINUE - IF (NOUNIT) X(J) = X(J)*A(J,J) - END IF - 60 CONTINUE - ELSE - KX = KX + (N-1)*INCX - JX = KX - DO 80 J = N,1,-1 - IF (X(JX).NE.ZERO) THEN - TEMP = X(JX) - IX = KX - DO 70 I = N,J + 1,-1 - X(IX) = X(IX) + TEMP*A(I,J) - IX = IX - INCX - 70 CONTINUE - IF (NOUNIT) X(JX) = X(JX)*A(J,J) - END IF - JX = JX - INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A**T*x or x := A**H*x. -* - IF (LSAME(UPLO,'U')) THEN - IF (INCX.EQ.1) THEN - DO 110 J = N,1,-1 - TEMP = X(J) - IF (NOCONJ) THEN - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 90 I = J - 1,1,-1 - TEMP = TEMP + A(I,J)*X(I) - 90 CONTINUE - ELSE - IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J)) - DO 100 I = J - 1,1,-1 - TEMP = TEMP + DCONJG(A(I,J))*X(I) - 100 CONTINUE - END IF - X(J) = TEMP - 110 CONTINUE - ELSE - JX = KX + (N-1)*INCX - DO 140 J = N,1,-1 - TEMP = X(JX) - IX = JX - IF (NOCONJ) THEN - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 120 I = J - 1,1,-1 - IX = IX - INCX - TEMP = TEMP + A(I,J)*X(IX) - 120 CONTINUE - ELSE - IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J)) - DO 130 I = J - 1,1,-1 - IX = IX - INCX - TEMP = TEMP + DCONJG(A(I,J))*X(IX) - 130 CONTINUE - END IF - X(JX) = TEMP - JX = JX - INCX - 140 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 170 J = 1,N - TEMP = X(J) - IF (NOCONJ) THEN - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 150 I = J + 1,N - TEMP = TEMP + A(I,J)*X(I) - 150 CONTINUE - ELSE - IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J)) - DO 160 I = J + 1,N - TEMP = TEMP + DCONJG(A(I,J))*X(I) - 160 CONTINUE - END IF - X(J) = TEMP - 170 CONTINUE - ELSE - JX = KX - DO 200 J = 1,N - TEMP = X(JX) - IX = JX - IF (NOCONJ) THEN - IF (NOUNIT) TEMP = TEMP*A(J,J) - DO 180 I = J + 1,N - IX = IX + INCX - TEMP = TEMP + A(I,J)*X(IX) - 180 CONTINUE - ELSE - IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J)) - DO 190 I = J + 1,N - IX = IX + INCX - TEMP = TEMP + DCONJG(A(I,J))*X(IX) - 190 CONTINUE - END IF - X(JX) = TEMP - JX = JX + INCX - 200 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZTRMV -* - END diff --git a/lib/linalg/zung2l.cpp b/lib/linalg/zung2l.cpp new file mode 100644 index 0000000000..ab3da15caa --- /dev/null +++ b/lib/linalg/zung2l.cpp @@ -0,0 +1,76 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +int zung2l_(integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, + doublecomplex *work, integer *info) +{ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublecomplex z__1; + integer i__, j, l, ii; + extern int zscal_(integer *, doublecomplex *, doublecomplex *, integer *), + zlarf_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, ftnlen), + xerbla_(char *, integer *, ftnlen); + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + --work; + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0 || *n > *m) { + *info = -2; + } else if (*k < 0 || *k > *n) { + *info = -3; + } else if (*lda < max(1, *m)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"ZUNG2L", &i__1, (ftnlen)6); + return 0; + } + if (*n <= 0) { + return 0; + } + i__1 = *n - *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (l = 1; l <= i__2; ++l) { + i__3 = l + j * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; + } + i__2 = *m - *n + j + j * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + } + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + ii = *n - *k + i__; + i__2 = *m - *n + ii + ii * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + i__2 = *m - *n + ii; + i__3 = ii - 1; + zlarf_((char *)"Left", &i__2, &i__3, &a[ii * a_dim1 + 1], &c__1, &tau[i__], &a[a_offset], lda, + &work[1], (ftnlen)4); + i__2 = *m - *n + ii - 1; + i__3 = i__; + z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i; + zscal_(&i__2, &z__1, &a[ii * a_dim1 + 1], &c__1); + i__2 = *m - *n + ii + ii * a_dim1; + i__3 = i__; + z__1.r = 1. - tau[i__3].r, z__1.i = 0. - tau[i__3].i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = *m; + for (l = *m - *n + ii + 1; l <= i__2; ++l) { + i__3 = l + ii * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zung2l.f b/lib/linalg/zung2l.f deleted file mode 100644 index add5cb946b..0000000000 --- a/lib/linalg/zung2l.f +++ /dev/null @@ -1,196 +0,0 @@ -*> \brief \b ZUNG2L generates all or part of the unitary matrix Q from a QL factorization determined by cgeqlf (unblocked algorithm). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZUNG2L + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, K, LDA, M, N -* .. -* .. Array Arguments .. -* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZUNG2L generates an m by n complex matrix Q with orthonormal columns, -*> which is defined as the last n columns of a product of k elementary -*> reflectors of order m -*> -*> Q = H(k) . . . H(2) H(1) -*> -*> as returned by ZGEQLF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix Q. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix Q. M >= N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines the -*> matrix Q. N >= K >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,N) -*> On entry, the (n-k+i)-th column must contain the vector which -*> defines the elementary reflector H(i), for i = 1,2,...,k, as -*> returned by ZGEQLF in the last k columns of its array -*> argument A. -*> On exit, the m-by-n matrix Q. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The first dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by ZGEQLF. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 array, dimension (N) -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument has an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE, ZERO - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, II, J, L -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLARF, ZSCAL -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNG2L', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* -* Initialise columns 1:n-k to columns of the unit matrix -* - DO 20 J = 1, N - K - DO 10 L = 1, M - A( L, J ) = ZERO - 10 CONTINUE - A( M-N+J, J ) = ONE - 20 CONTINUE -* - DO 40 I = 1, K - II = N - K + I -* -* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left -* - A( M-N+II, II ) = ONE - CALL ZLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A, - $ LDA, WORK ) - CALL ZSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 ) - A( M-N+II, II ) = ONE - TAU( I ) -* -* Set A(m-k+i+1:m,n-k+i) to zero -* - DO 30 L = M - N + II + 1, M - A( L, II ) = ZERO - 30 CONTINUE - 40 CONTINUE - RETURN -* -* End of ZUNG2L -* - END diff --git a/lib/linalg/zung2r.cpp b/lib/linalg/zung2r.cpp new file mode 100644 index 0000000000..20b7b0957e --- /dev/null +++ b/lib/linalg/zung2r.cpp @@ -0,0 +1,78 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +int zung2r_(integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, + doublecomplex *work, integer *info) +{ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublecomplex z__1; + integer i__, j, l; + extern int zscal_(integer *, doublecomplex *, doublecomplex *, integer *), + zlarf_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, ftnlen), + xerbla_(char *, integer *, ftnlen); + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + --work; + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0 || *n > *m) { + *info = -2; + } else if (*k < 0 || *k > *n) { + *info = -3; + } else if (*lda < max(1, *m)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"ZUNG2R", &i__1, (ftnlen)6); + return 0; + } + if (*n <= 0) { + return 0; + } + i__1 = *n; + for (j = *k + 1; j <= i__1; ++j) { + i__2 = *m; + for (l = 1; l <= i__2; ++l) { + i__3 = l + j * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; + } + i__2 = j + j * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + } + for (i__ = *k; i__ >= 1; --i__) { + if (i__ < *n) { + i__1 = i__ + i__ * a_dim1; + a[i__1].r = 1., a[i__1].i = 0.; + i__1 = *m - i__ + 1; + i__2 = *n - i__; + zlarf_((char *)"Left", &i__1, &i__2, &a[i__ + i__ * a_dim1], &c__1, &tau[i__], + &a[i__ + (i__ + 1) * a_dim1], lda, &work[1], (ftnlen)4); + } + if (i__ < *m) { + i__1 = *m - i__; + i__2 = i__; + z__1.r = -tau[i__2].r, z__1.i = -tau[i__2].i; + zscal_(&i__1, &z__1, &a[i__ + 1 + i__ * a_dim1], &c__1); + } + i__1 = i__ + i__ * a_dim1; + i__2 = i__; + z__1.r = 1. - tau[i__2].r, z__1.i = 0. - tau[i__2].i; + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + i__1 = i__ - 1; + for (l = 1; l <= i__1; ++l) { + i__2 = l + i__ * a_dim1; + a[i__2].r = 0., a[i__2].i = 0.; + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zung2r.f b/lib/linalg/zung2r.f deleted file mode 100644 index 2823b7ebdd..0000000000 --- a/lib/linalg/zung2r.f +++ /dev/null @@ -1,198 +0,0 @@ -*> \brief \b ZUNG2R -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZUNG2R + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, K, LDA, M, N -* .. -* .. Array Arguments .. -* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZUNG2R generates an m by n complex matrix Q with orthonormal columns, -*> which is defined as the first n columns of a product of k elementary -*> reflectors of order m -*> -*> Q = H(1) H(2) . . . H(k) -*> -*> as returned by ZGEQRF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix Q. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix Q. M >= N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines the -*> matrix Q. N >= K >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,N) -*> On entry, the i-th column must contain the vector which -*> defines the elementary reflector H(i), for i = 1,2,...,k, as -*> returned by ZGEQRF in the first k columns of its array -*> argument A. -*> On exit, the m by n matrix Q. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The first dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by ZGEQRF. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 array, dimension (N) -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument has an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE, ZERO - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, J, L -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLARF, ZSCAL -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNG2R', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* -* Initialise columns k+1:n to columns of the unit matrix -* - DO 20 J = K + 1, N - DO 10 L = 1, M - A( L, J ) = ZERO - 10 CONTINUE - A( J, J ) = ONE - 20 CONTINUE -* - DO 40 I = K, 1, -1 -* -* Apply H(i) to A(i:m,i:n) from the left -* - IF( I.LT.N ) THEN - A( I, I ) = ONE - CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), - $ A( I, I+1 ), LDA, WORK ) - END IF - IF( I.LT.M ) - $ CALL ZSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) - A( I, I ) = ONE - TAU( I ) -* -* Set A(1:i-1,i) to zero -* - DO 30 L = 1, I - 1 - A( L, I ) = ZERO - 30 CONTINUE - 40 CONTINUE - RETURN -* -* End of ZUNG2R -* - END diff --git a/lib/linalg/zungl2.cpp b/lib/linalg/zungl2.cpp new file mode 100644 index 0000000000..7ac8d65292 --- /dev/null +++ b/lib/linalg/zungl2.cpp @@ -0,0 +1,87 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +int zungl2_(integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, + doublecomplex *work, integer *info) +{ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublecomplex z__1, z__2; + void d_lmp_cnjg(doublecomplex *, doublecomplex *); + integer i__, j, l; + extern int zscal_(integer *, doublecomplex *, doublecomplex *, integer *), + zlarf_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, ftnlen), + xerbla_(char *, integer *, ftnlen), zlacgv_(integer *, doublecomplex *, integer *); + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + --work; + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < *m) { + *info = -2; + } else if (*k < 0 || *k > *m) { + *info = -3; + } else if (*lda < max(1, *m)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"ZUNGL2", &i__1, (ftnlen)6); + return 0; + } + if (*m <= 0) { + return 0; + } + if (*k < *m) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (l = *k + 1; l <= i__2; ++l) { + i__3 = l + j * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; + } + if (j > *k && j <= *m) { + i__2 = j + j * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + } + } + } + for (i__ = *k; i__ >= 1; --i__) { + if (i__ < *n) { + i__1 = *n - i__; + zlacgv_(&i__1, &a[i__ + (i__ + 1) * a_dim1], lda); + if (i__ < *m) { + i__1 = i__ + i__ * a_dim1; + a[i__1].r = 1., a[i__1].i = 0.; + i__1 = *m - i__; + i__2 = *n - i__ + 1; + d_lmp_cnjg(&z__1, &tau[i__]); + zlarf_((char *)"Right", &i__1, &i__2, &a[i__ + i__ * a_dim1], lda, &z__1, + &a[i__ + 1 + i__ * a_dim1], lda, &work[1], (ftnlen)5); + } + i__1 = *n - i__; + i__2 = i__; + z__1.r = -tau[i__2].r, z__1.i = -tau[i__2].i; + zscal_(&i__1, &z__1, &a[i__ + (i__ + 1) * a_dim1], lda); + i__1 = *n - i__; + zlacgv_(&i__1, &a[i__ + (i__ + 1) * a_dim1], lda); + } + i__1 = i__ + i__ * a_dim1; + d_lmp_cnjg(&z__2, &tau[i__]); + z__1.r = 1. - z__2.r, z__1.i = 0. - z__2.i; + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + i__1 = i__ - 1; + for (l = 1; l <= i__1; ++l) { + i__2 = i__ + l * a_dim1; + a[i__2].r = 0., a[i__2].i = 0.; + } + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zungl2.f b/lib/linalg/zungl2.f deleted file mode 100644 index e7a0b59603..0000000000 --- a/lib/linalg/zungl2.f +++ /dev/null @@ -1,204 +0,0 @@ -*> \brief \b ZUNGL2 generates all or part of the unitary matrix Q from an LQ factorization determined by cgelqf (unblocked algorithm). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZUNGL2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, K, LDA, M, N -* .. -* .. Array Arguments .. -* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZUNGL2 generates an m-by-n complex matrix Q with orthonormal rows, -*> which is defined as the first m rows of a product of k elementary -*> reflectors of order n -*> -*> Q = H(k)**H . . . H(2)**H H(1)**H -*> -*> as returned by ZGELQF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix Q. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix Q. N >= M. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines the -*> matrix Q. M >= K >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,N) -*> On entry, the i-th row must contain the vector which defines -*> the elementary reflector H(i), for i = 1,2,...,k, as returned -*> by ZGELQF in the first k rows of its array argument A. -*> On exit, the m by n matrix Q. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The first dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by ZGELQF. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 array, dimension (M) -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument has an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE, ZERO - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, J, L -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLACGV, ZLARF, ZSCAL -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.M ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNGL2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.LE.0 ) - $ RETURN -* - IF( K.LT.M ) THEN -* -* Initialise rows k+1:m to rows of the unit matrix -* - DO 20 J = 1, N - DO 10 L = K + 1, M - A( L, J ) = ZERO - 10 CONTINUE - IF( J.GT.K .AND. J.LE.M ) - $ A( J, J ) = ONE - 20 CONTINUE - END IF -* - DO 40 I = K, 1, -1 -* -* Apply H(i)**H to A(i:m,i:n) from the right -* - IF( I.LT.N ) THEN - CALL ZLACGV( N-I, A( I, I+1 ), LDA ) - IF( I.LT.M ) THEN - A( I, I ) = ONE - CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, - $ DCONJG( TAU( I ) ), A( I+1, I ), LDA, WORK ) - END IF - CALL ZSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA ) - CALL ZLACGV( N-I, A( I, I+1 ), LDA ) - END IF - A( I, I ) = ONE - DCONJG( TAU( I ) ) -* -* Set A(i,1:i-1) to zero -* - DO 30 L = 1, I - 1 - A( I, L ) = ZERO - 30 CONTINUE - 40 CONTINUE - RETURN -* -* End of ZUNGL2 -* - END diff --git a/lib/linalg/zungql.cpp b/lib/linalg/zungql.cpp new file mode 100644 index 0000000000..4250c31d03 --- /dev/null +++ b/lib/linalg/zungql.cpp @@ -0,0 +1,134 @@ +#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; +int zungql_(integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, + doublecomplex *work, integer *lwork, integer *info) +{ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + integer i__, j, l, ib, nb, kk, nx, iws, nbmin, iinfo; + extern int zung2l_(integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *), + xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, + ftnlen, ftnlen); + extern int zlarfb_(char *, char *, char *, char *, integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); + integer ldwork; + extern int zlarft_(char *, char *, integer *, integer *, doublecomplex *, integer *, + doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen); + logical lquery; + integer lwkopt; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + --work; + *info = 0; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0 || *n > *m) { + *info = -2; + } else if (*k < 0 || *k > *n) { + *info = -3; + } else if (*lda < max(1, *m)) { + *info = -5; + } + if (*info == 0) { + if (*n == 0) { + lwkopt = 1; + } else { + nb = ilaenv_(&c__1, (char *)"ZUNGQL", (char *)" ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1); + lwkopt = *n * nb; + } + work[1].r = (doublereal)lwkopt, work[1].i = 0.; + if (*lwork < max(1, *n) && !lquery) { + *info = -8; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"ZUNGQL", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + if (*n <= 0) { + return 0; + } + nbmin = 2; + nx = 0; + iws = *n; + if (nb > 1 && nb < *k) { + i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"ZUNGQL", (char *)" ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1); + nx = max(i__1, i__2); + if (nx < *k) { + ldwork = *n; + iws = ldwork * nb; + if (*lwork < iws) { + nb = *lwork / ldwork; + i__1 = 2, + i__2 = ilaenv_(&c__2, (char *)"ZUNGQL", (char *)" ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1); + nbmin = max(i__1, i__2); + } + } + } + if (nb >= nbmin && nb < *k && nx < *k) { + i__1 = *k, i__2 = (*k - nx + nb - 1) / nb * nb; + kk = min(i__1, i__2); + i__1 = *n - kk; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = *m - kk + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; + } + } + } else { + kk = 0; + } + i__1 = *m - kk; + i__2 = *n - kk; + i__3 = *k - kk; + zung2l_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], &iinfo); + if (kk > 0) { + i__1 = *k; + i__2 = nb; + for (i__ = *k - kk + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + i__3 = nb, i__4 = *k - i__ + 1; + ib = min(i__3, i__4); + if (*n - *k + i__ > 1) { + i__3 = *m - *k + i__ + ib - 1; + zlarft_((char *)"Backward", (char *)"Columnwise", &i__3, &ib, &a[(*n - *k + i__) * a_dim1 + 1], lda, + &tau[i__], &work[1], &ldwork, (ftnlen)8, (ftnlen)10); + i__3 = *m - *k + i__ + ib - 1; + i__4 = *n - *k + i__ - 1; + zlarfb_((char *)"Left", (char *)"No transpose", (char *)"Backward", (char *)"Columnwise", &i__3, &i__4, &ib, + &a[(*n - *k + i__) * a_dim1 + 1], lda, &work[1], &ldwork, &a[a_offset], lda, + &work[ib + 1], &ldwork, (ftnlen)4, (ftnlen)12, (ftnlen)8, (ftnlen)10); + } + i__3 = *m - *k + i__ + ib - 1; + zung2l_(&i__3, &ib, &ib, &a[(*n - *k + i__) * a_dim1 + 1], lda, &tau[i__], &work[1], + &iinfo); + i__3 = *n - *k + i__ + ib - 1; + for (j = *n - *k + i__; j <= i__3; ++j) { + i__4 = *m; + for (l = *m - *k + i__ + ib; l <= i__4; ++l) { + i__5 = l + j * a_dim1; + a[i__5].r = 0., a[i__5].i = 0.; + } + } + } + } + work[1].r = (doublereal)iws, work[1].i = 0.; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zungql.f b/lib/linalg/zungql.f deleted file mode 100644 index 1804ca65ff..0000000000 --- a/lib/linalg/zungql.f +++ /dev/null @@ -1,293 +0,0 @@ -*> \brief \b ZUNGQL -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZUNGQL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. -* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZUNGQL generates an M-by-N complex matrix Q with orthonormal columns, -*> which is defined as the last N columns of a product of K elementary -*> reflectors of order M -*> -*> Q = H(k) . . . H(2) H(1) -*> -*> as returned by ZGEQLF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix Q. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix Q. M >= N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines the -*> matrix Q. N >= K >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,N) -*> On entry, the (n-k+i)-th column must contain the vector which -*> defines the elementary reflector H(i), for i = 1,2,...,k, as -*> returned by ZGEQLF in the last k columns of its array -*> argument A. -*> On exit, the M-by-N matrix Q. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The first dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by ZGEQLF. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. LWORK >= max(1,N). -*> For optimum performance LWORK >= N*NB, where NB is the -*> optimal blocksize. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal size of the WORK array, returns -*> this value as the first entry of the WORK array, and no error -*> message related to LWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument has an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT, - $ NB, NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNG2L -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - END IF -* - IF( INFO.EQ.0 ) THEN - IF( N.EQ.0 ) THEN - LWKOPT = 1 - ELSE - NB = ILAENV( 1, 'ZUNGQL', ' ', M, N, K, -1 ) - LWKOPT = N*NB - END IF - WORK( 1 ) = LWKOPT -* - IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -8 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNGQL', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) THEN - RETURN - END IF -* - NBMIN = 2 - NX = 0 - IWS = N - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'ZUNGQL', ' ', M, N, K, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'ZUNGQL', ' ', M, N, K, -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code after the first block. -* The last kk columns are handled by the block method. -* - KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB ) -* -* Set A(m-kk+1:m,1:n-kk) to zero. -* - DO 20 J = 1, N - KK - DO 10 I = M - KK + 1, M - A( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - KK = 0 - END IF -* -* Use unblocked code for the first or only block. -* - CALL ZUNG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO ) -* - IF( KK.GT.0 ) THEN -* -* Use blocked code -* - DO 50 I = K - KK + 1, K, NB - IB = MIN( NB, K-I+1 ) - IF( N-K+I.GT.1 ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i+ib-1) . . . H(i+1) H(i) -* - CALL ZLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB, - $ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left -* - CALL ZLARFB( 'Left', 'No transpose', 'Backward', - $ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB, - $ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA, - $ WORK( IB+1 ), LDWORK ) - END IF -* -* Apply H to rows 1:m-k+i+ib-1 of current block -* - CALL ZUNG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA, - $ TAU( I ), WORK, IINFO ) -* -* Set rows m-k+i+ib:m of current block to zero -* - DO 40 J = N - K + I, N - K + I + IB - 1 - DO 30 L = M - K + I + IB, M - A( L, J ) = ZERO - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - END IF -* - WORK( 1 ) = IWS - RETURN -* -* End of ZUNGQL -* - END diff --git a/lib/linalg/zungqr.cpp b/lib/linalg/zungqr.cpp new file mode 100644 index 0000000000..5368d9130d --- /dev/null +++ b/lib/linalg/zungqr.cpp @@ -0,0 +1,131 @@ +#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; +int zungqr_(integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, + doublecomplex *work, integer *lwork, integer *info) +{ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + integer i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo; + extern int zung2r_(integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *), + xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, + ftnlen, ftnlen); + extern int zlarfb_(char *, char *, char *, char *, integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); + integer ldwork; + extern int zlarft_(char *, char *, integer *, integer *, doublecomplex *, integer *, + doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen); + integer lwkopt; + logical lquery; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + --work; + *info = 0; + nb = ilaenv_(&c__1, (char *)"ZUNGQR", (char *)" ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1); + lwkopt = max(1, *n) * nb; + work[1].r = (doublereal)lwkopt, work[1].i = 0.; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0 || *n > *m) { + *info = -2; + } else if (*k < 0 || *k > *n) { + *info = -3; + } else if (*lda < max(1, *m)) { + *info = -5; + } else if (*lwork < max(1, *n) && !lquery) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"ZUNGQR", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + if (*n <= 0) { + work[1].r = 1., work[1].i = 0.; + return 0; + } + nbmin = 2; + nx = 0; + iws = *n; + if (nb > 1 && nb < *k) { + i__1 = 0, i__2 = ilaenv_(&c__3, (char *)"ZUNGQR", (char *)" ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1); + nx = max(i__1, i__2); + if (nx < *k) { + ldwork = *n; + iws = ldwork * nb; + if (*lwork < iws) { + nb = *lwork / ldwork; + i__1 = 2, + i__2 = ilaenv_(&c__2, (char *)"ZUNGQR", (char *)" ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1); + nbmin = max(i__1, i__2); + } + } + } + if (nb >= nbmin && nb < *k && nx < *k) { + ki = (*k - nx - 1) / nb * nb; + i__1 = *k, i__2 = ki + nb; + kk = min(i__1, i__2); + i__1 = *n; + for (j = kk + 1; j <= i__1; ++j) { + i__2 = kk; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; + } + } + } else { + kk = 0; + } + if (kk < *n) { + i__1 = *m - kk; + i__2 = *n - kk; + i__3 = *k - kk; + zung2r_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, &tau[kk + 1], &work[1], + &iinfo); + } + if (kk > 0) { + i__1 = -nb; + for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { + i__2 = nb, i__3 = *k - i__ + 1; + ib = min(i__2, i__3); + if (i__ + ib <= *n) { + i__2 = *m - i__ + 1; + zlarft_((char *)"Forward", (char *)"Columnwise", &i__2, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], + &work[1], &ldwork, (ftnlen)7, (ftnlen)10); + i__2 = *m - i__ + 1; + i__3 = *n - i__ - ib + 1; + zlarfb_((char *)"Left", (char *)"No transpose", (char *)"Forward", (char *)"Columnwise", &i__2, &i__3, &ib, + &a[i__ + i__ * a_dim1], lda, &work[1], &ldwork, + &a[i__ + (i__ + ib) * a_dim1], lda, &work[ib + 1], &ldwork, (ftnlen)4, + (ftnlen)12, (ftnlen)7, (ftnlen)10); + } + i__2 = *m - i__ + 1; + zung2r_(&i__2, &ib, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1], &iinfo); + i__2 = i__ + ib - 1; + for (j = i__; j <= i__2; ++j) { + i__3 = i__ - 1; + for (l = 1; l <= i__3; ++l) { + i__4 = l + j * a_dim1; + a[i__4].r = 0., a[i__4].i = 0.; + } + } + } + } + work[1].r = (doublereal)iws, work[1].i = 0.; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zungqr.f b/lib/linalg/zungqr.f deleted file mode 100644 index b3f2c4507f..0000000000 --- a/lib/linalg/zungqr.f +++ /dev/null @@ -1,287 +0,0 @@ -*> \brief \b ZUNGQR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZUNGQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. -* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZUNGQR generates an M-by-N complex matrix Q with orthonormal columns, -*> which is defined as the first N columns of a product of K elementary -*> reflectors of order M -*> -*> Q = H(1) H(2) . . . H(k) -*> -*> as returned by ZGEQRF. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix Q. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix Q. M >= N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines the -*> matrix Q. N >= K >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,N) -*> On entry, the i-th column must contain the vector which -*> defines the elementary reflector H(i), for i = 1,2,...,k, as -*> returned by ZGEQRF in the first k columns of its array -*> argument A. -*> On exit, the M-by-N matrix Q. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The first dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by ZGEQRF. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. LWORK >= max(1,N). -*> For optimum performance LWORK >= N*NB, where NB is the -*> optimal blocksize. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal size of the WORK array, returns -*> this value as the first entry of the WORK array, and no error -*> message related to LWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument has an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, - $ LWKOPT, NB, NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNG2R -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - NB = ILAENV( 1, 'ZUNGQR', ' ', M, N, K, -1 ) - LWKOPT = MAX( 1, N )*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNGQR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - NX = 0 - IWS = N - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'ZUNGQR', ' ', M, N, K, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'ZUNGQR', ' ', M, N, K, -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code after the last block. -* The first kk columns are handled by the block method. -* - KI = ( ( K-NX-1 ) / NB )*NB - KK = MIN( K, KI+NB ) -* -* Set A(1:kk,kk+1:n) to zero. -* - DO 20 J = KK + 1, N - DO 10 I = 1, KK - A( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - KK = 0 - END IF -* -* Use unblocked code for the last or only block. -* - IF( KK.LT.N ) - $ CALL ZUNG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, - $ TAU( KK+1 ), WORK, IINFO ) -* - IF( KK.GT.0 ) THEN -* -* Use blocked code -* - DO 50 I = KI + 1, 1, -NB - IB = MIN( NB, K-I+1 ) - IF( I+IB.LE.N ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL ZLARFT( 'Forward', 'Columnwise', M-I+1, IB, - $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H to A(i:m,i+ib:n) from the left -* - CALL ZLARFB( 'Left', 'No transpose', 'Forward', - $ 'Columnwise', M-I+1, N-I-IB+1, IB, - $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), - $ LDA, WORK( IB+1 ), LDWORK ) - END IF -* -* Apply H to rows i:m of current block -* - CALL ZUNG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) -* -* Set rows 1:i-1 of current block to zero -* - DO 40 J = I, I + IB - 1 - DO 30 L = 1, I - 1 - A( L, J ) = ZERO - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - END IF -* - WORK( 1 ) = IWS - RETURN -* -* End of ZUNGQR -* - END diff --git a/lib/linalg/zungtr.cpp b/lib/linalg/zungtr.cpp new file mode 100644 index 0000000000..9a2ba97b64 --- /dev/null +++ b/lib/linalg/zungtr.cpp @@ -0,0 +1,125 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +static integer c_n1 = -1; +int zungtr_(char *uplo, integer *n, doublecomplex *a, integer *lda, doublecomplex *tau, + doublecomplex *work, integer *lwork, integer *info, ftnlen uplo_len) +{ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + integer i__, j, nb; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + integer iinfo; + logical upper; + extern int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, + ftnlen, ftnlen); + integer lwkopt; + logical lquery; + extern int zungql_(integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, integer *), + zungqr_(integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, integer *); + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + --work; + *info = 0; + lquery = *lwork == -1; + 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; + } else { + i__1 = 1, i__2 = *n - 1; + if (*lwork < max(i__1, i__2) && !lquery) { + *info = -7; + } + } + if (*info == 0) { + if (upper) { + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + nb = ilaenv_(&c__1, (char *)"ZUNGQL", (char *)" ", &i__1, &i__2, &i__3, &c_n1, (ftnlen)6, (ftnlen)1); + } else { + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + nb = ilaenv_(&c__1, (char *)"ZUNGQR", (char *)" ", &i__1, &i__2, &i__3, &c_n1, (ftnlen)6, (ftnlen)1); + } + i__1 = 1, i__2 = *n - 1; + lwkopt = max(i__1, i__2) * nb; + work[1].r = (doublereal)lwkopt, work[1].i = 0.; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"ZUNGTR", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + if (*n == 0) { + work[1].r = 1., work[1].i = 0.; + return 0; + } + if (upper) { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + (j + 1) * a_dim1; + a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i; + } + i__2 = *n + j * a_dim1; + a[i__2].r = 0., a[i__2].i = 0.; + } + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + *n * a_dim1; + a[i__2].r = 0., a[i__2].i = 0.; + } + i__1 = *n + *n * a_dim1; + a[i__1].r = 1., a[i__1].i = 0.; + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + zungql_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], lwork, &iinfo); + } else { + for (j = *n; j >= 2; --j) { + i__1 = j * a_dim1 + 1; + a[i__1].r = 0., a[i__1].i = 0.; + i__1 = *n; + for (i__ = j + 1; i__ <= i__1; ++i__) { + i__2 = i__ + j * a_dim1; + i__3 = i__ + (j - 1) * a_dim1; + a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i; + } + } + i__1 = a_dim1 + 1; + a[i__1].r = 1., a[i__1].i = 0.; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + i__2 = i__ + a_dim1; + a[i__2].r = 0., a[i__2].i = 0.; + } + if (*n > 1) { + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + zungqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[1], &work[1], lwork, + &iinfo); + } + } + work[1].r = (doublereal)lwkopt, work[1].i = 0.; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zungtr.f b/lib/linalg/zungtr.f deleted file mode 100644 index 01e100a8cd..0000000000 --- a/lib/linalg/zungtr.f +++ /dev/null @@ -1,253 +0,0 @@ -*> \brief \b ZUNGTR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZUNGTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER UPLO -* INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. -* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZUNGTR generates a complex unitary matrix Q which is defined as the -*> product of n-1 elementary reflectors of order N, as returned by -*> ZHETRD: -*> -*> if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), -*> -*> if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A contains elementary reflectors -*> from ZHETRD; -*> = 'L': Lower triangle of A contains elementary reflectors -*> from ZHETRD. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The order of the matrix Q. N >= 0. -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,N) -*> On entry, the vectors which define the elementary reflectors, -*> as returned by ZHETRD. -*> On exit, the N-by-N unitary matrix Q. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= N. -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension (N-1) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by ZHETRD. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. LWORK >= N-1. -*> For optimum performance LWORK >= (N-1)*NB, where NB is -*> the optimal blocksize. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal size of the WORK array, returns -*> this value as the first entry of the WORK array, and no error -*> message related to LWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), - $ ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY, UPPER - INTEGER I, IINFO, J, LWKOPT, NB -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZUNGQL, ZUNGQR -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN - INFO = -7 - END IF -* - IF( INFO.EQ.0 ) THEN - IF( UPPER ) THEN - NB = ILAENV( 1, 'ZUNGQL', ' ', N-1, N-1, N-1, -1 ) - ELSE - NB = ILAENV( 1, 'ZUNGQR', ' ', N-1, N-1, N-1, -1 ) - END IF - LWKOPT = MAX( 1, N-1 )*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNGTR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - IF( UPPER ) THEN -* -* Q was determined by a call to ZHETRD with UPLO = 'U' -* -* Shift the vectors which define the elementary reflectors one -* column to the left, and set the last row and column of Q to -* those of the unit matrix -* - DO 20 J = 1, N - 1 - DO 10 I = 1, J - 1 - A( I, J ) = A( I, J+1 ) - 10 CONTINUE - A( N, J ) = ZERO - 20 CONTINUE - DO 30 I = 1, N - 1 - A( I, N ) = ZERO - 30 CONTINUE - A( N, N ) = ONE -* -* Generate Q(1:n-1,1:n-1) -* - CALL ZUNGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO ) -* - ELSE -* -* Q was determined by a call to ZHETRD with UPLO = 'L'. -* -* Shift the vectors which define the elementary reflectors one -* column to the right, and set the first row and column of Q to -* those of the unit matrix -* - DO 50 J = N, 2, -1 - A( 1, J ) = ZERO - DO 40 I = J + 1, N - A( I, J ) = A( I, J-1 ) - 40 CONTINUE - 50 CONTINUE - A( 1, 1 ) = ONE - DO 60 I = 2, N - A( I, 1 ) = ZERO - 60 CONTINUE - IF( N.GT.1 ) THEN -* -* Generate Q(2:n,2:n) -* - CALL ZUNGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, - $ LWORK, IINFO ) - END IF - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of ZUNGTR -* - END diff --git a/lib/linalg/zunm2l.cpp b/lib/linalg/zunm2l.cpp new file mode 100644 index 0000000000..6358ee33a3 --- /dev/null +++ b/lib/linalg/zunm2l.cpp @@ -0,0 +1,103 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +int zunm2l_(char *side, char *trans, integer *m, integer *n, integer *k, doublecomplex *a, + integer *lda, doublecomplex *tau, doublecomplex *c__, integer *ldc, doublecomplex *work, + integer *info, ftnlen side_len, ftnlen trans_len) +{ + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3; + doublecomplex z__1; + void d_lmp_cnjg(doublecomplex *, doublecomplex *); + integer i__, i1, i2, i3, mi, ni, nq; + doublecomplex aii; + logical left; + doublecomplex taui; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern int zlarf_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, ftnlen), + xerbla_(char *, integer *, ftnlen); + logical notran; + 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; + left = lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1); + notran = lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1); + if (left) { + nq = *m; + } else { + nq = *n; + } + if (!left && !lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { + *info = -1; + } else if (!notran && !lsame_(trans, (char *)"C", (ftnlen)1, (ftnlen)1)) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0 || *k > nq) { + *info = -5; + } else if (*lda < max(1, nq)) { + *info = -7; + } else if (*ldc < max(1, *m)) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"ZUNM2L", &i__1, (ftnlen)6); + return 0; + } + if (*m == 0 || *n == 0 || *k == 0) { + return 0; + } + if (left && notran || !left && !notran) { + i1 = 1; + i2 = *k; + i3 = 1; + } else { + i1 = *k; + i2 = 1; + i3 = -1; + } + if (left) { + ni = *n; + } else { + mi = *m; + } + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + if (left) { + mi = *m - *k + i__; + } else { + ni = *n - *k + i__; + } + if (notran) { + i__3 = i__; + taui.r = tau[i__3].r, taui.i = tau[i__3].i; + } else { + d_lmp_cnjg(&z__1, &tau[i__]); + taui.r = z__1.r, taui.i = z__1.i; + } + i__3 = nq - *k + i__ + i__ * a_dim1; + aii.r = a[i__3].r, aii.i = a[i__3].i; + i__3 = nq - *k + i__ + i__ * a_dim1; + a[i__3].r = 1., a[i__3].i = 0.; + zlarf_(side, &mi, &ni, &a[i__ * a_dim1 + 1], &c__1, &taui, &c__[c_offset], ldc, &work[1], + (ftnlen)1); + i__3 = nq - *k + i__ + i__ * a_dim1; + a[i__3].r = aii.r, a[i__3].i = aii.i; + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zunm2l.f b/lib/linalg/zunm2l.f deleted file mode 100644 index 48c2dbfc0c..0000000000 --- a/lib/linalg/zunm2l.f +++ /dev/null @@ -1,278 +0,0 @@ -*> \brief \b ZUNM2L multiplies a general matrix by the unitary matrix from a QL factorization determined by cgeqlf (unblocked algorithm). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZUNM2L + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, -* WORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER SIDE, TRANS -* INTEGER INFO, K, LDA, LDC, M, N -* .. -* .. Array Arguments .. -* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZUNM2L overwrites the general complex m-by-n matrix C with -*> -*> Q * C if SIDE = 'L' and TRANS = 'N', or -*> -*> Q**H* C if SIDE = 'L' and TRANS = 'C', or -*> -*> C * Q if SIDE = 'R' and TRANS = 'N', or -*> -*> C * Q**H if SIDE = 'R' and TRANS = 'C', -*> -*> where Q is a complex unitary matrix defined as the product of k -*> elementary reflectors -*> -*> Q = H(k) . . . H(2) H(1) -*> -*> as returned by ZGEQLF. Q is of order m if SIDE = 'L' and of order n -*> if SIDE = 'R'. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': apply Q or Q**H from the Left -*> = 'R': apply Q or Q**H from the Right -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> = 'N': apply Q (No transpose) -*> = 'C': apply Q**H (Conjugate transpose) -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines -*> the matrix Q. -*> If SIDE = 'L', M >= K >= 0; -*> if SIDE = 'R', N >= K >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,K) -*> The i-th column must contain the vector which defines the -*> elementary reflector H(i), for i = 1,2,...,k, as returned by -*> ZGEQLF in the last k columns of its array argument A. -*> A is modified by the routine but restored on exit. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. -*> If SIDE = 'L', LDA >= max(1,M); -*> if SIDE = 'R', LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by ZGEQLF. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is COMPLEX*16 array, dimension (LDC,N) -*> On entry, the m-by-n matrix C. -*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 array, dimension -*> (N) if SIDE = 'L', -*> (M) if SIDE = 'R' -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, NOTRAN - INTEGER I, I1, I2, I3, MI, NI, NQ - COMPLEX*16 AII, TAUI -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLARF -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) -* -* NQ is the order of Q -* - IF( LEFT ) THEN - NQ = M - ELSE - NQ = N - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNM2L', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN -* - IF( ( LEFT .AND. NOTRAN .OR. .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN - I1 = 1 - I2 = K - I3 = 1 - ELSE - I1 = K - I2 = 1 - I3 = -1 - END IF -* - IF( LEFT ) THEN - NI = N - ELSE - MI = M - END IF -* - DO 10 I = I1, I2, I3 - IF( LEFT ) THEN -* -* H(i) or H(i)**H is applied to C(1:m-k+i,1:n) -* - MI = M - K + I - ELSE -* -* H(i) or H(i)**H is applied to C(1:m,1:n-k+i) -* - NI = N - K + I - END IF -* -* Apply H(i) or H(i)**H -* - IF( NOTRAN ) THEN - TAUI = TAU( I ) - ELSE - TAUI = DCONJG( TAU( I ) ) - END IF - AII = A( NQ-K+I, I ) - A( NQ-K+I, I ) = ONE - CALL ZLARF( SIDE, MI, NI, A( 1, I ), 1, TAUI, C, LDC, WORK ) - A( NQ-K+I, I ) = AII - 10 CONTINUE - RETURN -* -* End of ZUNM2L -* - END diff --git a/lib/linalg/zunm2r.cpp b/lib/linalg/zunm2r.cpp new file mode 100644 index 0000000000..e1c04b13f5 --- /dev/null +++ b/lib/linalg/zunm2r.cpp @@ -0,0 +1,107 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "lmp_f2c.h" +static integer c__1 = 1; +int zunm2r_(char *side, char *trans, integer *m, integer *n, integer *k, doublecomplex *a, + integer *lda, doublecomplex *tau, doublecomplex *c__, integer *ldc, doublecomplex *work, + integer *info, ftnlen side_len, ftnlen trans_len) +{ + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3; + doublecomplex z__1; + void d_lmp_cnjg(doublecomplex *, doublecomplex *); + integer i__, i1, i2, i3, ic, jc, mi, ni, nq; + doublecomplex aii; + logical left; + doublecomplex taui; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + extern int zlarf_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, ftnlen), + xerbla_(char *, integer *, ftnlen); + logical notran; + 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; + left = lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1); + notran = lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1); + if (left) { + nq = *m; + } else { + nq = *n; + } + if (!left && !lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { + *info = -1; + } else if (!notran && !lsame_(trans, (char *)"C", (ftnlen)1, (ftnlen)1)) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0 || *k > nq) { + *info = -5; + } else if (*lda < max(1, nq)) { + *info = -7; + } else if (*ldc < max(1, *m)) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"ZUNM2R", &i__1, (ftnlen)6); + return 0; + } + if (*m == 0 || *n == 0 || *k == 0) { + return 0; + } + if (left && !notran || !left && notran) { + i1 = 1; + i2 = *k; + i3 = 1; + } else { + i1 = *k; + i2 = 1; + i3 = -1; + } + if (left) { + ni = *n; + jc = 1; + } else { + mi = *m; + ic = 1; + } + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + if (left) { + mi = *m - i__ + 1; + ic = i__; + } else { + ni = *n - i__ + 1; + jc = i__; + } + if (notran) { + i__3 = i__; + taui.r = tau[i__3].r, taui.i = tau[i__3].i; + } else { + d_lmp_cnjg(&z__1, &tau[i__]); + taui.r = z__1.r, taui.i = z__1.i; + } + i__3 = i__ + i__ * a_dim1; + aii.r = a[i__3].r, aii.i = a[i__3].i; + i__3 = i__ + i__ * a_dim1; + a[i__3].r = 1., a[i__3].i = 0.; + zlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], &c__1, &taui, &c__[ic + jc * c_dim1], ldc, + &work[1], (ftnlen)1); + i__3 = i__ + i__ * a_dim1; + a[i__3].r = aii.r, a[i__3].i = aii.i; + } + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zunm2r.f b/lib/linalg/zunm2r.f deleted file mode 100644 index aec5a8bcae..0000000000 --- a/lib/linalg/zunm2r.f +++ /dev/null @@ -1,283 +0,0 @@ -*> \brief \b ZUNM2R multiplies a general matrix by the unitary matrix from a QR factorization determined by cgeqrf (unblocked algorithm). -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZUNM2R + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, -* WORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER SIDE, TRANS -* INTEGER INFO, K, LDA, LDC, M, N -* .. -* .. Array Arguments .. -* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZUNM2R overwrites the general complex m-by-n matrix C with -*> -*> Q * C if SIDE = 'L' and TRANS = 'N', or -*> -*> Q**H* C if SIDE = 'L' and TRANS = 'C', or -*> -*> C * Q if SIDE = 'R' and TRANS = 'N', or -*> -*> C * Q**H if SIDE = 'R' and TRANS = 'C', -*> -*> where Q is a complex unitary matrix defined as the product of k -*> elementary reflectors -*> -*> Q = H(1) H(2) . . . H(k) -*> -*> as returned by ZGEQRF. Q is of order m if SIDE = 'L' and of order n -*> if SIDE = 'R'. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': apply Q or Q**H from the Left -*> = 'R': apply Q or Q**H from the Right -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> = 'N': apply Q (No transpose) -*> = 'C': apply Q**H (Conjugate transpose) -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines -*> the matrix Q. -*> If SIDE = 'L', M >= K >= 0; -*> if SIDE = 'R', N >= K >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,K) -*> The i-th column must contain the vector which defines the -*> elementary reflector H(i), for i = 1,2,...,k, as returned by -*> ZGEQRF in the first k columns of its array argument A. -*> A is modified by the routine but restored on exit. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. -*> If SIDE = 'L', LDA >= max(1,M); -*> if SIDE = 'R', LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by ZGEQRF. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is COMPLEX*16 array, dimension (LDC,N) -*> On entry, the m-by-n matrix C. -*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 array, dimension -*> (N) if SIDE = 'L', -*> (M) if SIDE = 'R' -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, NOTRAN - INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ - COMPLEX*16 AII, TAUI -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLARF -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) -* -* NQ is the order of Q -* - IF( LEFT ) THEN - NQ = M - ELSE - NQ = N - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNM2R', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN -* - IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN - I1 = 1 - I2 = K - I3 = 1 - ELSE - I1 = K - I2 = 1 - I3 = -1 - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - DO 10 I = I1, I2, I3 - IF( LEFT ) THEN -* -* H(i) or H(i)**H is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H(i) or H(i)**H is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H(i) or H(i)**H -* - IF( NOTRAN ) THEN - TAUI = TAU( I ) - ELSE - TAUI = DCONJG( TAU( I ) ) - END IF - AII = A( I, I ) - A( I, I ) = ONE - CALL ZLARF( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ), LDC, - $ WORK ) - A( I, I ) = AII - 10 CONTINUE - RETURN -* -* End of ZUNM2R -* - END diff --git a/lib/linalg/zunmql.cpp b/lib/linalg/zunmql.cpp new file mode 100644 index 0000000000..11eca14656 --- /dev/null +++ b/lib/linalg/zunmql.cpp @@ -0,0 +1,149 @@ +#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 integer c__65 = 65; +int zunmql_(char *side, char *trans, integer *m, integer *n, integer *k, doublecomplex *a, + integer *lda, doublecomplex *tau, doublecomplex *c__, integer *ldc, doublecomplex *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, i__2, i__3[2], i__4, i__5; + char ch__1[2]; + int s_lmp_cat(char *, char **, integer *, integer *, ftnlen); + integer i__, i1, i2, i3, ib, nb, mi, ni, nq, nw, iwt; + logical left; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + integer nbmin, iinfo; + extern int zunm2l_(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, + ftnlen, ftnlen), + xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, + ftnlen, ftnlen); + extern int zlarfb_(char *, char *, char *, char *, integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); + logical notran; + integer ldwork; + extern int zlarft_(char *, char *, integer *, integer *, doublecomplex *, integer *, + doublecomplex *, doublecomplex *, 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; + left = lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1); + notran = lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1); + lquery = *lwork == -1; + if (left) { + nq = *m; + nw = max(1, *n); + } else { + nq = *n; + nw = max(1, *m); + } + if (!left && !lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { + *info = -1; + } else if (!notran && !lsame_(trans, (char *)"C", (ftnlen)1, (ftnlen)1)) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0 || *k > nq) { + *info = -5; + } else if (*lda < max(1, nq)) { + *info = -7; + } else if (*ldc < max(1, *m)) { + *info = -10; + } else if (*lwork < nw && !lquery) { + *info = -12; + } + if (*info == 0) { + if (*m == 0 || *n == 0) { + lwkopt = 1; + } else { + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_lmp_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = 64, i__2 = ilaenv_(&c__1, (char *)"ZUNMQL", ch__1, m, n, k, &c_n1, (ftnlen)6, (ftnlen)2); + nb = min(i__1, i__2); + lwkopt = nw * nb + 4160; + } + work[1].r = (doublereal)lwkopt, work[1].i = 0.; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"ZUNMQL", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + if (*m == 0 || *n == 0) { + return 0; + } + nbmin = 2; + ldwork = nw; + if (nb > 1 && nb < *k) { + if (*lwork < lwkopt) { + nb = (*lwork - 4160) / ldwork; + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_lmp_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"ZUNMQL", ch__1, m, n, k, &c_n1, (ftnlen)6, (ftnlen)2); + nbmin = max(i__1, i__2); + } + } + if (nb < nbmin || nb >= *k) { + zunm2l_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[c_offset], ldc, &work[1], + &iinfo, (ftnlen)1, (ftnlen)1); + } else { + iwt = nw * nb + 1; + if (left && notran || !left && !notran) { + i1 = 1; + i2 = *k; + i3 = nb; + } else { + i1 = (*k - 1) / nb * nb + 1; + i2 = 1; + i3 = -nb; + } + if (left) { + ni = *n; + } else { + mi = *m; + } + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + i__4 = nb, i__5 = *k - i__ + 1; + ib = min(i__4, i__5); + i__4 = nq - *k + i__ + ib - 1; + zlarft_((char *)"Backward", (char *)"Columnwise", &i__4, &ib, &a[i__ * a_dim1 + 1], lda, &tau[i__], + &work[iwt], &c__65, (ftnlen)8, (ftnlen)10); + if (left) { + mi = *m - *k + i__ + ib - 1; + } else { + ni = *n - *k + i__ + ib - 1; + } + zlarfb_(side, trans, (char *)"Backward", (char *)"Columnwise", &mi, &ni, &ib, &a[i__ * a_dim1 + 1], lda, + &work[iwt], &c__65, &c__[c_offset], ldc, &work[1], &ldwork, (ftnlen)1, + (ftnlen)1, (ftnlen)8, (ftnlen)10); + } + } + work[1].r = (doublereal)lwkopt, work[1].i = 0.; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zunmql.f b/lib/linalg/zunmql.f deleted file mode 100644 index 06353a0c75..0000000000 --- a/lib/linalg/zunmql.f +++ /dev/null @@ -1,336 +0,0 @@ -*> \brief \b ZUNMQL -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZUNMQL + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZUNMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, -* WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER SIDE, TRANS -* INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. -* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZUNMQL overwrites the general complex M-by-N matrix C with -*> -*> SIDE = 'L' SIDE = 'R' -*> TRANS = 'N': Q * C C * Q -*> TRANS = 'C': Q**H * C C * Q**H -*> -*> where Q is a complex unitary matrix defined as the product of k -*> elementary reflectors -*> -*> Q = H(k) . . . H(2) H(1) -*> -*> as returned by ZGEQLF. Q is of order M if SIDE = 'L' and of order N -*> if SIDE = 'R'. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': apply Q or Q**H from the Left; -*> = 'R': apply Q or Q**H from the Right. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> = 'N': No transpose, apply Q; -*> = 'C': Conjugate transpose, apply Q**H. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines -*> the matrix Q. -*> If SIDE = 'L', M >= K >= 0; -*> if SIDE = 'R', N >= K >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,K) -*> The i-th column must contain the vector which defines the -*> elementary reflector H(i), for i = 1,2,...,k, as returned by -*> ZGEQLF in the last k columns of its array argument A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. -*> If SIDE = 'L', LDA >= max(1,M); -*> if SIDE = 'R', LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by ZGEQLF. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is COMPLEX*16 array, dimension (LDC,N) -*> On entry, the M-by-N matrix C. -*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. -*> If SIDE = 'L', LWORK >= max(1,N); -*> if SIDE = 'R', LWORK >= max(1,M). -*> For good performance, LWORK should generally be larger. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal size of the WORK array, returns -*> this value as the first entry of the WORK array, and no error -*> message related to LWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZUNMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - INTEGER NBMAX, LDT, TSIZE - PARAMETER ( NBMAX = 64, LDT = NBMAX+1, - $ TSIZE = LDT*NBMAX ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, LQUERY, NOTRAN - INTEGER I, I1, I2, I3, IB, IINFO, IWT, LDWORK, LWKOPT, - $ MI, NB, NBMIN, NI, NQ, NW -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNM2L -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) - LQUERY = ( LWORK.EQ.-1 ) -* -* NQ is the order of Q and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = MAX( 1, N ) - ELSE - NQ = N - NW = MAX( 1, M ) - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF -* - IF( INFO.EQ.0 ) THEN -* -* Compute the workspace requirements -* - IF( M.EQ.0 .OR. N.EQ.0 ) THEN - LWKOPT = 1 - ELSE - NB = MIN( NBMAX, ILAENV( 1, 'ZUNMQL', SIDE // TRANS, M, N, - $ K, -1 ) ) - LWKOPT = NW*NB + TSIZE - END IF - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNMQL', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) THEN - RETURN - END IF -* - NBMIN = 2 - LDWORK = NW - IF( NB.GT.1 .AND. NB.LT.K ) THEN - IF( LWORK.LT.LWKOPT ) THEN - NB = (LWORK-TSIZE) / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'ZUNMQL', SIDE // TRANS, M, N, K, - $ -1 ) ) - END IF - END IF -* - IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN -* -* Use unblocked code -* - CALL ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, - $ IINFO ) - ELSE -* -* Use blocked code -* - IWT = 1 + NW*NB - IF( ( LEFT .AND. NOTRAN ) .OR. - $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN - I1 = 1 - I2 = K - I3 = NB - ELSE - I1 = ( ( K-1 ) / NB )*NB + 1 - I2 = 1 - I3 = -NB - END IF -* - IF( LEFT ) THEN - NI = N - ELSE - MI = M - END IF -* - DO 10 I = I1, I2, I3 - IB = MIN( NB, K-I+1 ) -* -* Form the triangular factor of the block reflector -* H = H(i+ib-1) . . . H(i+1) H(i) -* - CALL ZLARFT( 'Backward', 'Columnwise', NQ-K+I+IB-1, IB, - $ A( 1, I ), LDA, TAU( I ), WORK( IWT ), LDT ) - IF( LEFT ) THEN -* -* H or H**H is applied to C(1:m-k+i+ib-1,1:n) -* - MI = M - K + I + IB - 1 - ELSE -* -* H or H**H is applied to C(1:m,1:n-k+i+ib-1) -* - NI = N - K + I + IB - 1 - END IF -* -* Apply H or H**H -* - CALL ZLARFB( SIDE, TRANS, 'Backward', 'Columnwise', MI, NI, - $ IB, A( 1, I ), LDA, WORK( IWT ), LDT, C, LDC, - $ WORK, LDWORK ) - 10 CONTINUE - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of ZUNMQL -* - END diff --git a/lib/linalg/zunmqr.cpp b/lib/linalg/zunmqr.cpp new file mode 100644 index 0000000000..7a82cd0681 --- /dev/null +++ b/lib/linalg/zunmqr.cpp @@ -0,0 +1,150 @@ +#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 integer c__65 = 65; +int zunmqr_(char *side, char *trans, integer *m, integer *n, integer *k, doublecomplex *a, + integer *lda, doublecomplex *tau, doublecomplex *c__, integer *ldc, doublecomplex *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, i__2, i__3[2], i__4, i__5; + char ch__1[2]; + int s_lmp_cat(char *, char **, integer *, integer *, ftnlen); + integer i__, i1, i2, i3, ib, ic, jc, nb, mi, ni, nq, nw, iwt; + logical left; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + integer nbmin, iinfo; + extern int zunm2r_(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, + ftnlen, ftnlen), + xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, + ftnlen, ftnlen); + extern int zlarfb_(char *, char *, char *, char *, integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); + logical notran; + integer ldwork; + extern int zlarft_(char *, char *, integer *, integer *, doublecomplex *, integer *, + doublecomplex *, doublecomplex *, 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; + left = lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1); + notran = lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1); + lquery = *lwork == -1; + if (left) { + nq = *m; + nw = max(1, *n); + } else { + nq = *n; + nw = max(1, *m); + } + if (!left && !lsame_(side, (char *)"R", (ftnlen)1, (ftnlen)1)) { + *info = -1; + } else if (!notran && !lsame_(trans, (char *)"C", (ftnlen)1, (ftnlen)1)) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0 || *k > nq) { + *info = -5; + } else if (*lda < max(1, nq)) { + *info = -7; + } else if (*ldc < max(1, *m)) { + *info = -10; + } else if (*lwork < nw && !lquery) { + *info = -12; + } + if (*info == 0) { + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_lmp_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = 64, i__2 = ilaenv_(&c__1, (char *)"ZUNMQR", ch__1, m, n, k, &c_n1, (ftnlen)6, (ftnlen)2); + nb = min(i__1, i__2); + lwkopt = nw * nb + 4160; + work[1].r = (doublereal)lwkopt, work[1].i = 0.; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_((char *)"ZUNMQR", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + if (*m == 0 || *n == 0 || *k == 0) { + work[1].r = 1., work[1].i = 0.; + return 0; + } + nbmin = 2; + ldwork = nw; + if (nb > 1 && nb < *k) { + if (*lwork < lwkopt) { + nb = (*lwork - 4160) / ldwork; + i__3[0] = 1, a__1[0] = side; + i__3[1] = 1, a__1[1] = trans; + s_lmp_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + i__1 = 2, i__2 = ilaenv_(&c__2, (char *)"ZUNMQR", ch__1, m, n, k, &c_n1, (ftnlen)6, (ftnlen)2); + nbmin = max(i__1, i__2); + } + } + if (nb < nbmin || nb >= *k) { + zunm2r_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[c_offset], ldc, &work[1], + &iinfo, (ftnlen)1, (ftnlen)1); + } else { + iwt = nw * nb + 1; + if (left && !notran || !left && notran) { + i1 = 1; + i2 = *k; + i3 = nb; + } else { + i1 = (*k - 1) / nb * nb + 1; + i2 = 1; + i3 = -nb; + } + if (left) { + ni = *n; + jc = 1; + } else { + mi = *m; + ic = 1; + } + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + i__4 = nb, i__5 = *k - i__ + 1; + ib = min(i__4, i__5); + i__4 = nq - i__ + 1; + zlarft_((char *)"Forward", (char *)"Columnwise", &i__4, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], + &work[iwt], &c__65, (ftnlen)7, (ftnlen)10); + if (left) { + mi = *m - i__ + 1; + ic = i__; + } else { + ni = *n - i__ + 1; + jc = i__; + } + zlarfb_(side, trans, (char *)"Forward", (char *)"Columnwise", &mi, &ni, &ib, &a[i__ + i__ * a_dim1], + lda, &work[iwt], &c__65, &c__[ic + jc * c_dim1], ldc, &work[1], &ldwork, + (ftnlen)1, (ftnlen)1, (ftnlen)7, (ftnlen)10); + } + } + work[1].r = (doublereal)lwkopt, work[1].i = 0.; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zunmqr.f b/lib/linalg/zunmqr.f deleted file mode 100644 index 2ae205f4fd..0000000000 --- a/lib/linalg/zunmqr.f +++ /dev/null @@ -1,337 +0,0 @@ -*> \brief \b ZUNMQR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZUNMQR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, -* WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER SIDE, TRANS -* INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. -* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZUNMQR overwrites the general complex M-by-N matrix C with -*> -*> SIDE = 'L' SIDE = 'R' -*> TRANS = 'N': Q * C C * Q -*> TRANS = 'C': Q**H * C C * Q**H -*> -*> where Q is a complex unitary matrix defined as the product of k -*> elementary reflectors -*> -*> Q = H(1) H(2) . . . H(k) -*> -*> as returned by ZGEQRF. Q is of order M if SIDE = 'L' and of order N -*> if SIDE = 'R'. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': apply Q or Q**H from the Left; -*> = 'R': apply Q or Q**H from the Right. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> = 'N': No transpose, apply Q; -*> = 'C': Conjugate transpose, apply Q**H. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. N >= 0. -*> \endverbatim -*> -*> \param[in] K -*> \verbatim -*> K is INTEGER -*> The number of elementary reflectors whose product defines -*> the matrix Q. -*> If SIDE = 'L', M >= K >= 0; -*> if SIDE = 'R', N >= K >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is COMPLEX*16 array, dimension (LDA,K) -*> The i-th column must contain the vector which defines the -*> elementary reflector H(i), for i = 1,2,...,k, as returned by -*> ZGEQRF in the first k columns of its array argument A. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. -*> If SIDE = 'L', LDA >= max(1,M); -*> if SIDE = 'R', LDA >= max(1,N). -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension (K) -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by ZGEQRF. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is COMPLEX*16 array, dimension (LDC,N) -*> On entry, the M-by-N matrix C. -*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. -*> If SIDE = 'L', LWORK >= max(1,N); -*> if SIDE = 'R', LWORK >= max(1,M). -*> For good performance, LWORK should generally be larger. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal size of the WORK array, returns -*> this value as the first entry of the WORK array, and no error -*> message related to LWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - INTEGER NBMAX, LDT, TSIZE - PARAMETER ( NBMAX = 64, LDT = NBMAX+1, - $ TSIZE = LDT*NBMAX ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, LQUERY, NOTRAN - INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK, - $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNM2R -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) - LQUERY = ( LWORK.EQ.-1 ) -* -* NQ is the order of Q and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = MAX( 1, N ) - ELSE - NQ = N - NW = MAX( 1, M ) - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF -* - IF( INFO.EQ.0 ) THEN -* -* Compute the workspace requirements -* - NB = MIN( NBMAX, ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N, K, - $ -1 ) ) - LWKOPT = NW*NB + TSIZE - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNMQR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - LDWORK = NW - IF( NB.GT.1 .AND. NB.LT.K ) THEN - IF( LWORK.LT.LWKOPT ) THEN - NB = (LWORK-TSIZE) / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'ZUNMQR', SIDE // TRANS, M, N, K, - $ -1 ) ) - END IF - END IF -* - IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN -* -* Use unblocked code -* - CALL ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, - $ IINFO ) - ELSE -* -* Use blocked code -* - IWT = 1 + NW*NB - IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. - $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN - I1 = 1 - I2 = K - I3 = NB - ELSE - I1 = ( ( K-1 ) / NB )*NB + 1 - I2 = 1 - I3 = -NB - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - DO 10 I = I1, I2, I3 - IB = MIN( NB, K-I+1 ) -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL ZLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), - $ LDA, TAU( I ), WORK( IWT ), LDT ) - IF( LEFT ) THEN -* -* H or H**H is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H or H**H is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H or H**H -* - CALL ZLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, - $ IB, A( I, I ), LDA, WORK( IWT ), LDT, - $ C( IC, JC ), LDC, WORK, LDWORK ) - 10 CONTINUE - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of ZUNMQR -* - END diff --git a/lib/linalg/zunmtr.cpp b/lib/linalg/zunmtr.cpp new file mode 100644 index 0000000000..86530bb9c6 --- /dev/null +++ b/lib/linalg/zunmtr.cpp @@ -0,0 +1,145 @@ +#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 zunmtr_(char *side, char *uplo, char *trans, integer *m, integer *n, doublecomplex *a, + integer *lda, doublecomplex *tau, doublecomplex *c__, integer *ldc, doublecomplex *work, + integer *lwork, integer *info, ftnlen side_len, ftnlen uplo_len, ftnlen trans_len) +{ + address a__1[2]; + integer a_dim1, a_offset, c_dim1, c_offset, i__1[2], i__2, i__3; + char ch__1[2]; + int s_lmp_cat(char *, char **, integer *, integer *, ftnlen); + integer i1, i2, nb, mi, ni, nq, nw; + logical left; + extern logical lsame_(char *, char *, ftnlen, ftnlen); + integer iinfo; + logical upper; + extern int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, + ftnlen, ftnlen); + integer lwkopt; + logical lquery; + extern int zunmql_(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, + integer *, ftnlen, ftnlen), + zunmqr_(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer *, + ftnlen, ftnlen); + 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; + left = lsame_(side, (char *)"L", (ftnlen)1, (ftnlen)1); + upper = lsame_(uplo, (char *)"U", (ftnlen)1, (ftnlen)1); + lquery = *lwork == -1; + if (left) { + nq = *m; + nw = max(1, *n); + } else { + nq = *n; + nw = max(1, *m); + } + if (!left && !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 (!lsame_(trans, (char *)"N", (ftnlen)1, (ftnlen)1) && + !lsame_(trans, (char *)"C", (ftnlen)1, (ftnlen)1)) { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*lda < max(1, nq)) { + *info = -7; + } else if (*ldc < max(1, *m)) { + *info = -10; + } else if (*lwork < nw && !lquery) { + *info = -12; + } + if (*info == 0) { + if (upper) { + 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); + i__2 = *m - 1; + i__3 = *m - 1; + nb = ilaenv_(&c__1, (char *)"ZUNMQL", ch__1, &i__2, n, &i__3, &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); + i__2 = *n - 1; + i__3 = *n - 1; + nb = ilaenv_(&c__1, (char *)"ZUNMQL", ch__1, m, &i__2, &i__3, &c_n1, (ftnlen)6, (ftnlen)2); + } + } else { + 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); + i__2 = *m - 1; + i__3 = *m - 1; + nb = ilaenv_(&c__1, (char *)"ZUNMQR", ch__1, &i__2, n, &i__3, &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); + i__2 = *n - 1; + i__3 = *n - 1; + nb = ilaenv_(&c__1, (char *)"ZUNMQR", ch__1, m, &i__2, &i__3, &c_n1, (ftnlen)6, (ftnlen)2); + } + } + lwkopt = nw * nb; + work[1].r = (doublereal)lwkopt, work[1].i = 0.; + } + if (*info != 0) { + i__2 = -(*info); + xerbla_((char *)"ZUNMTR", &i__2, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + if (*m == 0 || *n == 0 || nq == 1) { + work[1].r = 1., work[1].i = 0.; + return 0; + } + if (left) { + mi = *m - 1; + ni = *n; + } else { + mi = *m; + ni = *n - 1; + } + if (upper) { + i__2 = nq - 1; + zunmql_(side, trans, &mi, &ni, &i__2, &a[(a_dim1 << 1) + 1], lda, &tau[1], &c__[c_offset], + ldc, &work[1], lwork, &iinfo, (ftnlen)1, (ftnlen)1); + } else { + if (left) { + i1 = 2; + i2 = 1; + } else { + i1 = 1; + i2 = 2; + } + i__2 = nq - 1; + zunmqr_(side, trans, &mi, &ni, &i__2, &a[a_dim1 + 2], lda, &tau[1], &c__[i1 + i2 * c_dim1], + ldc, &work[1], lwork, &iinfo, (ftnlen)1, (ftnlen)1); + } + work[1].r = (doublereal)lwkopt, work[1].i = 0.; + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/lib/linalg/zunmtr.f b/lib/linalg/zunmtr.f deleted file mode 100644 index 441a7c2bcc..0000000000 --- a/lib/linalg/zunmtr.f +++ /dev/null @@ -1,307 +0,0 @@ -*> \brief \b ZUNMTR -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZUNMTR + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZUNMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, -* WORK, LWORK, INFO ) -* -* .. Scalar Arguments .. -* CHARACTER SIDE, TRANS, UPLO -* INTEGER INFO, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. -* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> ZUNMTR overwrites the general complex M-by-N matrix C with -*> -*> SIDE = 'L' SIDE = 'R' -*> TRANS = 'N': Q * C C * Q -*> TRANS = 'C': Q**H * C C * Q**H -*> -*> where Q is a complex unitary matrix of order nq, with nq = m if -*> SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of -*> nq-1 elementary reflectors, as returned by ZHETRD: -*> -*> if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); -*> -*> if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': apply Q or Q**H from the Left; -*> = 'R': apply Q or Q**H from the Right. -*> \endverbatim -*> -*> \param[in] UPLO -*> \verbatim -*> UPLO is CHARACTER*1 -*> = 'U': Upper triangle of A contains elementary reflectors -*> from ZHETRD; -*> = 'L': Lower triangle of A contains elementary reflectors -*> from ZHETRD. -*> \endverbatim -*> -*> \param[in] TRANS -*> \verbatim -*> TRANS is CHARACTER*1 -*> = 'N': No transpose, apply Q; -*> = 'C': Conjugate transpose, apply Q**H. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix C. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix C. N >= 0. -*> \endverbatim -*> -*> \param[in] A -*> \verbatim -*> A is COMPLEX*16 array, dimension -*> (LDA,M) if SIDE = 'L' -*> (LDA,N) if SIDE = 'R' -*> The vectors which define the elementary reflectors, as -*> returned by ZHETRD. -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. -*> LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. -*> \endverbatim -*> -*> \param[in] TAU -*> \verbatim -*> TAU is COMPLEX*16 array, dimension -*> (M-1) if SIDE = 'L' -*> (N-1) if SIDE = 'R' -*> TAU(i) must contain the scalar factor of the elementary -*> reflector H(i), as returned by ZHETRD. -*> \endverbatim -*> -*> \param[in,out] C -*> \verbatim -*> C is COMPLEX*16 array, dimension (LDC,N) -*> On entry, the M-by-N matrix C. -*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) -*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. -*> If SIDE = 'L', LWORK >= max(1,N); -*> if SIDE = 'R', LWORK >= max(1,M). -*> For optimum performance LWORK >= N*NB if SIDE = 'L', and -*> LWORK >=M*NB if SIDE = 'R', where NB is the optimal -*> blocksize. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal size of the WORK array, returns -*> this value as the first entry of the WORK array, and no error -*> message related to LWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit -*> < 0: if INFO = -i, the i-th argument had an illegal value -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE ZUNMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, - $ WORK, LWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS, UPLO - INTEGER INFO, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL LEFT, LQUERY, UPPER - INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZUNMQL, ZUNMQR -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - UPPER = LSAME( UPLO, 'U' ) - LQUERY = ( LWORK.EQ.-1 ) -* -* NQ is the order of Q and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = MAX( 1, N ) - ELSE - NQ = N - NW = MAX( 1, M ) - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -2 - ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) - $ THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN - INFO = -12 - END IF -* - IF( INFO.EQ.0 ) THEN - IF( UPPER ) THEN - IF( LEFT ) THEN - NB = ILAENV( 1, 'ZUNMQL', SIDE // TRANS, M-1, N, M-1, - $ -1 ) - ELSE - NB = ILAENV( 1, 'ZUNMQL', SIDE // TRANS, M, N-1, N-1, - $ -1 ) - END IF - ELSE - IF( LEFT ) THEN - NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M-1, N, M-1, - $ -1 ) - ELSE - NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N-1, N-1, - $ -1 ) - END IF - END IF - LWKOPT = NW*NB - WORK( 1 ) = LWKOPT - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZUNMTR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. NQ.EQ.1 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - IF( LEFT ) THEN - MI = M - 1 - NI = N - ELSE - MI = M - NI = N - 1 - END IF -* - IF( UPPER ) THEN -* -* Q was determined by a call to ZHETRD with UPLO = 'U' -* - CALL ZUNMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU, C, - $ LDC, WORK, LWORK, IINFO ) - ELSE -* -* Q was determined by a call to ZHETRD with UPLO = 'L' -* - IF( LEFT ) THEN - I1 = 2 - I2 = 1 - ELSE - I1 = 1 - I2 = 2 - END IF - CALL ZUNMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, - $ C( I1, I2 ), LDC, WORK, LWORK, IINFO ) - END IF - WORK( 1 ) = LWKOPT - RETURN -* -* End of ZUNMTR -* - END diff --git a/lib/mlpod/Makefile.lammps.linalg b/lib/mlpod/Makefile.lammps.linalg index cb4d78df99..f37381464d 100644 --- a/lib/mlpod/Makefile.lammps.linalg +++ b/lib/mlpod/Makefile.lammps.linalg @@ -1,5 +1,5 @@ # Settings that the LAMMPS build will import when this package library is used mlpod_SYSINC = -mlpod_SYSLIB = -llinalg -lgfortran +mlpod_SYSLIB = -llinalg mlpod_SYSPATH = -L../../lib/linalg$(LIBOBJDIR) diff --git a/lib/pace/Install.py b/lib/pace/Install.py index 9f132a9580..f7f50d4f6d 100644 --- a/lib/pace/Install.py +++ b/lib/pace/Install.py @@ -18,11 +18,11 @@ from install_helpers import fullpath, geturl, checkmd5sum # settings thisdir = fullpath('.') -version ='v.2022.10.15' +version ='v.2023.01.3' # known checksums for different PACE versions. used to validate the download. checksums = { \ - 'v.2022.10.15': '848ad6a6cc79fa82745927001fb1c9b5' + 'v.2023.01.3': 'f418d32b60e531063ac4285bf702b468' } parser = ArgumentParser(prog='Install.py', description="LAMMPS library build wrapper script") diff --git a/src/KOKKOS/Install.sh b/src/KOKKOS/Install.sh index a5bf6437fc..77a9932d90 100755 --- a/src/KOKKOS/Install.sh +++ b/src/KOKKOS/Install.sh @@ -320,6 +320,8 @@ action pair_multi_lucy_rx_kokkos.cpp pair_multi_lucy_rx.cpp action pair_multi_lucy_rx_kokkos.h pair_multi_lucy_rx.h action pair_pace_kokkos.cpp pair_pace.cpp action pair_pace_kokkos.h pair_pace.h +action pair_pace_extrapolation_kokkos.cpp pair_pace_extrapolation.cpp +action pair_pace_extrapolation_kokkos.h pair_pace_extrapolation.h action pair_reaxff_kokkos.cpp pair_reaxff.cpp action pair_reaxff_kokkos.h pair_reaxff.h action pair_snap_kokkos.cpp pair_snap.cpp diff --git a/src/KOKKOS/pair_pace_extrapolation_kokkos.cpp b/src/KOKKOS/pair_pace_extrapolation_kokkos.cpp new file mode 100644 index 0000000000..e6ae694cad --- /dev/null +++ b/src/KOKKOS/pair_pace_extrapolation_kokkos.cpp @@ -0,0 +1,1882 @@ +// clang-format off +/* -*- c++ -*- ---------------------------------------------------------- + LAMMPS - Large-scale Atomic/Molecular Massively Parallel Simulator + https://www.lammps.org/, Sandia National Laboratories + LAMMPS development team: developers@lammps.org + + Copyright (2003) Sandia Corporation. Under the terms of Contract + aE-AC04-94AL85000 with Sandia Corporation, the U.S. Government retains + certain rights in this software. This software is distributed under + the GNU General Public License. + + See the README file in the top-level LAMMPS directory. +------------------------------------------------------------------------- */ + +/* ---------------------------------------------------------------------- + Contributing author: Yury Lysogorskiy (ICAMS) +------------------------------------------------------------------------- */ + +#include "pair_pace_extrapolation_kokkos.h" + +#include "atom_kokkos.h" +#include "atom_masks.h" +#include "comm.h" +#include "error.h" +#include "force.h" +#include "kokkos.h" +#include "math_const.h" +#include "memory_kokkos.h" +#include "neighbor_kokkos.h" +#include "neigh_request.h" + +#include "ace-evaluator/ace_version.h" +#include "ace-evaluator/ace_radial.h" + +#include "ace/ace_b_basis.h" +#include "ace/ace_b_evaluator.h" + +#include + +namespace LAMMPS_NS { + struct ACEALImpl { + ACEALImpl() : basis_set(nullptr), ace(nullptr) {} + + ~ACEALImpl() { + delete basis_set; + delete ace; + } + + ACEBBasisSet *basis_set; + ACEBEvaluator *ace; + }; +} // namespace LAMMPS_NS + +using namespace LAMMPS_NS; +using namespace MathConst; + +enum{FS,FS_SHIFTEDSCALED}; + +/* ---------------------------------------------------------------------- */ + +template +PairPACEExtrapolationKokkos::PairPACEExtrapolationKokkos(LAMMPS *lmp) : PairPACEExtrapolation(lmp) +{ + respa_enable = 0; + + kokkosable = 1; + atomKK = (AtomKokkos *) atom; + execution_space = ExecutionSpaceFromDevice::space; + datamask_read = EMPTY_MASK; + datamask_modify = EMPTY_MASK; + + host_flag = (execution_space == Host); +} + +/* ---------------------------------------------------------------------- + check if allocated, since class can be destructed when incomplete +------------------------------------------------------------------------- */ + +template +PairPACEExtrapolationKokkos::~PairPACEExtrapolationKokkos() +{ + if (copymode) return; + + memoryKK->destroy_kokkos(k_eatom,eatom); + memoryKK->destroy_kokkos(k_vatom,vatom); + + // deallocate views of views in serial to prevent issues in Kokkos tools + + if (k_splines_gk.h_view.data()) { + for (int i = 0; i < nelements; i++) { + for (int j = 0; j < nelements; j++) { + k_splines_gk.h_view(i, j).deallocate(); + k_splines_rnl.h_view(i, j).deallocate(); + k_splines_hc.h_view(i, j).deallocate(); + } + } + } +} + +/* ---------------------------------------------------------------------- */ + +template +void PairPACEExtrapolationKokkos::grow(int natom, int maxneigh) +{ + auto basis_set = aceimpl->basis_set; + + if ((int)A.extent(0) < natom) { + + MemKK::realloc_kokkos(A, "pace:A", natom, nelements, nradmax + 1, (lmax + 1) * (lmax + 1)); + MemKK::realloc_kokkos(A_rank1, "pace:A_rank1", natom, nelements, nradbase); + + MemKK::realloc_kokkos(A_list, "pace:A_list", natom, idx_ms_combs_max, basis_set->rankmax); + //size is +1 of max to avoid out-of-boundary array access in double-triangular scheme + MemKK::realloc_kokkos(A_forward_prod, "pace:A_forward_prod", natom, idx_ms_combs_max, basis_set->rankmax + 1); + + MemKK::realloc_kokkos(e_atom, "pace:e_atom", natom); + MemKK::realloc_kokkos(rhos, "pace:rhos", natom, basis_set->ndensitymax + 1); // +1 density for core repulsion + MemKK::realloc_kokkos(dF_drho, "pace:dF_drho", natom, basis_set->ndensitymax + 1); // +1 density for core repulsion + + MemKK::realloc_kokkos(weights, "pace:weights", natom, nelements, nradmax + 1, (lmax + 1) * (lmax + 1)); + MemKK::realloc_kokkos(weights_rank1, "pace:weights_rank1", natom, nelements, nradbase); + + // hard-core repulsion + MemKK::realloc_kokkos(rho_core, "pace:rho_core", natom); + MemKK::realloc_kokkos(dF_drho_core, "pace:dF_drho_core", natom); + + MemKK::realloc_kokkos(dB_flatten, "pace:dB_flatten", natom, idx_ms_combs_max, basis_set->rankmax); + + //B-projections + MemKK::realloc_kokkos(projections, "pace:projections", natom, total_num_functions_max); // per-atom B-projections + MemKK::realloc_kokkos(d_gamma, "pace:gamma", natom); // per-atom gamma + } + + if (((int)ylm.extent(0) < natom) || ((int)ylm.extent(1) < maxneigh)) { + + // radial functions + MemKK::realloc_kokkos(fr, "pace:fr", natom, maxneigh, nradmax, lmax + 1); + MemKK::realloc_kokkos(dfr, "pace:dfr", natom, maxneigh, nradmax, lmax + 1); + MemKK::realloc_kokkos(gr, "pace:gr", natom, maxneigh, nradbase); + MemKK::realloc_kokkos(dgr, "pace:dgr", natom, maxneigh, nradbase); + const int max_num_functions = MAX(nradbase, nradmax*(lmax + 1)); + MemKK::realloc_kokkos(d_values, "pace:d_values", natom, maxneigh, max_num_functions); + MemKK::realloc_kokkos(d_derivatives, "pace:d_derivatives", natom, maxneigh, max_num_functions); + + // hard-core repulsion + MemKK::realloc_kokkos(cr, "pace:cr", natom, maxneigh); + MemKK::realloc_kokkos(dcr, "pace:dcr", natom, maxneigh); + + // spherical harmonics + MemKK::realloc_kokkos(plm, "pace:plm", natom, maxneigh, (lmax + 1) * (lmax + 1)); + MemKK::realloc_kokkos(dplm, "pace:dplm", natom, maxneigh, (lmax + 1) * (lmax + 1)); + MemKK::realloc_kokkos(ylm, "pace:ylm", natom, maxneigh, (lmax + 1) * (lmax + 1)); + MemKK::realloc_kokkos(dylm, "pace:dylm", natom, maxneigh, (lmax + 1) * (lmax + 1)); + + // short neigh list + MemKK::realloc_kokkos(d_ncount, "pace:ncount", natom); + MemKK::realloc_kokkos(d_mu, "pace:mu", natom, maxneigh); + MemKK::realloc_kokkos(d_rhats, "pace:rhats", natom, maxneigh); + MemKK::realloc_kokkos(d_rnorms, "pace:rnorms", natom, maxneigh); + MemKK::realloc_kokkos(d_nearest, "pace:nearest", natom, maxneigh); + + MemKK::realloc_kokkos(f_ij, "pace:f_ij", natom, maxneigh); + } +} + +/* ---------------------------------------------------------------------- */ + +template +void PairPACEExtrapolationKokkos::copy_pertype() +{ + auto basis_set = aceimpl->basis_set; + + MemKK::realloc_kokkos(d_rho_core_cutoff, "pace:rho_core_cutoff", nelements); + MemKK::realloc_kokkos(d_drho_core_cutoff, "pace:drho_core_cutoff", nelements); + MemKK::realloc_kokkos(d_E0vals, "pace:E0vals", nelements); + MemKK::realloc_kokkos(d_ndensity, "pace:ndensity", nelements); + MemKK::realloc_kokkos(d_npoti, "pace:npoti", nelements); + + auto h_rho_core_cutoff = Kokkos::create_mirror_view(d_rho_core_cutoff); + auto h_drho_core_cutoff = Kokkos::create_mirror_view(d_drho_core_cutoff); + auto h_E0vals = Kokkos::create_mirror_view(d_E0vals); + auto h_ndensity = Kokkos::create_mirror_view(d_ndensity); + auto h_npoti = Kokkos::create_mirror_view(d_npoti); + + for (int n = 0; n < nelements; n++) { + h_rho_core_cutoff[n] = basis_set->map_embedding_specifications.at(n).rho_core_cutoff; + h_drho_core_cutoff[n] = basis_set->map_embedding_specifications.at(n).drho_core_cutoff; + + h_E0vals(n) = basis_set->E0vals(n); + + h_ndensity(n) = basis_set->map_embedding_specifications.at(n).ndensity; + + string npoti = basis_set->map_embedding_specifications.at(n).npoti; + if (npoti == "FinnisSinclair") + h_npoti(n) = FS; + else if (npoti == "FinnisSinclairShiftedScaled") + h_npoti(n) = FS_SHIFTEDSCALED; + } + + Kokkos::deep_copy(d_rho_core_cutoff, h_rho_core_cutoff); + Kokkos::deep_copy(d_drho_core_cutoff, h_drho_core_cutoff); + Kokkos::deep_copy(d_E0vals, h_E0vals); + Kokkos::deep_copy(d_ndensity, h_ndensity); + Kokkos::deep_copy(d_npoti, h_npoti); + + MemKK::realloc_kokkos(d_wpre, "pace:wpre", nelements, basis_set->ndensitymax); + MemKK::realloc_kokkos(d_mexp, "pace:mexp", nelements, basis_set->ndensitymax); + + auto h_wpre = Kokkos::create_mirror_view(d_wpre); + auto h_mexp = Kokkos::create_mirror_view(d_mexp); + + for (int n = 0; n < nelements; n++) { + const int ndensity = basis_set->map_embedding_specifications.at(n).ndensity; + for (int p = 0; p < ndensity; p++) { + h_wpre(n, p) = basis_set->map_embedding_specifications.at(n).FS_parameters.at(p * 2 + 0); + h_mexp(n, p) = basis_set->map_embedding_specifications.at(n).FS_parameters.at(p * 2 + 1); + } + } + + Kokkos::deep_copy(d_wpre, h_wpre); + Kokkos::deep_copy(d_mexp, h_mexp); +} + +/* ---------------------------------------------------------------------- */ + +template +void PairPACEExtrapolationKokkos::copy_splines() +{ + auto basis_set = aceimpl->basis_set; + + if (k_splines_gk.d_view.data()) { + for (int i = 0; i < nelements; i++) { + for (int j = 0; j < nelements; j++) { + k_splines_gk.h_view(i, j).deallocate(); + k_splines_rnl.h_view(i, j).deallocate(); + k_splines_hc.h_view(i, j).deallocate(); + } + } + } + + k_splines_gk = Kokkos::DualView("pace:splines_gk", nelements, nelements); + k_splines_rnl = Kokkos::DualView("pace:splines_rnl", nelements, nelements); + k_splines_hc = Kokkos::DualView("pace:splines_hc", nelements, nelements); + + ACERadialFunctions* radial_functions = dynamic_cast(basis_set->radial_functions); + + for (int i = 0; i < nelements; i++) { + for (int j = 0; j < nelements; j++) { + k_splines_gk.h_view(i, j) = radial_functions->splines_gk(i, j); + k_splines_rnl.h_view(i, j) = radial_functions->splines_rnl(i, j); + k_splines_hc.h_view(i, j) = radial_functions->splines_hc(i, j); + } + } + + k_splines_gk.modify_host(); + k_splines_rnl.modify_host(); + k_splines_hc.modify_host(); + + k_splines_gk.sync_device(); + k_splines_rnl.sync_device(); + k_splines_hc.sync_device(); +} + +/* ---------------------------------------------------------------------- */ + +template +void PairPACEExtrapolationKokkos::copy_tilde() +{ + auto basis_set = aceimpl->basis_set; + auto b_evaluator = aceimpl->ace; + + // flatten loops, get per-element count and max + + idx_ms_combs_max = 0; + total_num_functions_max = 0; + + MemKK::realloc_kokkos(d_idx_ms_combs_count, "pace:idx_ms_combs_count", nelements); + MemKK::realloc_kokkos(d_total_basis_size, "pace:total_basis_size", nelements); + auto h_idx_ms_combs_count = Kokkos::create_mirror_view(d_idx_ms_combs_count); + auto h_total_basis_size = Kokkos::create_mirror_view(d_total_basis_size); + + for (int mu = 0; mu < nelements; mu++) { + int idx_ms_combs = 0; + const int total_basis_size_rank1 = basis_set->total_basis_size_rank1[mu]; + const int total_basis_size = basis_set->total_basis_size[mu]; + + ACEBBasisFunction *basis = basis_set->basis[mu]; + + // rank=1 + for (int func_rank1_ind = 0; func_rank1_ind < total_basis_size_rank1; ++func_rank1_ind) + idx_ms_combs++; + + // rank > 1 + for (int func_ind = 0; func_ind < total_basis_size; ++func_ind) { + ACEBBasisFunction *func = &basis[func_ind]; + + // loop over {ms} combinations in sum + for (int ms_ind = 0; ms_ind < func->num_ms_combs; ++ms_ind) + idx_ms_combs++; + } + h_idx_ms_combs_count(mu) = idx_ms_combs; + idx_ms_combs_max = MAX(idx_ms_combs_max, idx_ms_combs); + total_num_functions_max = MAX(total_num_functions_max, total_basis_size_rank1 + total_basis_size); + h_total_basis_size(mu) = total_basis_size_rank1 + total_basis_size; + } + + Kokkos::deep_copy(d_idx_ms_combs_count, h_idx_ms_combs_count); + Kokkos::deep_copy(d_total_basis_size, h_total_basis_size); + + MemKK::realloc_kokkos(d_rank, "pace:rank", nelements, total_num_functions_max); + MemKK::realloc_kokkos(d_num_ms_combs, "pace:num_ms_combs", nelements, total_num_functions_max); + MemKK::realloc_kokkos(d_func_inds, "pace:func_inds", nelements, idx_ms_combs_max); + MemKK::realloc_kokkos(d_mus, "pace:mus", nelements, total_num_functions_max, basis_set->rankmax); + MemKK::realloc_kokkos(d_ns, "pace:ns", nelements, total_num_functions_max, basis_set->rankmax); + MemKK::realloc_kokkos(d_ls, "pace:ls", nelements, total_num_functions_max, basis_set->rankmax); + MemKK::realloc_kokkos(d_ms_combs, "pace:ms_combs", nelements, idx_ms_combs_max, basis_set->rankmax); + MemKK::realloc_kokkos(d_gen_cgs, "pace:gen_cgs", nelements, idx_ms_combs_max); + MemKK::realloc_kokkos(d_coeffs, "pace:coeffs", nelements, total_num_functions_max, basis_set->ndensitymax); + // active set inverted + t_ace_3d d_ASI_temp; + MemKK::realloc_kokkos(d_ASI_temp, "pace:ASI_temp", nelements, total_num_functions_max, total_num_functions_max); + + auto h_rank = Kokkos::create_mirror_view(d_rank); + auto h_num_ms_combs = Kokkos::create_mirror_view(d_num_ms_combs); + auto h_func_inds = Kokkos::create_mirror_view(d_func_inds); + auto h_mus = Kokkos::create_mirror_view(d_mus); + auto h_ns = Kokkos::create_mirror_view(d_ns); + auto h_ls = Kokkos::create_mirror_view(d_ls); + auto h_ms_combs = Kokkos::create_mirror_view(d_ms_combs); + auto h_gen_cgs = Kokkos::create_mirror_view(d_gen_cgs); + auto h_coeffs = Kokkos::create_mirror_view(d_coeffs); + // asi + auto h_ASI = Kokkos::create_mirror_view(d_ASI_temp); + + // copy values on host + + for (int mu = 0; mu < nelements; mu++) { + const int total_basis_size_rank1 = basis_set->total_basis_size_rank1[mu]; + const int total_basis_size = basis_set->total_basis_size[mu]; + + ACEBBasisFunction *basis_rank1 = basis_set->basis_rank1[mu]; + ACEBBasisFunction *basis = basis_set->basis[mu]; + + const int ndensity = basis_set->map_embedding_specifications.at(mu).ndensity; + + int idx_ms_comb = 0; + + // rank=1 + for (int func_ind = 0; func_ind < total_basis_size_rank1; ++func_ind) { + ACEBBasisFunction *func = &basis_rank1[func_ind]; + h_rank(mu, func_ind) = 1; + h_mus(mu, func_ind, 0) = func->mus[0]; + h_ns(mu, func_ind, 0) = func->ns[0]; + + for (int p = 0; p < ndensity; ++p) + h_coeffs(mu, func_ind, p) = func->coeff[p]; + + h_gen_cgs(mu, idx_ms_comb) = func->gen_cgs[0]; + + h_func_inds(mu, idx_ms_comb) = func_ind; + idx_ms_comb++; + } + + // rank > 1 + for (int func_ind = 0; func_ind < total_basis_size; ++func_ind) { + ACEBBasisFunction *func = &basis[func_ind]; + // TODO: check if func->ctildes are zero, then skip + + const int func_ind_through = total_basis_size_rank1 + func_ind; + + const int rank = h_rank(mu, func_ind_through) = func->rank; + h_num_ms_combs(mu, func_ind_through) = func->num_ms_combs; + for (int t = 0; t < rank; t++) { + h_mus(mu, func_ind_through, t) = func->mus[t]; + h_ns(mu, func_ind_through, t) = func->ns[t]; + h_ls(mu, func_ind_through, t) = func->ls[t]; + } + + for (int p = 0; p < ndensity; ++p) + h_coeffs(mu, func_ind_through, p) = func->coeff[p]; + + + // loop over {ms} combinations in sum + for (int ms_ind = 0; ms_ind < func->num_ms_combs; ++ms_ind) { + auto ms = &func->ms_combs[ms_ind * rank]; // current ms-combination (of length = rank) + for (int t = 0; t < rank; t++) + h_ms_combs(mu, idx_ms_comb, t) = ms[t]; + + + h_gen_cgs(mu, idx_ms_comb) = func->gen_cgs[ms_ind]; + + + h_func_inds(mu, idx_ms_comb) = func_ind_through; + idx_ms_comb++; + } + } + + // ASI + const auto &A_as_inv = b_evaluator->A_active_set_inv.at(mu); + for (int i = 0; i < total_basis_size_rank1 + total_basis_size; i++) + for (int j = 0; j < total_basis_size_rank1 + total_basis_size; j++){ + h_ASI(mu,i,j) = A_as_inv(j,i); // transpose back for better performance on GPU + } + } + + Kokkos::deep_copy(d_rank, h_rank); + Kokkos::deep_copy(d_num_ms_combs, h_num_ms_combs); + Kokkos::deep_copy(d_func_inds, h_func_inds); + Kokkos::deep_copy(d_mus, h_mus); + Kokkos::deep_copy(d_ns, h_ns); + Kokkos::deep_copy(d_ls, h_ls); + Kokkos::deep_copy(d_ms_combs, h_ms_combs); + Kokkos::deep_copy(d_gen_cgs, h_gen_cgs); + Kokkos::deep_copy(d_coeffs, h_coeffs); + Kokkos::deep_copy(d_ASI_temp, h_ASI); + d_ASI = d_ASI_temp; // copy from temopary array to const array +} + +/* ---------------------------------------------------------------------- + init specific to this pair style +------------------------------------------------------------------------- */ + +template +void PairPACEExtrapolationKokkos::init_style() +{ + if (host_flag) { + if (lmp->kokkos->nthreads > 1) + error->all(FLERR,"Pair style pace/extrapolation/kk can currently only run on a single " + "CPU thread"); + + PairPACEExtrapolation::init_style(); + return; + } + + if (atom->tag_enable == 0) error->all(FLERR, "Pair style PACE requires atom IDs"); + if (force->newton_pair == 0) error->all(FLERR, "Pair style PACE requires newton pair on"); + + // neighbor list request for KOKKOS + + neighflag = lmp->kokkos->neighflag; + + auto request = neighbor->add_request(this, NeighConst::REQ_FULL); + request->set_kokkos_host(std::is_same::value && + !std::is_same::value); + request->set_kokkos_device(std::is_same::value); + if (neighflag == FULL) + error->all(FLERR,"Must use half neighbor list style with pair pace/kk"); + + auto basis_set = aceimpl->basis_set; + + nelements = basis_set->nelements; + lmax = basis_set->lmax; + nradmax = basis_set->nradmax; + nradbase = basis_set->nradbase; + + // spherical harmonics + + MemKK::realloc_kokkos(alm, "pace:alm", (lmax + 1) * (lmax + 1)); + MemKK::realloc_kokkos(blm, "pace:blm", (lmax + 1) * (lmax + 1)); + MemKK::realloc_kokkos(cl, "pace:cl", lmax + 1); + MemKK::realloc_kokkos(dl, "pace:dl", lmax + 1); + + pre_compute_harmonics(lmax); + copy_pertype(); + copy_splines(); + copy_tilde(); +} + +/* ---------------------------------------------------------------------- + init for one type pair i,j and corresponding j,i +------------------------------------------------------------------------- */ + +template +double PairPACEExtrapolationKokkos::init_one(int i, int j) +{ + double cutone = PairPACEExtrapolation::init_one(i,j); + + k_scale.h_view(i,j) = k_scale.h_view(j,i) = scale[i][j]; + k_scale.template modify(); + + k_cutsq.h_view(i,j) = k_cutsq.h_view(j,i) = cutone*cutone; + k_cutsq.template modify(); + + return cutone; +} + +/* ---------------------------------------------------------------------- + set coeffs for one or more type pairs +------------------------------------------------------------------------- */ + +template +void PairPACEExtrapolationKokkos::coeff(int narg, char **arg) +{ + PairPACEExtrapolation::coeff(narg,arg); + + auto b_evaluator = aceimpl->ace; + if (!b_evaluator->get_is_linear_extrapolation_grade()) { + error->all(FLERR,"Must use LINEAR ASI with pair pace/extrapolation/kk"); + } + // Set up element lists + + auto h_map = Kokkos::create_mirror_view(d_map); + + for (int i = 1; i <= atom->ntypes; i++) + h_map(i) = map[i]; + + Kokkos::deep_copy(d_map,h_map); +} + +/* ---------------------------------------------------------------------- */ + +template +void PairPACEExtrapolationKokkos::allocate() +{ + PairPACEExtrapolation::allocate(); + + int n = atom->ntypes + 1; + MemKK::realloc_kokkos(d_map, "pace:map", n); + + MemKK::realloc_kokkos(k_cutsq, "pace:cutsq", n, n); + d_cutsq = k_cutsq.template view(); + + MemKK::realloc_kokkos(k_scale, "pace:scale", n, n); + d_scale = k_scale.template view(); +} + +/* ---------------------------------------------------------------------- */ + +template +struct FindMaxNumNeighs { + typedef DeviceType device_type; + NeighListKokkos k_list; + + FindMaxNumNeighs(NeighListKokkos* nl): k_list(*nl) {} + ~FindMaxNumNeighs() {k_list.copymode = 1;} + + KOKKOS_INLINE_FUNCTION + void operator() (const int& ii, int& maxneigh) const { + const int i = k_list.d_ilist[ii]; + const int num_neighs = k_list.d_numneigh[i]; + if (maxneigh < num_neighs) maxneigh = num_neighs; + } +}; + +/* ---------------------------------------------------------------------- */ + +template +void PairPACEExtrapolationKokkos::compute(int eflag_in, int vflag_in) +{ + if (host_flag) { + atomKK->sync(Host,X_MASK|TYPE_MASK); + PairPACEExtrapolation::compute(eflag_in,vflag_in); + atomKK->modified(Host,F_MASK); + return; + } + eflag = eflag_in; + vflag = vflag_in; + + if (neighflag == FULL) no_virial_fdotr_compute = 1; + + ev_init(eflag,vflag,0); + + // reallocate per-atom arrays if necessary + + if (eflag_atom) { + memoryKK->destroy_kokkos(k_eatom,eatom); + memoryKK->create_kokkos(k_eatom,eatom,maxeatom,"pair:eatom"); + d_eatom = k_eatom.view(); + } + if (vflag_atom) { + memoryKK->destroy_kokkos(k_vatom,vatom); + memoryKK->create_kokkos(k_vatom,vatom,maxvatom,"pair:vatom"); + d_vatom = k_vatom.view(); + } + + if (gamma_flag && atom->nlocal > nmax) { + memory->destroy(extrapolation_grade_gamma); + nmax = atom->nlocal; + memory->create(extrapolation_grade_gamma, nmax, "pace/atom:gamma"); + //zeroify array + memset(extrapolation_grade_gamma, 0, nmax * sizeof(*extrapolation_grade_gamma)); + } + + copymode = 1; + if (!force->newton_pair) + error->all(FLERR,"PairPACEExtrapolationKokkos requires 'newton on'"); + + atomKK->sync(execution_space,X_MASK|F_MASK|TYPE_MASK); + x = atomKK->k_x.view(); + f = atomKK->k_f.view(); + type = atomKK->k_type.view(); + k_scale.template sync(); + k_cutsq.template sync(); + + NeighListKokkos* k_list = static_cast*>(list); + d_numneigh = k_list->d_numneigh; + d_neighbors = k_list->d_neighbors; + d_ilist = k_list->d_ilist; + inum = list->inum; + + need_dup = lmp->kokkos->need_dup(); + if (need_dup) { + dup_f = Kokkos::Experimental::create_scatter_view(f); + dup_vatom = Kokkos::Experimental::create_scatter_view(d_vatom); + } else { + ndup_f = Kokkos::Experimental::create_scatter_view(f); + ndup_vatom = Kokkos::Experimental::create_scatter_view(d_vatom); + } + + maxneigh = 0; + Kokkos::parallel_reduce("pace::find_maxneigh", inum, FindMaxNumNeighs(k_list), Kokkos::Max(maxneigh)); + + int vector_length_default = 1; + int team_size_default = 1; + if (!host_flag) + team_size_default = 32; + + chunk_size = MIN(chunksize,inum); // "chunksize" variable is set by user + chunk_offset = 0; + + + grow(chunk_size, maxneigh); + + EV_FLOAT ev; + + while (chunk_offset < inum) { // chunk up loop to prevent running out of memory + + Kokkos::deep_copy(weights, 0.0); + Kokkos::deep_copy(weights_rank1, 0.0); + Kokkos::deep_copy(A, 0.0); + Kokkos::deep_copy(A_rank1, 0.0); + Kokkos::deep_copy(rhos, 0.0); + + Kokkos::deep_copy(projections, 0.0); + Kokkos::deep_copy(d_gamma, 0.0); + + EV_FLOAT ev_tmp; + + if (chunk_size > inum - chunk_offset) + chunk_size = inum - chunk_offset; + + //Neigh + { + int vector_length = vector_length_default; + int team_size = team_size_default; + check_team_size_for(chunk_size,team_size,vector_length); + int scratch_size = scratch_size_helper(team_size * maxneigh); + typename Kokkos::TeamPolicy policy_neigh(chunk_size,team_size,vector_length); + policy_neigh = policy_neigh.set_scratch_size(0, Kokkos::PerTeam(scratch_size)); + Kokkos::parallel_for("ComputeNeigh",policy_neigh,*this); + } + + //ComputeRadial + { + int vector_length = vector_length_default; + int team_size = team_size_default; + check_team_size_for(((chunk_size+team_size-1)/team_size)*maxneigh,team_size,vector_length); + typename Kokkos::TeamPolicy policy_radial(((chunk_size+team_size-1)/team_size)*maxneigh,team_size,vector_length); + Kokkos::parallel_for("ComputeRadial",policy_radial,*this); + } + + //ComputeYlm + { + int vector_length = vector_length_default; + int team_size = 16; + check_team_size_for(((chunk_size+team_size-1)/team_size)*maxneigh,team_size,vector_length); + typename Kokkos::TeamPolicy policy_ylm(((chunk_size+team_size-1)/team_size)*maxneigh,team_size,vector_length); + Kokkos::parallel_for("ComputeYlm",policy_ylm,*this); + } + + //ComputeAi + { + int vector_length = vector_length_default; + int team_size = team_size_default; + check_team_size_for(((chunk_size+team_size-1)/team_size)*maxneigh,team_size,vector_length); + typename Kokkos::TeamPolicy policy_ai(((chunk_size+team_size-1)/team_size)*maxneigh,team_size,vector_length); + Kokkos::parallel_for("ComputeAi",policy_ai,*this); + } + + //ConjugateAi + { + typename Kokkos::RangePolicy policy_conj_ai(0,chunk_size); + Kokkos::parallel_for("ConjugateAi",policy_conj_ai,*this); + } + + //ComputeRho + { + typename Kokkos::RangePolicy policy_rho(0, chunk_size * idx_ms_combs_max); + Kokkos::parallel_for("ComputeRho",policy_rho,*this); + } + + //ComputeFS + { + typename Kokkos::RangePolicy policy_fs(0,chunk_size); + Kokkos::parallel_for("ComputeFS",policy_fs,*this); + } + + //ComputeGamma + if (gamma_flag) { + typename Kokkos::RangePolicy policy_gamma(0,chunk_size); + Kokkos::parallel_for("ComputeGamma",policy_gamma,*this); + } + + //ComputeWeights + { + typename Kokkos::RangePolicy policy_weights(0, chunk_size * idx_ms_combs_max); + Kokkos::parallel_for("ComputeWeights",policy_weights,*this); + } + + //ComputeDerivative + { + int vector_length = vector_length_default; + int team_size = team_size_default; + check_team_size_for(((chunk_size+team_size-1)/team_size)*maxneigh,team_size,vector_length); + typename Kokkos::TeamPolicy policy_derivative(((chunk_size+team_size-1)/team_size)*maxneigh,team_size,vector_length); + Kokkos::parallel_for("ComputeDerivative",policy_derivative,*this); + } + + //ComputeForce + { + if (evflag) { + if (neighflag == HALF) { + typename Kokkos::RangePolicy > policy_force(0,chunk_size); + Kokkos::parallel_reduce(policy_force, *this, ev_tmp); + } else if (neighflag == HALFTHREAD) { + typename Kokkos::RangePolicy > policy_force(0,chunk_size); + Kokkos::parallel_reduce("ComputeForce",policy_force, *this, ev_tmp); + } + } else { + if (neighflag == HALF) { + typename Kokkos::RangePolicy > policy_force(0,chunk_size); + Kokkos::parallel_for(policy_force, *this); + } else if (neighflag == HALFTHREAD) { + typename Kokkos::RangePolicy > policy_force(0,chunk_size); + Kokkos::parallel_for("ComputeForce",policy_force, *this); + } + } + } + ev += ev_tmp; + + //if gamma_flag - copy current d_gamma to extrapolation_grade_gamma + if (gamma_flag){ + h_gamma = Kokkos::create_mirror_view(d_gamma); + Kokkos:deep_copy(h_gamma, d_gamma); + memcpy(extrapolation_grade_gamma+chunk_offset, (void *) h_gamma.data(), sizeof(double)*chunk_size); + } + + chunk_offset += chunk_size; + } // end while + + if (need_dup) + Kokkos::Experimental::contribute(f, dup_f); + + if (eflag_global) eng_vdwl += ev.evdwl; + if (vflag_global) { + virial[0] += ev.v[0]; + virial[1] += ev.v[1]; + virial[2] += ev.v[2]; + virial[3] += ev.v[3]; + virial[4] += ev.v[4]; + virial[5] += ev.v[5]; + } + + if (vflag_fdotr) pair_virial_fdotr_compute(this); + + if (eflag_atom) { + k_eatom.template modify(); + k_eatom.template sync(); + } + + if (vflag_atom) { + if (need_dup) + Kokkos::Experimental::contribute(d_vatom, dup_vatom); + k_vatom.template modify(); + k_vatom.template sync(); + } + + atomKK->modified(execution_space,F_MASK); + + copymode = 0; + + // free duplicated memory + if (need_dup) { + dup_f = decltype(dup_f)(); + dup_vatom = decltype(dup_vatom)(); + } +} + +/* ---------------------------------------------------------------------- */ + +template +KOKKOS_INLINE_FUNCTION +void PairPACEExtrapolationKokkos::operator() (TagPairPACEComputeNeigh,const typename Kokkos::TeamPolicy::member_type& team) const +{ + const int ii = team.league_rank(); + const int i = d_ilist[ii + chunk_offset]; + const int itype = type[i]; + const X_FLOAT xtmp = x(i,0); + const X_FLOAT ytmp = x(i,1); + const X_FLOAT ztmp = x(i,2); + const int jnum = d_numneigh[i]; + + // get a pointer to scratch memory + // This is used to cache whether or not an atom is within the cutoff + // If it is, inside is assigned to 1, otherwise -1 + const int team_rank = team.team_rank(); + const int scratch_shift = team_rank * maxneigh; // offset into pointer for entire team + int* inside = (int*)team.team_shmem().get_shmem(team.team_size() * maxneigh * sizeof(int), 0) + scratch_shift; + + // loop over list of all neighbors within force cutoff + // distsq[] = distance sq to each + // rlist[] = distance vector to each + // nearest[] = atom indices of neighbors + + int ncount = 0; + Kokkos::parallel_reduce(Kokkos::TeamThreadRange(team,jnum), + [&] (const int jj, int& count) { + int j = d_neighbors(i,jj); + j &= NEIGHMASK; + + const int jtype = type(j); + + const F_FLOAT delx = xtmp - x(j,0); + const F_FLOAT dely = ytmp - x(j,1); + const F_FLOAT delz = ztmp - x(j,2); + const F_FLOAT rsq = delx*delx + dely*dely + delz*delz; + + inside[jj] = -1; + if (rsq < d_cutsq(itype,jtype)) { + inside[jj] = 1; + count++; + } + },ncount); + + d_ncount(ii) = ncount; + + Kokkos::parallel_scan(Kokkos::TeamThreadRange(team,jnum), + [&] (const int jj, int& offset, bool final) { + + if (inside[jj] < 0) return; + + if (final) { + int j = d_neighbors(i,jj); + j &= NEIGHMASK; + const F_FLOAT delx = xtmp - x(j,0); + const F_FLOAT dely = ytmp - x(j,1); + const F_FLOAT delz = ztmp - x(j,2); + const F_FLOAT rsq = delx*delx + dely*dely + delz*delz; + const F_FLOAT r = sqrt(rsq); + const F_FLOAT rinv = 1.0/r; + const int mu_j = d_map(type(j)); + d_mu(ii,offset) = mu_j; + d_rnorms(ii,offset) = r; + d_rhats(ii,offset,0) = -delx*rinv; + d_rhats(ii,offset,1) = -dely*rinv; + d_rhats(ii,offset,2) = -delz*rinv; + d_nearest(ii,offset) = j; + } + offset++; + }); +} + +/* ---------------------------------------------------------------------- */ + +template +KOKKOS_INLINE_FUNCTION +void PairPACEExtrapolationKokkos::operator() (TagPairPACEComputeRadial, const typename Kokkos::TeamPolicy::member_type& team) const +{ + // Extract the atom number + int ii = team.team_rank() + team.team_size() * (team.league_rank() % + ((chunk_size+team.team_size()-1)/team.team_size())); + if (ii >= chunk_size) return; + const int i = d_ilist[ii + chunk_offset]; + + // Extract the neighbor number + const int jj = team.league_rank() / ((chunk_size+team.team_size()-1)/team.team_size()); + const int ncount = d_ncount(ii); + if (jj >= ncount) return; + + const double r_norm = d_rnorms(ii, jj); + const int mu_i = d_map(type(i)); + const int mu_j = d_mu(ii, jj); + + evaluate_splines(ii, jj, r_norm, nradbase, nradmax, mu_i, mu_j); +} + +/* ---------------------------------------------------------------------- */ + +template +KOKKOS_INLINE_FUNCTION +void PairPACEExtrapolationKokkos::operator() (TagPairPACEComputeYlm, const typename Kokkos::TeamPolicy::member_type& team) const +{ + // Extract the atom number + int ii = team.team_rank() + team.team_size() * (team.league_rank() % + ((chunk_size+team.team_size()-1)/team.team_size())); + if (ii >= chunk_size) return; + + // Extract the neighbor number + const int jj = team.league_rank() / ((chunk_size+team.team_size()-1)/team.team_size()); + const int ncount = d_ncount(ii); + if (jj >= ncount) return; + + const double xn = d_rhats(ii, jj, 0); + const double yn = d_rhats(ii, jj, 1); + const double zn = d_rhats(ii, jj, 2); + compute_ylm(ii,jj,xn,yn,zn,lmax); +} + +/* ---------------------------------------------------------------------- */ + +template +KOKKOS_INLINE_FUNCTION +void PairPACEExtrapolationKokkos::operator() (TagPairPACEComputeAi, const typename Kokkos::TeamPolicy::member_type& team) const +{ + // Extract the atom number + int ii = team.team_rank() + team.team_size() * (team.league_rank() % + ((chunk_size+team.team_size()-1)/team.team_size())); + if (ii >= chunk_size) return; + + // Extract the neighbor number + const int jj = team.league_rank() / ((chunk_size+team.team_size()-1)/team.team_size()); + const int ncount = d_ncount(ii); + if (jj >= ncount) return; + + const int mu_j = d_mu(ii, jj); + + // rank = 1 + for (int n = 0; n < nradbase; n++) + Kokkos::atomic_add(&A_rank1(ii, mu_j, n), gr(ii, jj, n) * Y00); + + // rank > 1 + for (int n = 0; n < nradmax; n++) { + for (int l = 0; l <= lmax; l++) { + for (int m = 0; m <= l; m++) { + const int idx = l * (l + 1) + m; // (l, m) + Kokkos::atomic_add(&A(ii, mu_j, n, idx).re, fr(ii, jj, n, l) * ylm(ii, jj, idx).re); + Kokkos::atomic_add(&A(ii, mu_j, n, idx).im, fr(ii, jj, n, l) * ylm(ii, jj, idx).im); + } + } + } + + // hard-core repulsion + Kokkos::atomic_add(&rho_core(ii), cr(ii, jj)); +} + +/* ---------------------------------------------------------------------- */ + +template +KOKKOS_INLINE_FUNCTION +void PairPACEExtrapolationKokkos::operator() (TagPairPACEConjugateAi, const int& ii) const +{ + //complex conjugate A's (for NEGATIVE (-m) terms) + // for rank > 1 + for (int mu_j = 0; mu_j < nelements; mu_j++) { + for (int n = 0; n < nradmax; n++) { + for (int l = 0; l <= lmax; l++) { + //fill in -m part in the outer loop using the same m <-> -m symmetry as for Ylm + for (int m = 1; m <= l; m++) { + const int idx = l * (l + 1) + m; // (l, m) + const int idxm = l * (l + 1) - m; // (l, -m) + const int factor = m % 2 == 0 ? 1 : -1; + A(ii, mu_j, n, idxm) = A(ii, mu_j, n, idx).conj() * (double)factor; + } + } + } + } +} + +/* ---------------------------------------------------------------------- */ + +template +KOKKOS_INLINE_FUNCTION +void PairPACEExtrapolationKokkos::operator() (TagPairPACEComputeRho, const int& iter) const +{ + const int idx_ms_comb = iter / chunk_size; + const int ii = iter % chunk_size; + + const int i = d_ilist[ii + chunk_offset]; + const int mu_i = d_map(type(i)); + + if (idx_ms_comb >= d_idx_ms_combs_count(mu_i)) return; + + const int ndensity = d_ndensity(mu_i); + + const int func_ind = d_func_inds(mu_i, idx_ms_comb); + const int rank = d_rank(mu_i, func_ind); + const int r = rank - 1; + + // Basis functions B with iterative product and density rho(p) calculation + if (rank == 1) { + const int mu = d_mus(mu_i, func_ind, 0); + const int n = d_ns(mu_i, func_ind, 0); + double A_cur = A_rank1(ii, mu, n - 1); + for (int p = 0; p < ndensity; ++p) { + //for rank=1 (r=0) only 1 ms-combination exists (ms_ind=0), so index of func.ctildes is 0..ndensity-1 + Kokkos::atomic_add(&rhos(ii, p), d_coeffs(mu_i, func_ind, p) * d_gen_cgs(mu_i, idx_ms_comb) * A_cur); + } + + + //gamma_i + if (gamma_flag) + Kokkos::atomic_add(&projections(ii, func_ind), d_gen_cgs(mu_i, idx_ms_comb) * A_cur); + + } else { // rank > 1 + // loop over {ms} combinations in sum + + // loop over m, collect B = product of A with given ms + A_forward_prod(ii, idx_ms_comb, 0) = complex::one(); + + // fill forward A-product triangle + for (int t = 0; t < rank; t++) { + //TODO: optimize ns[t]-1 -> ns[t] during functions construction + const int mu = d_mus(mu_i, func_ind, t); + const int n = d_ns(mu_i, func_ind, t); + const int l = d_ls(mu_i, func_ind, t); + const int m = d_ms_combs(mu_i, idx_ms_comb, t); // current ms-combination (of length = rank) + const int idx = l * (l + 1) + m; // (l, m) + A_list(ii, idx_ms_comb, t) = A(ii, mu, n - 1, idx); + A_forward_prod(ii, idx_ms_comb, t + 1) = A_forward_prod(ii, idx_ms_comb, t) * A_list(ii, idx_ms_comb, t); + } + + complex A_backward_prod = complex::one(); + + // fill backward A-product triangle + for (int t = r; t >= 1; t--) { + const complex dB = A_forward_prod(ii, idx_ms_comb, t) * A_backward_prod; // dB - product of all A's except t-th + dB_flatten(ii, idx_ms_comb, t) = dB; + + A_backward_prod = A_backward_prod * A_list(ii, idx_ms_comb, t); + } + dB_flatten(ii, idx_ms_comb, 0) = A_forward_prod(ii, idx_ms_comb, 0) * A_backward_prod; + + const complex B = A_forward_prod(ii, idx_ms_comb, rank); + + for (int p = 0; p < ndensity; ++p) { + // real-part only multiplication + Kokkos::atomic_add(&rhos(ii, p), B.real_part_product(d_coeffs(mu_i, func_ind, p) * d_gen_cgs(mu_i, idx_ms_comb))); + } + //gamma_i + if (gamma_flag) + Kokkos::atomic_add(&projections(ii, func_ind), B.real_part_product(d_gen_cgs(mu_i, idx_ms_comb))); + } +} + +/* ---------------------------------------------------------------------- */ + +template +KOKKOS_INLINE_FUNCTION +void PairPACEExtrapolationKokkos::operator() (TagPairPACEComputeFS, const int& ii) const +{ + const int i = d_ilist[ii + chunk_offset]; + const int mu_i = d_map(type(i)); + + const double rho_cut = d_rho_core_cutoff(mu_i); + const double drho_cut = d_drho_core_cutoff(mu_i); + const int ndensity = d_ndensity(mu_i); + + double evdwl, fcut, dfcut; + evdwl = fcut = dfcut = 0.0; + + inner_cutoff(rho_core(ii), rho_cut, drho_cut, fcut, dfcut); + FS_values_and_derivatives(ii, evdwl, mu_i); + + dF_drho_core(ii) = evdwl * dfcut + 1; + for (int p = 0; p < ndensity; ++p) + dF_drho(ii, p) *= fcut; + + + // tally energy contribution + if (eflag) { + double evdwl_cut = evdwl * fcut + rho_core(ii); + // E0 shift + evdwl_cut += d_E0vals(mu_i); + e_atom(ii) = evdwl_cut; + } +} + +/* ---------------------------------------------------------------------- */ + +template +KOKKOS_INLINE_FUNCTION +void PairPACEExtrapolationKokkos::operator() (TagPairPACEComputeGamma, const int& ii) const +{ + const int i = d_ilist[ii + chunk_offset]; + const int mu_i = d_map(type(i)); + const int basis_size = d_total_basis_size(mu_i); + + double gamma_max = 0; + double current_gamma; + for (int j = 0; j gamma_max) + gamma_max = current_gamma; + } + + // tally energy contribution + d_gamma(ii) = gamma_max; +} + +/* ---------------------------------------------------------------------- */ + +template +KOKKOS_INLINE_FUNCTION +void PairPACEExtrapolationKokkos::operator() (TagPairPACEComputeWeights, const int& iter) const +{ + const int idx_ms_comb = iter / chunk_size; + const int ii = iter % chunk_size; + + const int i = d_ilist[ii + chunk_offset]; + const int mu_i = d_map(type(i)); + + if (idx_ms_comb >= d_idx_ms_combs_count(mu_i)) return; + + const int ndensity = d_ndensity(mu_i); + + const int func_ind = d_func_inds(mu_i, idx_ms_comb); + const int rank = d_rank(mu_i, func_ind); + + // Weights and theta calculation + + if (rank == 1) { + const int mu = d_mus(mu_i, func_ind, 0); + const int n = d_ns(mu_i, func_ind, 0); + double theta = 0.0; + for (int p = 0; p < ndensity; ++p) { + // for rank=1 (r=0) only 1 ms-combination exists (ms_ind=0), so index of func.ctildes is 0..ndensity-1 + theta += dF_drho(ii, p) * d_coeffs(mu_i, func_ind, p) * d_gen_cgs(mu_i, idx_ms_comb); + } + Kokkos::atomic_add(&weights_rank1(ii, mu, n - 1), theta); + } else { // rank > 1 + double theta = 0.0; + for (int p = 0; p < ndensity; ++p) + theta += dF_drho(ii, p) * d_coeffs(mu_i, func_ind, p) * d_gen_cgs(mu_i, idx_ms_comb); + + theta *= 0.5; // 0.5 factor due to possible double counting ??? + for (int t = 0; t < rank; ++t) { + const int m_t = d_ms_combs(mu_i, idx_ms_comb, t); + const int factor = (m_t % 2 == 0 ? 1 : -1); + const complex dB = dB_flatten(ii, idx_ms_comb, t); + const int mu_t = d_mus(mu_i, func_ind, t); + const int n_t = d_ns(mu_i, func_ind, t); + const int l_t = d_ls(mu_i, func_ind, t); + const int idx = l_t * (l_t + 1) + m_t; // (l, m) + const complex value = theta * dB; + Kokkos::atomic_add(&(weights(ii, mu_t, n_t - 1, idx).re), value.re); + Kokkos::atomic_add(&(weights(ii, mu_t, n_t - 1, idx).im), value.im); + // update -m_t (that could also be positive), because the basis is half_basis + const int idxm = l_t * (l_t + 1) - m_t; // (l, -m) + const complex valuem = theta * dB.conj() * (double)factor; + Kokkos::atomic_add(&(weights(ii, mu_t, n_t - 1, idxm).re), valuem.re); + Kokkos::atomic_add(&(weights(ii, mu_t, n_t - 1, idxm).im), valuem.im); + } + } +} + +/* ---------------------------------------------------------------------- */ +template +KOKKOS_INLINE_FUNCTION +void PairPACEExtrapolationKokkos::operator() (TagPairPACEComputeDerivative, const typename Kokkos::TeamPolicy::member_type& team) const +{ + // Extract the atom number + int ii = team.team_rank() + team.team_size() * (team.league_rank() % + ((chunk_size+team.team_size()-1)/team.team_size())); + if (ii >= chunk_size) return; + const int i = d_ilist[ii + chunk_offset]; + + // Extract the neighbor number + const int jj = team.league_rank() / ((chunk_size+team.team_size()-1)/team.team_size()); + const int ncount = d_ncount(ii); + if (jj >= ncount) return; + + const int itype = type(i); + const double scale = d_scale(itype,itype); + + const int mu_j = d_mu(ii, jj); + double r_hat[3]; + r_hat[0] = d_rhats(ii, jj, 0); + r_hat[1] = d_rhats(ii, jj, 1); + r_hat[2] = d_rhats(ii, jj, 2); + const double r = d_rnorms(ii, jj); + const double rinv = 1.0/r; + + double f_ji[3]; + f_ji[0] = f_ji[1] = f_ji[2] = 0; + + // for rank = 1 + for (int n = 0; n < nradbase; ++n) { + if (weights_rank1(ii, mu_j, n) == 0) continue; + double &DG = dgr(ii, jj, n); + double DGR = DG * Y00; + DGR *= weights_rank1(ii, mu_j, n); + f_ji[0] += DGR * r_hat[0]; + f_ji[1] += DGR * r_hat[1]; + f_ji[2] += DGR * r_hat[2]; + } + + // for rank > 1 + for (int n = 0; n < nradmax; n++) { + for (int l = 0; l <= lmax; l++) { + const double R_over_r = fr(ii, jj, n, l) * rinv; + const double DR = dfr(ii, jj, n, l); + + // for m >= 0 + for (int m = 0; m <= l; m++) { + const int idx = l * (l + 1) + m; // (l, m) + complex w = weights(ii, mu_j, n, idx); + if (w.re == 0.0 && w.im == 0.0) continue; + // counting for -m cases if m > 0 + if (m > 0) { + w.re *= 2.0; + w.im *= 2.0; + } + + complex DY[3]; + DY[0] = dylm(ii, jj, idx, 0); + DY[1] = dylm(ii, jj, idx, 1); + DY[2] = dylm(ii, jj, idx, 2); + const complex Y_DR = ylm(ii, jj, idx) * DR; + + complex grad_phi_nlm[3]; + grad_phi_nlm[0] = Y_DR * r_hat[0] + DY[0] * R_over_r; + grad_phi_nlm[1] = Y_DR * r_hat[1] + DY[1] * R_over_r; + grad_phi_nlm[2] = Y_DR * r_hat[2] + DY[2] * R_over_r; + // real-part multiplication only + f_ji[0] += w.real_part_product(grad_phi_nlm[0]); + f_ji[1] += w.real_part_product(grad_phi_nlm[1]); + f_ji[2] += w.real_part_product(grad_phi_nlm[2]); + } + } + } + + // hard-core repulsion + const double fpair = dF_drho_core(ii) * dcr(ii,jj); + f_ij(ii, jj, 0) = scale * f_ji[0] + fpair * r_hat[0]; + f_ij(ii, jj, 1) = scale * f_ji[1] + fpair * r_hat[1]; + f_ij(ii, jj, 2) = scale * f_ji[2] + fpair * r_hat[2]; +} + +/* ---------------------------------------------------------------------- */ + +template +template +KOKKOS_INLINE_FUNCTION +void PairPACEExtrapolationKokkos::operator() (TagPairPACEComputeForce, const int& ii, EV_FLOAT& ev) const +{ + // The f array is duplicated for OpenMP, atomic for CUDA, and neither for Serial + const auto v_f = ScatterViewHelper::value,decltype(dup_f),decltype(ndup_f)>::get(dup_f,ndup_f); + const auto a_f = v_f.template access::value>(); + + const int i = d_ilist[ii + chunk_offset]; + const int itype = type(i); + const double scale = d_scale(itype,itype); + + const int ncount = d_ncount(ii); + + F_FLOAT fitmp[3] = {0.0,0.0,0.0}; + for (int jj = 0; jj < ncount; jj++) { + int j = d_nearest(ii,jj); + + double r_hat[3]; + r_hat[0] = d_rhats(ii, jj, 0); + r_hat[1] = d_rhats(ii, jj, 1); + r_hat[2] = d_rhats(ii, jj, 2); + const double r = d_rnorms(ii, jj); + const double delx = -r_hat[0]*r; + const double dely = -r_hat[1]*r; + const double delz = -r_hat[2]*r; + + const double fpairx = f_ij(ii, jj, 0); + const double fpairy = f_ij(ii, jj, 1); + const double fpairz = f_ij(ii, jj, 2); + + fitmp[0] += fpairx; + fitmp[1] += fpairy; + fitmp[2] += fpairz; + a_f(j,0) -= fpairx; + a_f(j,1) -= fpairy; + a_f(j,2) -= fpairz; + + // tally per-atom virial contribution + if (EVFLAG && vflag_either) + v_tally_xyz(ev, i, j, fpairx, fpairy, fpairz, delx, dely, delz); + } + + a_f(i,0) += fitmp[0]; + a_f(i,1) += fitmp[1]; + a_f(i,2) += fitmp[2]; + + // tally energy contribution + if (EVFLAG && eflag_either) { + const double evdwl = scale*e_atom(ii); + //ev_tally_full(i, 2.0 * evdwl, 0.0, 0.0, 0.0, 0.0, 0.0); + if (eflag_global) ev.evdwl += evdwl; + if (eflag_atom) d_eatom[i] += evdwl; + } +} + +template +template +KOKKOS_INLINE_FUNCTION +void PairPACEExtrapolationKokkos::operator() (TagPairPACEComputeForce,const int& ii) const { + EV_FLOAT ev; + this->template operator()(TagPairPACEComputeForce(), ii, ev); +} + +/* ---------------------------------------------------------------------- */ + +template +template +KOKKOS_INLINE_FUNCTION +void PairPACEExtrapolationKokkos::v_tally_xyz(EV_FLOAT &ev, const int &i, const int &j, + const F_FLOAT &fx, const F_FLOAT &fy, const F_FLOAT &fz, + const F_FLOAT &delx, const F_FLOAT &dely, const F_FLOAT &delz) const +{ + // The vatom array is duplicated for OpenMP, atomic for CUDA, and neither for Serial + + auto v_vatom = ScatterViewHelper,decltype(dup_vatom),decltype(ndup_vatom)>::get(dup_vatom,ndup_vatom); + auto a_vatom = v_vatom.template access>(); + + const E_FLOAT v0 = delx*fx; + const E_FLOAT v1 = dely*fy; + const E_FLOAT v2 = delz*fz; + const E_FLOAT v3 = delx*fy; + const E_FLOAT v4 = delx*fz; + const E_FLOAT v5 = dely*fz; + + if (vflag_global) { + ev.v[0] += v0; + ev.v[1] += v1; + ev.v[2] += v2; + ev.v[3] += v3; + ev.v[4] += v4; + ev.v[5] += v5; + } + + if (vflag_atom) { + a_vatom(i,0) += 0.5*v0; + a_vatom(i,1) += 0.5*v1; + a_vatom(i,2) += 0.5*v2; + a_vatom(i,3) += 0.5*v3; + a_vatom(i,4) += 0.5*v4; + a_vatom(i,5) += 0.5*v5; + a_vatom(j,0) += 0.5*v0; + a_vatom(j,1) += 0.5*v1; + a_vatom(j,2) += 0.5*v2; + a_vatom(j,3) += 0.5*v3; + a_vatom(j,4) += 0.5*v4; + a_vatom(j,5) += 0.5*v5; + } +} + +/* ---------------------------------------------------------------------- */ + +template +void PairPACEExtrapolationKokkos::pre_compute_harmonics(int lmax) +{ + auto h_alm = Kokkos::create_mirror_view(alm); + auto h_blm = Kokkos::create_mirror_view(blm); + auto h_cl = Kokkos::create_mirror_view(cl); + auto h_dl = Kokkos::create_mirror_view(dl); + + for (int l = 1; l <= lmax; l++) { + const double lsq = l * l; + const double ld = 2 * l; + const double l1 = (4 * lsq - 1); + const double l2 = lsq - ld + 1; + for (int m = 0; m < l - 1; m++) { + const double msq = m * m; + const double a = sqrt((double(l1)) / (double(lsq - msq))); + const double b = -sqrt((double(l2 - msq)) / (double(4 * l2 - 1))); + const int idx = l * (l + 1) + m; // (l, m) + h_alm(idx) = a; + h_blm(idx) = b; + } + } + + for (int l = 1; l <= lmax; l++) { + h_cl(l) = -sqrt(1.0 + 0.5 / (double(l))); + h_dl(l) = sqrt(double(2 * (l - 1) + 3)); + } + + Kokkos::deep_copy(alm, h_alm); + Kokkos::deep_copy(blm, h_blm); + Kokkos::deep_copy(cl, h_cl); + Kokkos::deep_copy(dl, h_dl); +} + +/* ---------------------------------------------------------------------- */ + +template +KOKKOS_INLINE_FUNCTION +void PairPACEExtrapolationKokkos::compute_barplm(int ii, int jj, double rz, int lmax) const +{ + // requires -1 <= rz <= 1 , NO CHECKING IS PERFORMED !!!!!!!!! + // prefactors include 1/sqrt(2) factor compared to reference + + // l=0, m=0 + // plm(ii, jj, 0, 0) = Y00/sq1o4pi; //= sq1o4pi; + plm(ii, jj, 0) = Y00; //= 1; + dplm(ii, jj, 0) = 0.0; + + if (lmax > 0) { + + // l=1, m=0 + plm(ii, jj, 2) = Y00 * sq3 * rz; + dplm(ii, jj, 2) = Y00 * sq3; + + // l=1, m=1 + plm(ii, jj, 3) = -sq3o2 * Y00; + dplm(ii, jj, 3) = 0.0; + + // loop l = 2, lmax + for (int l = 2; l <= lmax; l++) { + for (int m = 0; m < l - 1; m++) { + const int idx = l * (l + 1) + m; // (l, m) + const int idx1 = (l - 1) * l + m; // (l - 1, m) + const int idx2 = (l - 2) * (l - 1) + m; // (l - 2, m) + plm(ii, jj, idx) = alm(idx) * (rz * plm(ii, jj, idx1) + blm(idx) * plm(ii, jj, idx2)); + dplm(ii, jj, idx) = alm(idx) * (plm(ii, jj, idx1) + rz * dplm(ii, jj, idx1) + blm(idx) * dplm(ii, jj, idx2)); + } + const int idx = l * (l + 1) + l; // (l, l) + const int idx1 = l * (l + 1) + l - 1; // (l, l - 1) + const int idx2 = (l - 1) * l + l - 1; // (l - 1, l - 1) + const double t = dl(l) * plm(ii, jj, idx2); + plm(ii, jj, idx1) = t * rz; + dplm(ii, jj, idx1) = t; + plm(ii, jj, idx) = cl(l) * plm(ii, jj, idx2); + dplm(ii, jj, idx) = 0.0; + } + } +} + +/* ---------------------------------------------------------------------- */ + +template +KOKKOS_INLINE_FUNCTION +void PairPACEExtrapolationKokkos::compute_ylm(int ii, int jj, double rx, double ry, double rz, int lmax) const +{ + // requires rx^2 + ry^2 + rz^2 = 1 , NO CHECKING IS PERFORMED !!!!!!!!! + + complex phase; + complex phasem, mphasem1; + complex dyx, dyy, dyz; + complex rdy; + + phase.re = rx; + phase.im = ry; + + // compute barplm + compute_barplm(ii, jj, rz, lmax); + + // m = 0 + for (int l = 0; l <= lmax; l++) { + const int idx = l * (l + 1); + + ylm(ii, jj, idx).re = plm(ii, jj, idx); + ylm(ii, jj, idx).im = 0.0; + + dyz.re = dplm(ii, jj, idx); + rdy.re = dyz.re * rz; + + dylm(ii, jj, idx, 0).re = -rdy.re * rx; + dylm(ii, jj, idx, 0).im = 0.0; + dylm(ii, jj, idx, 1).re = -rdy.re * ry; + dylm(ii, jj, idx, 1).im = 0.0; + dylm(ii, jj, idx, 2).re = dyz.re - rdy.re * rz; + dylm(ii, jj, idx, 2).im = 0; + } + // m = 1 + for (int l = 1; l <= lmax; l++) { + const int idx = l * (l + 1) + 1; + + ylm(ii, jj, idx) = phase * plm(ii, jj, idx); + + dyx.re = plm(ii, jj, idx); + dyx.im = 0.0; + dyy.re = 0.0; + dyy.im = plm(ii, jj, idx); + dyz.re = phase.re * dplm(ii, jj, idx); + dyz.im = phase.im * dplm(ii, jj, idx); + + rdy.re = rx * dyx.re + +rz * dyz.re; + rdy.im = ry * dyy.im + rz * dyz.im; + + dylm(ii, jj, idx, 0).re = dyx.re - rdy.re * rx; + dylm(ii, jj, idx, 0).im = -rdy.im * rx; + dylm(ii, jj, idx, 1).re = -rdy.re * ry; + dylm(ii, jj, idx, 1).im = dyy.im - rdy.im * ry; + dylm(ii, jj, idx, 2).re = dyz.re - rdy.re * rz; + dylm(ii, jj, idx, 2).im = dyz.im - rdy.im * rz; + } + + // m > 1 + phasem = phase; + for (int m = 2; m <= lmax; m++) { + + mphasem1.re = phasem.re * double(m); + mphasem1.im = phasem.im * double(m); + phasem = phasem * phase; + + for (int l = m; l <= lmax; l++) { + const int idx = l * (l + 1) + m; + + ylm(ii, jj, idx).re = phasem.re * plm(ii, jj, idx); + ylm(ii, jj, idx).im = phasem.im * plm(ii, jj, idx); + + dyx = mphasem1 * plm(ii, jj, idx); + dyy.re = -dyx.im; + dyy.im = dyx.re; + dyz = phasem * dplm(ii, jj, idx); + + rdy.re = rx * dyx.re + ry * dyy.re + rz * dyz.re; + rdy.im = rx * dyx.im + ry * dyy.im + rz * dyz.im; + + dylm(ii, jj, idx, 0).re = dyx.re - rdy.re * rx; + dylm(ii, jj, idx, 0).im = dyx.im - rdy.im * rx; + dylm(ii, jj, idx, 1).re = dyy.re - rdy.re * ry; + dylm(ii, jj, idx, 1).im = dyy.im - rdy.im * ry; + dylm(ii, jj, idx, 2).re = dyz.re - rdy.re * rz; + dylm(ii, jj, idx, 2).im = dyz.im - rdy.im * rz; + } + } +} + +/* ---------------------------------------------------------------------- */ + +template +KOKKOS_INLINE_FUNCTION +void PairPACEExtrapolationKokkos::cutoff_func_poly(const double r, const double r_in, const double delta_in, double &fc, double &dfc) const +{ + if (r <= r_in-delta_in) { + fc = 1; + dfc = 0; + } else if (r >= r_in ) { + fc = 0; + dfc = 0; + } else { + double x = 1 - 2 * (1 + (r - r_in) / delta_in); + fc = 0.5 + 7.5 / 2. * (x / 4. - pow(x, 3) / 6. + pow(x, 5) / 20.); + dfc = -7.5 / delta_in * (0.25 - x * x / 2.0 + pow(x, 4) / 4.); + } +} + +/* ---------------------------------------------------------------------- */ + +template +KOKKOS_INLINE_FUNCTION +void PairPACEExtrapolationKokkos::Fexp(const double x, const double m, double &F, double &DF) const +{ + const double w = 1.e6; + const double eps = 1e-10; + + const double lambda = pow(1.0 / w, m - 1.0); + if (abs(x) > eps) { + double g; + const double a = abs(x); + const double am = pow(a, m); + const double w3x3 = pow(w * a, 3); //// use cube + const double sign_factor = (signbit(x) ? -1 : 1); + if (w3x3 > 30.0) + g = 0.0; + else + g = exp(-w3x3); + + const double omg = 1.0 - g; + F = sign_factor * (omg * am + lambda * g * a); + const double dg = -3.0 * w * w * w * a * a * g; + DF = m * pow(a, m - 1.0) * omg - am * dg + lambda * dg * a + lambda * g; + } else { + F = lambda * x; + DF = lambda; + } +} + +/* ---------------------------------------------------------------------- */ + +template +KOKKOS_INLINE_FUNCTION +void PairPACEExtrapolationKokkos::FexpShiftedScaled(const double rho, const double mexp, double &F, double &DF) const +{ + const double eps = 1e-10; + + if (abs(mexp - 1.0) < eps) { + F = rho; + DF = 1; + } else { + const double a = abs(rho); + const double exprho = exp(-a); + const double nx = 1. / mexp; + const double xoff = pow(nx, (nx / (1.0 - nx))) * exprho; + const double yoff = pow(nx, (1 / (1.0 - nx))) * exprho; + const double sign_factor = (signbit(rho) ? -1 : 1); + F = sign_factor * (pow(xoff + a, mexp) - yoff); + DF = yoff + mexp * (-xoff + 1.0) * pow(xoff + a, mexp - 1.); + } +} + +/* ---------------------------------------------------------------------- */ + +template +KOKKOS_INLINE_FUNCTION +void PairPACEExtrapolationKokkos::inner_cutoff(const double rho_core, const double rho_cut, const double drho_cut, + double &fcut, double &dfcut) const +{ + double rho_low = rho_cut - drho_cut; + if (rho_core >= rho_cut) { + fcut = 0; + dfcut = 0; + } else if (rho_core <= rho_low) { + fcut = 1; + dfcut = 0; + } else { + cutoff_func_poly(rho_core, rho_cut, drho_cut, fcut, dfcut); + } +} + +/* ---------------------------------------------------------------------- */ + +template +KOKKOS_INLINE_FUNCTION +void PairPACEExtrapolationKokkos::FS_values_and_derivatives(const int ii, double &evdwl, const int mu_i) const +{ + double F, DF = 0; + int npoti = d_npoti(mu_i); + int ndensity = d_ndensity(mu_i); + for (int p = 0; p < ndensity; p++) { + const double wpre = d_wpre(mu_i, p); + const double mexp = d_mexp(mu_i, p); + + if (npoti == FS) + Fexp(rhos(ii, p), mexp, F, DF); + else if (npoti == FS_SHIFTEDSCALED) + FexpShiftedScaled(rhos(ii, p), mexp, F, DF); + + evdwl += F * wpre; // * weight (wpre) + dF_drho(ii, p) = DF * wpre; // * weight (wpre) + } +} + +/* ---------------------------------------------------------------------- */ + +template +KOKKOS_INLINE_FUNCTION +void PairPACEExtrapolationKokkos::evaluate_splines(const int ii, const int jj, double r, + int /*nradbase_c*/, int /*nradial_c*/, + int mu_i, int mu_j) const +{ + auto &spline_gk = k_splines_gk.template view()(mu_i, mu_j); + auto &spline_rnl = k_splines_rnl.template view()(mu_i, mu_j); + auto &spline_hc = k_splines_hc.template view()(mu_i, mu_j); + + spline_gk.calcSplines(ii, jj, r, gr, dgr); + + spline_rnl.calcSplines(ii, jj, r, d_values, d_derivatives); + for (int kk = 0; kk < (int)fr.extent(2); kk++) { + for (int ll = 0; ll < (int)fr.extent(3); ll++) { + const int flatten = kk*fr.extent(3) + ll; + fr(ii, jj, kk, ll) = d_values(ii, jj, flatten); + dfr(ii, jj, kk, ll) = d_derivatives(ii, jj, flatten); + } + } + + spline_hc.calcSplines(ii, jj, r, d_values, d_derivatives); + cr(ii, jj) = d_values(ii, jj, 0); + dcr(ii, jj) = d_derivatives(ii, jj, 0); +} + +/* ---------------------------------------------------------------------- */ +template +void PairPACEExtrapolationKokkos::SplineInterpolatorKokkos::operator=(const SplineInterpolator &spline) { + cutoff = spline.cutoff; + deltaSplineBins = spline.deltaSplineBins; + ntot = spline.ntot; + nlut = spline.nlut; + invrscalelookup = spline.invrscalelookup; + rscalelookup = spline.rscalelookup; + num_of_functions = spline.num_of_functions; + + lookupTable = t_ace_3d4("lookupTable", ntot+1, num_of_functions); + auto h_lookupTable = Kokkos::create_mirror_view(lookupTable); + for (int i = 0; i < ntot+1; i++) + for (int j = 0; j < num_of_functions; j++) + for (int k = 0; k < 4; k++) + h_lookupTable(i, j, k) = spline.lookupTable(i, j, k); + Kokkos::deep_copy(lookupTable, h_lookupTable); +} +/* ---------------------------------------------------------------------- */ +template +KOKKOS_INLINE_FUNCTION +void PairPACEExtrapolationKokkos::SplineInterpolatorKokkos::calcSplines(const int ii, const int jj, const double r, const t_ace_3d &d_values, const t_ace_3d &d_derivatives) const +{ + double wl, wl2, wl3, w2l1, w3l2; + double c[4]; + double x = r * rscalelookup; + int nl = static_cast(floor(x)); + + if (nl <= 0) + Kokkos::abort("Encountered very small distance. Stopping."); + + if (nl < nlut) { + wl = x - double(nl); + wl2 = wl * wl; + wl3 = wl2 * wl; + w2l1 = 2.0 * wl; + w3l2 = 3.0 * wl2; + for (int func_id = 0; func_id < num_of_functions; func_id++) { + for (int idx = 0; idx < 4; idx++) + c[idx] = lookupTable(nl, func_id, idx); + d_values(ii, jj, func_id) = c[0] + c[1] * wl + c[2] * wl2 + c[3] * wl3; + d_derivatives(ii, jj, func_id) = (c[1] + c[2] * w2l1 + c[3] * w3l2) * rscalelookup; + } + } else { // fill with zeroes + for (int func_id = 0; func_id < num_of_functions; func_id++) { + d_values(ii, jj, func_id) = 0.0; + d_derivatives(ii, jj, func_id) = 0.0; + } + } +} + +/* ---------------------------------------------------------------------- */ + +template +template +void PairPACEExtrapolationKokkos::check_team_size_for(int inum, int &team_size, int vector_length) { + int team_size_max; + + team_size_max = Kokkos::TeamPolicy(inum,Kokkos::AUTO).team_size_max(*this,Kokkos::ParallelForTag()); + + if (team_size*vector_length > team_size_max) + team_size = team_size_max/vector_length; +} + +/* ---------------------------------------------------------------------- */ + +template +template +void PairPACEExtrapolationKokkos::check_team_size_reduce(int inum, int &team_size, int vector_length) { + int team_size_max; + + team_size_max = Kokkos::TeamPolicy(inum,Kokkos::AUTO).team_size_max(*this,Kokkos::ParallelReduceTag()); + + if (team_size*vector_length > team_size_max) + team_size = team_size_max/vector_length; +} + +template +template +int PairPACEExtrapolationKokkos::scratch_size_helper(int values_per_team) { + typedef Kokkos::View > ScratchViewType; + + return ScratchViewType::shmem_size(values_per_team); +} + +/* ---------------------------------------------------------------------- + memory usage of arrays +------------------------------------------------------------------------- */ + +template +double PairPACEExtrapolationKokkos::memory_usage() +{ + double bytes = 0; + + bytes += MemKK::memory_usage(A); + bytes += MemKK::memory_usage(A_rank1); + bytes += MemKK::memory_usage(A_list); + bytes += MemKK::memory_usage(A_forward_prod); + bytes += MemKK::memory_usage(e_atom); + bytes += MemKK::memory_usage(rhos); + bytes += MemKK::memory_usage(dF_drho); + bytes += MemKK::memory_usage(weights); + bytes += MemKK::memory_usage(weights_rank1); + bytes += MemKK::memory_usage(rho_core); + bytes += MemKK::memory_usage(dF_drho_core); + bytes += MemKK::memory_usage(dB_flatten); + bytes += MemKK::memory_usage(fr); + bytes += MemKK::memory_usage(dfr); + bytes += MemKK::memory_usage(gr); + bytes += MemKK::memory_usage(dgr); + bytes += MemKK::memory_usage(d_values); + bytes += MemKK::memory_usage(d_derivatives); + bytes += MemKK::memory_usage(cr); + bytes += MemKK::memory_usage(dcr); + bytes += MemKK::memory_usage(plm); + bytes += MemKK::memory_usage(dplm); + bytes += MemKK::memory_usage(ylm); + bytes += MemKK::memory_usage(dylm); + bytes += MemKK::memory_usage(d_ncount); + bytes += MemKK::memory_usage(d_mu); + bytes += MemKK::memory_usage(d_rhats); + bytes += MemKK::memory_usage(d_rnorms); + bytes += MemKK::memory_usage(d_nearest); + bytes += MemKK::memory_usage(f_ij); + bytes += MemKK::memory_usage(d_rho_core_cutoff); + bytes += MemKK::memory_usage(d_drho_core_cutoff); + bytes += MemKK::memory_usage(d_E0vals); + bytes += MemKK::memory_usage(d_ndensity); + bytes += MemKK::memory_usage(d_npoti); + bytes += MemKK::memory_usage(d_wpre); + bytes += MemKK::memory_usage(d_mexp); + bytes += MemKK::memory_usage(d_idx_ms_combs_count); + bytes += MemKK::memory_usage(d_rank); + bytes += MemKK::memory_usage(d_num_ms_combs); + bytes += MemKK::memory_usage(d_func_inds); + bytes += MemKK::memory_usage(d_mus); + bytes += MemKK::memory_usage(d_ns); + bytes += MemKK::memory_usage(d_ls); + bytes += MemKK::memory_usage(d_ms_combs); + bytes += MemKK::memory_usage(d_gen_cgs); + bytes += MemKK::memory_usage(d_coeffs); + bytes += MemKK::memory_usage(alm); + bytes += MemKK::memory_usage(blm); + bytes += MemKK::memory_usage(cl); + bytes += MemKK::memory_usage(dl); + bytes += MemKK::memory_usage(d_total_basis_size); + bytes += MemKK::memory_usage(d_ASI); + bytes += MemKK::memory_usage(projections); + bytes += MemKK::memory_usage(d_gamma); + + if (k_splines_gk.h_view.data()) { + for (int i = 0; i < nelements; i++) { + for (int j = 0; j < nelements; j++) { + bytes += k_splines_gk.h_view(i, j).memory_usage(); + bytes += k_splines_rnl.h_view(i, j).memory_usage(); + bytes += k_splines_hc.h_view(i, j).memory_usage(); + } + } + } + + return bytes; +} + +/* ---------------------------------------------------------------------- + extract method for extracting value of scale variable + ---------------------------------------------------------------------- */ + +template +void *PairPACEExtrapolationKokkos::extract(const char *str, int &dim) +{ + //check if str=="gamma_flag" then compute extrapolation grades on this iteration + dim = 0; + if (strcmp(str, "gamma_flag") == 0) return (void *) &gamma_flag; + + dim = 2; + if (strcmp(str, "scale") == 0) return (void *) scale; + return nullptr; +} + +/* ---------------------------------------------------------------------- + peratom requests from FixPair + return ptr to requested data + also return ncol = # of quantites per atom + 0 = per-atom vector + 1 or more = # of columns in per-atom array + return NULL if str is not recognized +---------------------------------------------------------------------- */ + +template +void *PairPACEExtrapolationKokkos::extract_peratom(const char *str, int &ncol) +{ + if (strcmp(str, "gamma") == 0) { + ncol = 0; + return (void *) extrapolation_grade_gamma; + } + + return nullptr; +} + +/* ---------------------------------------------------------------------- */ + +namespace LAMMPS_NS { +template class PairPACEExtrapolationKokkos; +#ifdef LMP_KOKKOS_GPU +template class PairPACEExtrapolationKokkos; +#endif +} + diff --git a/src/KOKKOS/pair_pace_extrapolation_kokkos.h b/src/KOKKOS/pair_pace_extrapolation_kokkos.h new file mode 100644 index 0000000000..a65841f8f6 --- /dev/null +++ b/src/KOKKOS/pair_pace_extrapolation_kokkos.h @@ -0,0 +1,339 @@ +/* -*- c++ -*- ---------------------------------------------------------- + LAMMPS - Large-scale Atomic/Molecular Massively Parallel Simulator + https://www.lammps.org/, Sandia National Laboratories + LAMMPS development team: developers@lammps.org + + Copyright (2003) Sandia Corporation. Under the terms of Contract + DE-AC04-94AL85000 with Sandia Corporation, the U.S. Government retains + certain rights in this software. This software is distributed under + the GNU General Public License. + + See the README file in the top-level LAMMPS directory. +------------------------------------------------------------------------- */ + +#ifdef PAIR_CLASS +// clang-format off +PairStyle(pace/extrapolation/kk,PairPACEExtrapolationKokkos); +PairStyle(pace/extrapolation/kk/device,PairPACEExtrapolationKokkos); +PairStyle(pace/extrapolation/kk/host,PairPACEExtrapolationKokkos); +// clang-format on +#else + +// clang-format off +#ifndef LMP_PAIR_PACE_EXTRAPOLATION_KOKKOS_H +#define LMP_PAIR_PACE_EXTRAPOLATION_KOKKOS_H + +#include "pair_pace_extrapolation.h" +#include "kokkos_type.h" +#include "pair_kokkos.h" + +class SplineInterpolator; + +namespace LAMMPS_NS { + +template +class PairPACEExtrapolationKokkos : public PairPACEExtrapolation { + public: + struct TagPairPACEComputeNeigh{}; + struct TagPairPACEComputeRadial{}; + struct TagPairPACEComputeYlm{}; + struct TagPairPACEComputeAi{}; + struct TagPairPACEConjugateAi{}; + struct TagPairPACEComputeRho{}; + struct TagPairPACEComputeFS{}; + struct TagPairPACEComputeGamma{}; + struct TagPairPACEComputeWeights{}; + struct TagPairPACEComputeDerivative{}; + + template + struct TagPairPACEComputeForce{}; + + typedef DeviceType device_type; + typedef ArrayTypes AT; + typedef EV_FLOAT value_type; + using complex = SNAComplex; + + PairPACEExtrapolationKokkos(class LAMMPS *); + ~PairPACEExtrapolationKokkos() override; + + void compute(int, int) override; + void coeff(int, char **) override; + void init_style() override; + double init_one(int, int) override; + + KOKKOS_INLINE_FUNCTION + void operator() (TagPairPACEComputeNeigh,const typename Kokkos::TeamPolicy::member_type& team) const; + + KOKKOS_INLINE_FUNCTION + void operator() (TagPairPACEComputeRadial,const typename Kokkos::TeamPolicy::member_type& team) const; + + KOKKOS_INLINE_FUNCTION + void operator() (TagPairPACEComputeYlm,const typename Kokkos::TeamPolicy::member_type& team) const; + + KOKKOS_INLINE_FUNCTION + void operator() (TagPairPACEComputeAi,const typename Kokkos::TeamPolicy::member_type& team) const; + + KOKKOS_INLINE_FUNCTION + void operator() (TagPairPACEConjugateAi,const int& ii) const; + + KOKKOS_INLINE_FUNCTION + void operator() (TagPairPACEComputeRho,const int& iter) const; + + KOKKOS_INLINE_FUNCTION + void operator() (TagPairPACEComputeFS,const int& ii) const; + + KOKKOS_INLINE_FUNCTION + void operator() (TagPairPACEComputeGamma, const int& ii) const; + + KOKKOS_INLINE_FUNCTION + void operator() (TagPairPACEComputeWeights,const int& iter) const; + + KOKKOS_INLINE_FUNCTION + void operator() (TagPairPACEComputeDerivative,const typename Kokkos::TeamPolicy::member_type& team) const; + + template + KOKKOS_INLINE_FUNCTION + void operator() (TagPairPACEComputeForce,const int& ii) const; + + template + KOKKOS_INLINE_FUNCTION + void operator() (TagPairPACEComputeForce,const int& ii, EV_FLOAT&) const; + + + void *extract(const char *str, int &dim); + void *extract_peratom(const char *str, int &ncol); + + protected: + int inum, maxneigh, chunk_size, chunk_offset, idx_ms_combs_max, total_num_functions_max; + int host_flag; + int gamma_flag; + + int eflag, vflag; + + int neighflag, max_ndensity; + int nelements, lmax, nradmax, nradbase; + + typename AT::t_neighbors_2d d_neighbors; + typename AT::t_int_1d_randomread d_ilist; + typename AT::t_int_1d_randomread d_numneigh; + + DAT::tdual_efloat_1d k_eatom; + DAT::tdual_virial_array k_vatom; + typename AT::t_efloat_1d d_eatom; + typename AT::t_virial_array d_vatom; + + typename AT::t_x_array_randomread x; + typename AT::t_f_array f; + typename AT::t_int_1d_randomread type; + + typedef Kokkos::DualView tdual_fparams; + tdual_fparams k_cutsq, k_scale; + typedef Kokkos::View t_fparams; + t_fparams d_cutsq, d_scale; + + typename AT::t_int_1d d_map; + + int need_dup; + + using KKDeviceType = typename KKDevice::value; + + template + using DupScatterView = KKScatterView; + + template + using NonDupScatterView = KKScatterView; + + DupScatterView dup_f; + DupScatterView dup_vatom; + + NonDupScatterView ndup_f; + NonDupScatterView ndup_vatom; + + friend void pair_virial_fdotr_compute(PairPACEExtrapolationKokkos*); + + void grow(int, int); + void copy_pertype(); + void copy_splines(); + void copy_tilde(); + void allocate() override; + void precompute_harmonics(); + double memory_usage() override; + + template + KOKKOS_INLINE_FUNCTION + void v_tally_xyz(EV_FLOAT &ev, const int &i, const int &j, + const F_FLOAT &fx, const F_FLOAT &fy, const F_FLOAT &fz, + const F_FLOAT &delx, const F_FLOAT &dely, const F_FLOAT &delz) const; + + KOKKOS_INLINE_FUNCTION + void compute_barplm(int, int, double, int) const; + + KOKKOS_INLINE_FUNCTION + void compute_ylm(int, int, double, double, double, int) const; + + KOKKOS_INLINE_FUNCTION + void cutoff_func_poly(const double, const double, const double, double &, double &) const; + + KOKKOS_INLINE_FUNCTION + void Fexp(const double, const double, double &, double &) const; + + KOKKOS_INLINE_FUNCTION + void FexpShiftedScaled(const double, const double, double &, double &) const; + + KOKKOS_INLINE_FUNCTION + void inner_cutoff(const double, const double, const double, double &, double &) const; + + KOKKOS_INLINE_FUNCTION + void FS_values_and_derivatives(const int, double&, const int) const; + + KOKKOS_INLINE_FUNCTION + void evaluate_splines(const int, const int, double, int, int, int, int) const; + + template + void check_team_size_for(int, int&, int); + + template + void check_team_size_reduce(int, int&, int); + + // Utility routine which wraps computing per-team scratch size requirements for + // ComputeNeigh, ComputeUi, and ComputeFusedDeidrj + template + int scratch_size_helper(int values_per_team); + + typedef Kokkos::View t_ace_1i; + typedef Kokkos::View t_ace_2i; + typedef Kokkos::View t_ace_3i; + typedef Kokkos::View t_ace_4i; + typedef Kokkos::View t_ace_1d; + typedef Kokkos::View t_ace_2d; + typedef Kokkos::View t_ace_2d3; + typedef Kokkos::View t_ace_3d; + typedef Kokkos::View tc_ace_3d; + typedef Kokkos::View t_ace_3d3; + typedef Kokkos::View t_ace_3d4; + typedef Kokkos::View t_ace_4d; + typedef Kokkos::View t_ace_1c; + typedef Kokkos::View t_ace_2c; + typedef Kokkos::View t_ace_3c; + typedef Kokkos::View t_ace_3c3; + typedef Kokkos::View t_ace_4c; + typedef Kokkos::View t_ace_4c3; + + typedef Kokkos::View::HostMirror th_ace_1d; + + t_ace_3d A_rank1; + t_ace_4c A; + + t_ace_3c A_list; + t_ace_3c A_forward_prod; + + t_ace_3d weights_rank1; + t_ace_4c weights; + + t_ace_1d e_atom; + t_ace_2d rhos; + t_ace_2d dF_drho; + + // hard-core repulsion + t_ace_1d rho_core; + t_ace_3c dB_flatten; + t_ace_2d cr; + t_ace_2d dcr; + t_ace_1d dF_drho_core; + + // radial functions + t_ace_4d fr; + t_ace_4d dfr; + t_ace_3d gr; + t_ace_3d dgr; + t_ace_3d d_values; + t_ace_3d d_derivatives; + + // inverted active set + tc_ace_3d d_ASI; + t_ace_2d projections; + t_ace_1d d_gamma; + th_ace_1d h_gamma; + + // Spherical Harmonics + void pre_compute_harmonics(int); + + KOKKOS_INLINE_FUNCTION + void compute_barplm(double rz, int lmaxi); + + KOKKOS_INLINE_FUNCTION + void compute_ylm(double rx, double ry, double rz, int lmaxi); + + t_ace_1d alm; + t_ace_1d blm; + t_ace_1d cl; + t_ace_1d dl; + + t_ace_3d plm; + t_ace_3d dplm; + + t_ace_3c ylm; + t_ace_4c3 dylm; + + // short neigh list + t_ace_1i d_ncount; + t_ace_2d d_mu; + t_ace_2d d_rnorms; + t_ace_3d3 d_rhats; + t_ace_2i d_nearest; + + // per-type + t_ace_1i d_ndensity; + t_ace_1i d_npoti; + t_ace_1d d_rho_core_cutoff; + t_ace_1d d_drho_core_cutoff; + t_ace_1d d_E0vals; + t_ace_2d d_wpre; + t_ace_2d d_mexp; + + // tilde + t_ace_1i d_idx_ms_combs_count; + t_ace_1i d_total_basis_size; + t_ace_2i d_rank; + t_ace_2i d_num_ms_combs; + t_ace_2i d_func_inds; + t_ace_3i d_mus; + t_ace_3i d_ns; + t_ace_3i d_ls; + t_ace_3i d_ms_combs; +// t_ace_3d d_ctildes; + t_ace_2d d_gen_cgs; + t_ace_3d d_coeffs; + + t_ace_3d3 f_ij; + + public: + struct SplineInterpolatorKokkos { + int ntot, nlut, num_of_functions; + double cutoff, deltaSplineBins, invrscalelookup, rscalelookup; + + t_ace_3d4 lookupTable; + + void operator=(const SplineInterpolator &spline); + + void deallocate() { + lookupTable = t_ace_3d4(); + } + + double memory_usage() { + return lookupTable.span() * sizeof(typename decltype(lookupTable)::value_type); + } + + KOKKOS_INLINE_FUNCTION + void calcSplines(const int ii, const int jj, const double r, const t_ace_3d &d_values, const t_ace_3d &d_derivatives) const; + }; + + Kokkos::DualView k_splines_gk; + Kokkos::DualView k_splines_rnl; + Kokkos::DualView k_splines_hc; + +}; +} // namespace LAMMPS_NS + +#endif +#endif diff --git a/src/KOKKOS/pair_pace_kokkos.cpp b/src/KOKKOS/pair_pace_kokkos.cpp index dd5b97fe32..6f1e3feaf8 100644 --- a/src/KOKKOS/pair_pace_kokkos.cpp +++ b/src/KOKKOS/pair_pace_kokkos.cpp @@ -1574,7 +1574,25 @@ void PairPACEKokkos::evaluate_splines(const int ii, const int jj, do } /* ---------------------------------------------------------------------- */ +template +void PairPACEKokkos::SplineInterpolatorKokkos::operator=(const SplineInterpolator &spline) { + cutoff = spline.cutoff; + deltaSplineBins = spline.deltaSplineBins; + ntot = spline.ntot; + nlut = spline.nlut; + invrscalelookup = spline.invrscalelookup; + rscalelookup = spline.rscalelookup; + num_of_functions = spline.num_of_functions; + lookupTable = t_ace_3d4("lookupTable", ntot+1, num_of_functions); + auto h_lookupTable = Kokkos::create_mirror_view(lookupTable); + for (int i = 0; i < ntot+1; i++) + for (int j = 0; j < num_of_functions; j++) + for (int k = 0; k < 4; k++) + h_lookupTable(i, j, k) = spline.lookupTable(i, j, k); + Kokkos::deep_copy(lookupTable, h_lookupTable); +} +/* ---------------------------------------------------------------------- */ template KOKKOS_INLINE_FUNCTION void PairPACEKokkos::SplineInterpolatorKokkos::calcSplines(const int ii, const int jj, const double r, const t_ace_3d &d_values, const t_ace_3d &d_derivatives) const diff --git a/src/KOKKOS/pair_pace_kokkos.h b/src/KOKKOS/pair_pace_kokkos.h index cc2a3cb674..39cfd100f8 100644 --- a/src/KOKKOS/pair_pace_kokkos.h +++ b/src/KOKKOS/pair_pace_kokkos.h @@ -24,10 +24,11 @@ PairStyle(pace/kk/host,PairPACEKokkos); #define LMP_PAIR_PACE_KOKKOS_H #include "pair_pace.h" -#include "ace-evaluator/ace_radial.h" #include "kokkos_type.h" #include "pair_kokkos.h" +class SplineInterpolator; + namespace LAMMPS_NS { template @@ -293,23 +294,7 @@ class PairPACEKokkos : public PairPACE { t_ace_3d4 lookupTable; - void operator=(const SplineInterpolator &spline) { - cutoff = spline.cutoff; - deltaSplineBins = spline.deltaSplineBins; - ntot = spline.ntot; - nlut = spline.nlut; - invrscalelookup = spline.invrscalelookup; - rscalelookup = spline.rscalelookup; - num_of_functions = spline.num_of_functions; - - lookupTable = t_ace_3d4("lookupTable", ntot+1, num_of_functions); - auto h_lookupTable = Kokkos::create_mirror_view(lookupTable); - for (int i = 0; i < ntot+1; i++) - for (int j = 0; j < num_of_functions; j++) - for (int k = 0; k < 4; k++) - h_lookupTable(i, j, k) = spline.lookupTable(i, j, k); - Kokkos::deep_copy(lookupTable, h_lookupTable); - } + void operator=(const SplineInterpolator &spline); void deallocate() { lookupTable = t_ace_3d4(); diff --git a/src/ML-PACE/pair_pace_extrapolation.cpp b/src/ML-PACE/pair_pace_extrapolation.cpp index ec185e75df..8a0116526a 100644 --- a/src/ML-PACE/pair_pace_extrapolation.cpp +++ b/src/ML-PACE/pair_pace_extrapolation.cpp @@ -98,6 +98,8 @@ PairPACEExtrapolation::PairPACEExtrapolation(LAMMPS *lmp) : Pair(lmp) scale = nullptr; flag_compute_extrapolation_grade = 0; extrapolation_grade_gamma = nullptr; + + chunksize = 4096; } /* ---------------------------------------------------------------------- @@ -133,16 +135,12 @@ void PairPACEExtrapolation::compute(int eflag, int vflag) double **x = atom->x; double **f = atom->f; - tagint *tag = atom->tag; int *type = atom->type; // number of atoms in cell int nlocal = atom->nlocal; int newton_pair = force->newton_pair; - // number of atoms including ghost atoms - int nall = nlocal + atom->nghost; - // inum: length of the neighborlists list inum = list->inum; @@ -283,7 +281,20 @@ void PairPACEExtrapolation::allocate() void PairPACEExtrapolation::settings(int narg, char **arg) { - if (narg > 0) error->all(FLERR, "Pair style pace/extrapolation supports no keywords"); +// if (narg > 2) error->all(FLERR, "Pair style pace/extrapolation supports no keywords"); + if (narg > 2) utils::missing_cmd_args(FLERR, "pair_style pace/extrapolation", error); + // ACE potentials are parameterized in metal units + if (strcmp("metal", update->unit_style) != 0) + error->all(FLERR, "ACE potentials require 'metal' units"); + + int iarg = 0; + while (iarg < narg) { + if (strcmp(arg[iarg], "chunksize") == 0) { + chunksize = utils::inumeric(FLERR, arg[iarg + 1], false, lmp); + iarg += 2; + } else + error->all(FLERR, "Unknown pair_style pace keyword: {}", arg[iarg]); + } if (comm->me == 0) utils::logmesg(lmp, "ACE/AL version: {}.{}.{}\n", VERSION_YEAR, VERSION_MONTH, VERSION_DAY); @@ -343,7 +354,6 @@ void PairPACEExtrapolation::coeff(int narg, char **arg) aceimpl->rec_ace->element_type_mapping.init(atom->ntypes + 1); aceimpl->rec_ace->element_type_mapping.fill(-1); //-1 means atom not included into potential - FILE *species_type_file = nullptr; const int n = atom->ntypes; element_names.resize(n); diff --git a/src/ML-PACE/pair_pace_extrapolation.h b/src/ML-PACE/pair_pace_extrapolation.h index c5d9da23db..6f7eeb279e 100644 --- a/src/ML-PACE/pair_pace_extrapolation.h +++ b/src/ML-PACE/pair_pace_extrapolation.h @@ -49,13 +49,15 @@ class PairPACEExtrapolation : public Pair { struct ACEALImpl *aceimpl; int nmax; - void allocate(); + virtual void allocate(); std::vector element_names; // list of elements (used by dump pace/extrapolation) double *extrapolation_grade_gamma; //per-atom gamma value int flag_compute_extrapolation_grade; double **scale; + + int chunksize; }; } // namespace LAMMPS_NS diff --git a/src/REACTION/README b/src/REACTION/README index f5fc929c9d..99a5d604ec 100644 --- a/src/REACTION/README +++ b/src/REACTION/README @@ -13,12 +13,16 @@ crosslinked materials. Any number of competing or reversible reaction pathways can be specified, and reacting sites can be stabilized. Other advanced options currently available include reaction constraints (e.g. angle and Arrhenius constraints), deletion of reaction -byproducts or other small molecules, and chiral-sensitive reactions. +byproducts or other small molecules, creation of new atoms or +molecules bonded to existing atoms, and using LAMMPS variables for +input parameters. The REACTER methodology is detailed in: Gissinger et al., Polymer 128, 211-217 (2017) https://doi.org/10.1016/j.polymer.2017.09.038 + Gissinger et al., Macromolecules 53, 22, 9953-9961 (2020). + https://doi.org/10.1021/acs.macromol.0c02012 + This package was created by Jacob Gissinger -(jacob.r.gissinger@gmail.com), while at the NASA Langley Research -Center. +(jacob.r.gissinger@gmail.com) at the NASA Langley Research Center. diff --git a/src/REACTION/fix_bond_react.cpp b/src/REACTION/fix_bond_react.cpp index 87d83da1ae..edddac1cb8 100644 --- a/src/REACTION/fix_bond_react.cpp +++ b/src/REACTION/fix_bond_react.cpp @@ -1476,9 +1476,6 @@ void FixBondReact::superimpose_algorithm() // this updates topology next step next_reneighbor = update->ntimestep; - // call limit_bond in 'global_mega_glove mode.' oh, and local mode - limit_bond(LOCAL); // add reacting atoms to nve/limit - limit_bond(GLOBAL); update_everything(); // change topology } @@ -2779,80 +2776,6 @@ void FixBondReact::dedup_mega_gloves(int dedup_mode) delete [] dup_list; } -/* ---------------------------------------------------------------------- -let's limit movement of newly bonded atoms -and exclude them from other thermostats via exclude_group -------------------------------------------------------------------------- */ - -void FixBondReact::limit_bond(int limit_bond_mode) -{ - //two types of passes: 1) while superimpose algorithm is iterating (only local atoms) - // 2) once more for global_mega_glove [after de-duplicating rxn instances] - //in second case, only add local atoms to group - //as with update_everything, we can pre-prepare these arrays, then run generic limit_bond code - - //create local, generic variables for onemol->natoms and glove - //to be filled differently on respective passes - - int nlocal = atom->nlocal; - int temp_limit_num = 0; - tagint *temp_limit_glove; - if (limit_bond_mode == LOCAL) { - int max_temp = local_num_mega * (max_natoms + 1); - temp_limit_glove = new tagint[max_temp]; - for (int j = 0; j < local_num_mega; j++) { - rxnID = local_mega_glove[0][j]; - onemol = atom->molecules[unreacted_mol[rxnID]]; - for (int i = 0; i < onemol->natoms; i++) { - temp_limit_glove[temp_limit_num++] = local_mega_glove[i+1][j]; - } - } - - } else if (limit_bond_mode == GLOBAL) { - int max_temp = global_megasize * (max_natoms + 1); - temp_limit_glove = new tagint[max_temp]; - for (int j = 0; j < global_megasize; j++) { - rxnID = global_mega_glove[0][j]; - onemol = atom->molecules[unreacted_mol[rxnID]]; - for (int i = 0; i < onemol->natoms; i++) { - if (atom->map(global_mega_glove[i+1][j]) >= 0 && - atom->map(global_mega_glove[i+1][j]) < nlocal) - temp_limit_glove[temp_limit_num++] = global_mega_glove[i+1][j]; - } - } - } - - if (temp_limit_num == 0) { - delete [] temp_limit_glove; - return; - } - - // we must keep our own list of limited atoms - // this will be a new per-atom property! - - int flag,cols; - int index1 = atom->find_custom("limit_tags",flag,cols); - int *i_limit_tags = atom->ivector[index1]; - - int *i_statted_tags; - if (stabilization_flag == 1) { - int index2 = atom->find_custom(statted_id,flag,cols); - i_statted_tags = atom->ivector[index2]; - } - - int index3 = atom->find_custom("react_tags",flag,cols); - int *i_react_tags = atom->ivector[index3]; - - for (int i = 0; i < temp_limit_num; i++) { - // update->ntimestep could be 0. so add 1 throughout - i_limit_tags[atom->map(temp_limit_glove[i])] = update->ntimestep + 1; - if (stabilization_flag == 1) i_statted_tags[atom->map(temp_limit_glove[i])] = 0; - i_react_tags[atom->map(temp_limit_glove[i])] = rxnID; - } - - delete [] temp_limit_glove; -} - /* ---------------------------------------------------------------------- let's unlimit movement of newly bonded atoms after n timesteps. we give them back to the system thermostat @@ -3055,6 +2978,21 @@ void FixBondReact::update_everything() int delta_dihed = 0; int delta_imprp = 0; + // use the following per-atom arrays to keep track of reacting atoms + + int flag,cols; + int index1 = atom->find_custom("limit_tags",flag,cols); + int *i_limit_tags = atom->ivector[index1]; + + int *i_statted_tags; + if (stabilization_flag == 1) { + int index2 = atom->find_custom(statted_id,flag,cols); + i_statted_tags = atom->ivector[index2]; + } + + int index3 = atom->find_custom("react_tags",flag,cols); + int *i_react_tags = atom->ivector[index3]; + // pass through twice // redefining 'update_num_mega' and 'update_mega_glove' each time // first pass: when glove is all local atoms @@ -3175,18 +3113,25 @@ void FixBondReact::update_everything() } // update charges and types of landlocked atoms + // also keep track of 'stabilization' groups here for (int i = 0; i < update_num_mega; i++) { rxnID = update_mega_glove[0][i]; twomol = atom->molecules[reacted_mol[rxnID]]; for (int j = 0; j < twomol->natoms; j++) { int jj = equivalences[j][1][rxnID]-1; - if (atom->map(update_mega_glove[jj+1][i]) >= 0 && - atom->map(update_mega_glove[jj+1][i]) < nlocal) { + int ilocal = atom->map(update_mega_glove[jj+1][i]); + if (ilocal >= 0 && ilocal < nlocal) { + + // update->ntimestep could be 0. so add 1 throughout + i_limit_tags[ilocal] = update->ntimestep + 1; + if (stabilization_flag == 1) i_statted_tags[ilocal] = 0; + i_react_tags[ilocal] = rxnID; + if (landlocked_atoms[j][rxnID] == 1) - type[atom->map(update_mega_glove[jj+1][i])] = twomol->type[j]; + type[ilocal] = twomol->type[j]; if (twomol->qflag && atom->q_flag && custom_charges[jj][rxnID] == 1) { double *q = atom->q; - q[atom->map(update_mega_glove[jj+1][i])] = twomol->q[j]+charge_rescale_addend; + q[ilocal] = twomol->q[j]+charge_rescale_addend; } } } @@ -3913,25 +3858,6 @@ int FixBondReact::insert_atoms(tagint **my_mega_glove, int iupdate) v[n][1] = v[n][1]/vnorm*vtnorm; v[n][2] = v[n][2]/vnorm*vtnorm; modify->create_attribute(n); - - // initialize group statuses - // why aren't these more global... - int flag,cols; - int index1 = atom->find_custom("limit_tags",flag,cols); - int *i_limit_tags = atom->ivector[index1]; - - int *i_statted_tags; - if (stabilization_flag == 1) { - int index2 = atom->find_custom(statted_id,flag,cols); - i_statted_tags = atom->ivector[index2]; - } - - int index3 = atom->find_custom("react_tags",flag,cols); - int *i_react_tags = atom->ivector[index3]; - - i_limit_tags[n] = update->ntimestep + 1; - if (stabilization_flag == 1) i_statted_tags[n] = 0; - i_react_tags[n] = rxnID; } // globally update mega_glove and equivalences MPI_Allreduce(MPI_IN_PLACE,&root,1,MPI_INT,MPI_SUM,world); diff --git a/src/REACTION/fix_bond_react.h b/src/REACTION/fix_bond_react.h index 4751bc4eef..b434699ec7 100644 --- a/src/REACTION/fix_bond_react.h +++ b/src/REACTION/fix_bond_react.h @@ -209,7 +209,6 @@ class FixBondReact : public Fix { void update_everything(); int insert_atoms(tagint **, int); void unlimit_bond(); // removes atoms from stabilization, and other post-reaction every-step operations - void limit_bond(int); void dedup_mega_gloves(int); //dedup global mega_glove void write_restart(FILE *) override; void restart(char *buf) override; diff --git a/src/angle_write.cpp b/src/angle_write.cpp new file mode 100644 index 0000000000..e7c95be3cf --- /dev/null +++ b/src/angle_write.cpp @@ -0,0 +1,227 @@ +/* ---------------------------------------------------------------------- + LAMMPS - Large-scale Atomic/Molecular Massively Parallel Simulator + https://www.lammps.org/, Sandia National Laboratories + LAMMPS development team: developers@lammps.org + + Copyright (2003) Sandia Corporation. Under the terms of Contract + DE-AC04-94AL85000 with Sandia Corporation, the U.S. Government retains + certain rights in this software. This software is distributed under + the GNU General Public License. + + See the README file in the top-level LAMMPS directory. +------------------------------------------------------------------------- */ + +/* ---------------------------------------------------------------------- + Contributing authors: Axel Kohlmeyer (Temple U) +------------------------------------------------------------------------- */ + +#include "angle_write.h" + +#include "angle.h" +#include "atom.h" +#include "atom_vec.h" +#include "comm.h" +#include "domain.h" +#include "error.h" +#include "force.h" +#include "input.h" +#include "lammps.h" +#include "math_const.h" +#include "update.h" + +#include +using namespace LAMMPS_NS; +using MathConst::DEG2RAD; +using MathConst::RAD2DEG; + +static constexpr double epsilon = 6.5e-6; +#define MAXLINE 1024 +/* ---------------------------------------------------------------------- */ + +void AngleWrite::command(int narg, char **arg) +{ + // sanity checks + + if (domain->box_exist == 0) + error->all(FLERR, "Angle_write command before simulation box is defined"); + if (atom->avec->angles_allow == 0) + error->all(FLERR, "Angle_write command when no angles allowed"); + auto angle = force->angle; + if (angle == nullptr) error->all(FLERR, "Angle_write command before an angle_style is defined"); + if (angle && (force->angle->writedata == 0)) + error->all(FLERR, "Angle style must support writing coeffs to data file for angle_write"); + + if (angle && (utils::strmatch(force->angle_style, "^class2"))) + error->all(FLERR, "Angle_write command is not compatible with angle style {}", + force->angle_style); + + // parse arguments + + if (narg != 4) error->all(FLERR, "Illegal angle_write command"); + + int atype = utils::inumeric(FLERR, arg[0], false, lmp); + if ((atype <= 0) || (atype > atom->nangletypes)) + error->all(FLERR, "Invalid angle type {} in angle_write command", atype); + + int n = utils::inumeric(FLERR, arg[1], false, lmp); + std::string table_file = arg[2]; + std::string keyword = arg[3]; + + // make sure system is initialized before calling any functions + + lmp->init(); + + double theta0 = angle->equilibrium_angle(atype) * RAD2DEG; + + // write out all angle_coeff settings to file. use function from write_data. + // open table file in append mode if it already exists + // add line with DATE: and UNITS: tag when creating new file + // otherwise make certain that units are consistent + // print header in format used by angle_style table + + FILE *fp = nullptr; + std::string coeffs_file = table_file + ".tmp.coeffs"; + if (comm->me == 0) { + + fp = fopen(coeffs_file.c_str(), "w"); + force->angle->write_data(fp); + fclose(fp); + + // units sanity check: + // - if this is the first time we write to this potential file, + // write out a line with "DATE:" and "UNITS:" tags + // - if the file already exists, print a message about appending + // while printing the date and check that units are consistent. + if (platform::file_is_readable(table_file)) { + std::string units = utils::get_potential_units(table_file, "table"); + if (!units.empty() && (units != update->unit_style)) { + error->one(FLERR, "Trying to append to a table file with UNITS: {} while units are {}", + units, update->unit_style); + } + std::string date = utils::get_potential_date(table_file, "table"); + utils::logmesg(lmp, "Appending to table file {} with DATE: {}\n", table_file, date); + fp = fopen(table_file.c_str(), "a"); + } else { + utils::logmesg(lmp, "Creating table file {} with DATE: {}\n", table_file, + utils::current_date()); + fp = fopen(table_file.c_str(), "w"); + if (fp) + fmt::print(fp, "# DATE: {} UNITS: {} Created by angle_write\n", utils::current_date(), + update->unit_style); + } + if (fp == nullptr) + error->one(FLERR, "Cannot open angle_write file {}: {}", table_file, utils::getsyserror()); + } + + // split communicator so that we can run a new LAMMPS class instance only on comm->me == 0 + + MPI_Comm singlecomm; + int color = (comm->me == 0) ? 1 : MPI_UNDEFINED; + int key = comm->me; + MPI_Comm_split(world, color, key, &singlecomm); + + if (comm->me == 0) { + // set up new LAMMPS instance with dummy system to evaluate angle potential + const char *args[] = {"AngleWrite", "-nocite", "-echo", "none", + "-log", "none", "-screen", "none"}; + char **argv = (char **) args; + int argc = sizeof(args) / sizeof(char *); + LAMMPS *writer = new LAMMPS(argc, argv, singlecomm); + + // create dummy system replicating angle style settings + writer->input->one(fmt::format("units {}", update->unit_style)); + writer->input->one("atom_style angle"); + writer->input->one("atom_modify map array"); + writer->input->one("boundary f f f"); + writer->input->one("region box block -2 2 -2 2 -1 1"); + writer->input->one(fmt::format("create_box {} box angle/types {} " + "extra/angle/per/atom 1 " + "extra/special/per/atom 4", + atom->ntypes, atom->nangletypes)); + writer->input->one("create_atoms 1 single 0.0 0.0 0.0"); + writer->input->one("create_atoms 1 single 1.0 0.0 0.0"); + writer->input->one("create_atoms 1 single -1.0 0.0 0.0"); + writer->input->one(fmt::format("create_bonds single/angle {} 2 1 3", atype)); + + writer->input->one("pair_style zero 10.0"); + writer->input->one("pair_coeff * *"); + writer->input->one("mass * 1.0"); + writer->input->one(fmt::format("angle_style {}", force->angle_style)); + FILE *coeffs; + char line[MAXLINE]; + coeffs = fopen(coeffs_file.c_str(), "r"); + for (int i = 0; i < atom->nangletypes; ++i) { + fgets(line, MAXLINE, coeffs); + writer->input->one(fmt::format("angle_coeff {}", line)); + } + fclose(coeffs); + platform::unlink(coeffs_file); + + // initialize system + + writer->init(); + + // move third atom to reproduce angles + + double theta, phi, phi1, phi2, f; + angle = writer->force->angle; + int i1, i2, i3; + i1 = writer->atom->map(1); + i2 = writer->atom->map(2); + i3 = writer->atom->map(3); + auto atom3 = writer->atom->x[i3]; + + // evaluate energy and force at each of N distances + + fmt::print(fp, "# Angle potential {} for angle type {}: i,theta,energy,force\n", + force->angle_style, atype); + fmt::print(fp, "\n{}\nN {} EQ {:.15g}\n\n", keyword, n, theta0); + +#define GET_ENERGY(myphi, mytheta) \ + theta = mytheta; \ + atom3[0] = cos(theta * DEG2RAD); \ + atom3[1] = sin(theta * DEG2RAD); \ + myphi = angle->single(atype, i2, i1, i3) + + const double dtheta = 180.0 / static_cast(n - 1); + + // get force for divergent 0 degree angle from interpolation to the right + + GET_ENERGY(phi, 0.0); + GET_ENERGY(phi1, epsilon); + GET_ENERGY(phi2, 2.0 * epsilon); + + f = (1.5 * phi - 2.0 * phi1 + 0.5 * phi2) / epsilon; + if (!std::isfinite(f)) f = 0.0; + if (!std::isfinite(phi)) phi = 0.0; + fprintf(fp, "%8d %- 22.15g %- 22.15g %- 22.15g\n", 1, 0.0, phi, f); + + for (int i = 1; i < n - 1; i++) { + GET_ENERGY(phi1, dtheta * static_cast(i) - epsilon); + GET_ENERGY(phi2, dtheta * static_cast(i) + epsilon); + GET_ENERGY(phi, dtheta * static_cast(i)); + + if (!std::isfinite(phi)) phi = 0.0; + + // get force from numerical differentiation + f = -0.5 * (phi2 - phi1) / epsilon; + if (!std::isfinite(f)) f = 0.0; + fprintf(fp, "%8d %- 22.15g %- 22.15g %- 22.15g\n", i + 1, theta, phi, f); + } + + // get force for divergent 180 degree angle from interpolation to the left + GET_ENERGY(phi, 180.0); + GET_ENERGY(phi1, 180.0 - epsilon); + GET_ENERGY(phi2, 180.0 - 2.0 * epsilon); + + f = (2.0 * phi1 - 1.5 * phi - 0.5 * phi2) / epsilon; + if (!std::isfinite(f)) f = 0.0; + if (!std::isfinite(phi)) phi = 0.0; + fprintf(fp, "%8d %- 22.15g %- 22.15g %- 22.15g\n", 1, 180.0, phi, f); + + // clean up + delete writer; + fclose(fp); + } + MPI_Comm_free(&singlecomm); +} diff --git a/src/angle_write.h b/src/angle_write.h new file mode 100644 index 0000000000..5c56cd8efc --- /dev/null +++ b/src/angle_write.h @@ -0,0 +1,34 @@ +/* -*- c++ -*- ---------------------------------------------------------- + LAMMPS - Large-scale Atomic/Molecular Massively Parallel Simulator + https://www.lammps.org/, Sandia National Laboratories + LAMMPS development team: developers@lammps.org + + Copyright (2003) Sandia Corporation. Under the terms of Contract + DE-AC04-94AL85000 with Sandia Corporation, the U.S. Government retains + certain rights in this software. This software is distributed under + the GNU General Public License. + + See the README file in the top-level LAMMPS directory. +------------------------------------------------------------------------- */ + +#ifdef COMMAND_CLASS +// clang-format off +CommandStyle(angle_write,AngleWrite); +// clang-format on +#else + +#ifndef LMP_ANGLE_WRITE_H +#define LMP_ANGLE_WRITE_H + +#include "command.h" + +namespace LAMMPS_NS { + +class AngleWrite : public Command { + public: + AngleWrite(class LAMMPS *lmp) : Command(lmp){}; + void command(int, char **) override; +}; +} // namespace LAMMPS_NS +#endif +#endif diff --git a/src/dihedral_write.cpp b/src/dihedral_write.cpp new file mode 100644 index 0000000000..eedcde0eb8 --- /dev/null +++ b/src/dihedral_write.cpp @@ -0,0 +1,206 @@ +/* ---------------------------------------------------------------------- + LAMMPS - Large-scale Atomic/Molecular Massively Parallel Simulator + https://www.lammps.org/, Sandia National Laboratories + LAMMPS development team: developers@lammps.org + + Copyright (2003) Sandia Corporation. Under the terms of Contract + DE-AC04-94AL85000 with Sandia Corporation, the U.S. Government retains + certain rights in this software. This software is distributed under + the GNU General Public License. + + See the README file in the top-level LAMMPS directory. +------------------------------------------------------------------------- */ + +/* ---------------------------------------------------------------------- + Contributing authors: Axel Kohlmeyer (Temple U) +------------------------------------------------------------------------- */ + +#include "dihedral_write.h" + +#include "atom.h" +#include "atom_vec.h" +#include "comm.h" +#include "dihedral.h" +#include "domain.h" +#include "error.h" +#include "force.h" +#include "input.h" +#include "lammps.h" +#include "math_const.h" +#include "update.h" + +#include +using namespace LAMMPS_NS; +using MathConst::DEG2RAD; +using MathConst::RAD2DEG; + +static constexpr double epsilon = 6.5e-6; +#define MAXLINE 1024 +/* ---------------------------------------------------------------------- */ + +void DihedralWrite::command(int narg, char **arg) +{ + // sanity checks + + if (domain->box_exist == 0) + error->all(FLERR, "Dihedral_write command before simulation box is defined"); + if (atom->avec->dihedrals_allow == 0) + error->all(FLERR, "Dihedral_write command when no dihedrals allowed"); + auto dihedral = force->dihedral; + if (dihedral == nullptr) + error->all(FLERR, "Dihedral_write command before an dihedral_style is defined"); + if (dihedral && (force->dihedral->writedata == 0)) + error->all(FLERR, "Dihedral style must support writing coeffs to data file for dihedral_write"); + + if (dihedral && + (utils::strmatch(force->dihedral_style, "^charmm") || + utils::strmatch(force->dihedral_style, "^class2"))) + error->all(FLERR, "Dihedral_write command is not compatible with dihedral style {}", + force->dihedral_style); + + // parse arguments + + if (narg != 4) error->all(FLERR, "Illegal dihedral_write command"); + + int dtype = utils::inumeric(FLERR, arg[0], false, lmp); + if ((dtype <= 0) || (dtype > atom->ndihedraltypes)) + error->all(FLERR, "Invalid dihedral type {} in dihedral_write command", dtype); + + int n = utils::inumeric(FLERR, arg[1], false, lmp); + std::string table_file = arg[2]; + std::string keyword = arg[3]; + + // make sure system is initialized before calling any functions + + lmp->init(); + + // write out all dihedral_coeff settings to file. use function from write_data. + // open table file in append mode if it already exists + // add line with DATE: and UNITS: tag when creating new file + // otherwise make certain that units are consistent + // print header in format used by dihedral_style table + + FILE *fp = nullptr; + std::string coeffs_file = table_file + ".tmp.coeffs"; + if (comm->me == 0) { + + fp = fopen(coeffs_file.c_str(), "w"); + force->dihedral->write_data(fp); + fclose(fp); + + // units sanity check: + // - if this is the first time we write to this potential file, + // write out a line with "DATE:" and "UNITS:" tags + // - if the file already exists, print a message about appending + // while printing the date and check that units are consistent. + if (platform::file_is_readable(table_file)) { + std::string units = utils::get_potential_units(table_file, "table"); + if (!units.empty() && (units != update->unit_style)) { + error->one(FLERR, "Trying to append to a table file with UNITS: {} while units are {}", + units, update->unit_style); + } + std::string date = utils::get_potential_date(table_file, "table"); + utils::logmesg(lmp, "Appending to table file {} with DATE: {}\n", table_file, date); + fp = fopen(table_file.c_str(), "a"); + } else { + utils::logmesg(lmp, "Creating table file {} with DATE: {}\n", table_file, + utils::current_date()); + fp = fopen(table_file.c_str(), "w"); + if (fp) + fmt::print(fp, "# DATE: {} UNITS: {} Created by dihedral_write\n", utils::current_date(), + update->unit_style); + } + if (fp == nullptr) + error->one(FLERR, "Cannot open dihedral_write file {}: {}", table_file, utils::getsyserror()); + } + + // split communicator so that we can run a new LAMMPS class instance only on comm->me == 0 + + MPI_Comm singlecomm; + int color = (comm->me == 0) ? 1 : MPI_UNDEFINED; + int key = comm->me; + MPI_Comm_split(world, color, key, &singlecomm); + + if (comm->me == 0) { + // set up new LAMMPS instance with dummy system to evaluate dihedral potential + // const char *args[] = {"DihedralWrite", "-nocite", "-echo", "none", + // "-log", "none", "-screen", "none"}; + const char *args[] = {"DihedralWrite", "-nocite", "-echo", "screen", "-log", "none"}; + char **argv = (char **) args; + int argc = sizeof(args) / sizeof(char *); + LAMMPS *writer = new LAMMPS(argc, argv, singlecomm); + + // create dummy system replicating dihedral style settings + writer->input->one(fmt::format("units {}", update->unit_style)); + writer->input->one("atom_style molecular"); + writer->input->one("atom_modify map array"); + writer->input->one("boundary f f f"); + writer->input->one("region box block -2 2 -2 2 -2 2"); + writer->input->one(fmt::format("create_box {} box dihedral/types {} " + "extra/dihedral/per/atom 1 " + "extra/special/per/atom 4", + atom->ntypes, atom->ndihedraltypes)); + writer->input->one("create_atoms 1 single 1.0 0.0 -1.0"); + writer->input->one("create_atoms 1 single 0.0 0.0 -1.0"); + writer->input->one("create_atoms 1 single 0.0 0.0 1.0"); + writer->input->one("create_atoms 1 single 1.0 0.0 1.0"); + writer->input->one(fmt::format("create_bonds single/dihedral {} 1 2 3 4", dtype)); + + writer->input->one("pair_style zero 10.0"); + writer->input->one("pair_coeff * *"); + writer->input->one("mass * 1.0"); + writer->input->one(fmt::format("dihedral_style {}", force->dihedral_style)); + FILE *coeffs; + char line[MAXLINE]; + coeffs = fopen(coeffs_file.c_str(), "r"); + for (int i = 0; i < atom->ndihedraltypes; ++i) { + fgets(line, MAXLINE, coeffs); + writer->input->one(fmt::format("dihedral_coeff {}", line)); + } + fclose(coeffs); + platform::unlink(coeffs_file); + + // must complete a full setup() to initialize system including neighbor and dihedral lists. + + writer->input->one("run 0 post no"); + + // move third atom to reproduce dihedrals + + double theta, phi, phi1, phi2, f; + dihedral = writer->force->dihedral; + auto atom4 = writer->atom->x[writer->atom->map(4)]; + + // evaluate energy and force at each of N distances + + fmt::print(fp, "# Dihedral potential {} for dihedral type {}: i,theta,energy,force\n", + force->dihedral_style, dtype); + fmt::print(fp, "\n{}\nN {} DEGREES\n\n", keyword, n); + +#define GET_ENERGY(myphi, mytheta) \ + theta = mytheta; \ + atom4[0] = cos(theta * DEG2RAD); \ + atom4[1] = sin(theta * DEG2RAD); \ + dihedral->energy = 0.0; \ + dihedral->compute(ENERGY_GLOBAL, 0); \ + myphi = dihedral->energy + + const double dtheta = 360.0 / static_cast(n); + for (int i = 0; i < n; i++) { + GET_ENERGY(phi1, dtheta * static_cast(i) - epsilon); + GET_ENERGY(phi2, dtheta * static_cast(i) + epsilon); + GET_ENERGY(phi, dtheta * static_cast(i)); + + if (!std::isfinite(phi)) phi = 0.0; + + // get force from numerical differentiation + f = -0.5 * (phi2 - phi1) / epsilon; + if (!std::isfinite(f)) f = 0.0; + fprintf(fp, "%8d %- 22.15g %- 22.15g %- 22.15g\n", i + 1, theta, phi, f); + } + + // clean up + delete writer; + fclose(fp); + } + MPI_Comm_free(&singlecomm); +} diff --git a/src/dihedral_write.h b/src/dihedral_write.h new file mode 100644 index 0000000000..b17f8d19da --- /dev/null +++ b/src/dihedral_write.h @@ -0,0 +1,34 @@ +/* -*- c++ -*- ---------------------------------------------------------- + LAMMPS - Large-scale Atomic/Molecular Massively Parallel Simulator + https://www.lammps.org/, Sandia National Laboratories + LAMMPS development team: developers@lammps.org + + Copyright (2003) Sandia Corporation. Under the terms of Contract + DE-AC04-94AL85000 with Sandia Corporation, the U.S. Government retains + certain rights in this software. This software is distributed under + the GNU General Public License. + + See the README file in the top-level LAMMPS directory. +------------------------------------------------------------------------- */ + +#ifdef COMMAND_CLASS +// clang-format off +CommandStyle(dihedral_write,DihedralWrite); +// clang-format on +#else + +#ifndef LMP_DIHEDRAL_WRITE_H +#define LMP_DIHEDRAL_WRITE_H + +#include "command.h" + +namespace LAMMPS_NS { + +class DihedralWrite : public Command { + public: + DihedralWrite(class LAMMPS *lmp) : Command(lmp){}; + void command(int, char **) override; +}; +} // namespace LAMMPS_NS +#endif +#endif diff --git a/src/fix_pair.cpp b/src/fix_pair.cpp index 5e5ccbf810..59f9dbda4a 100644 --- a/src/fix_pair.cpp +++ b/src/fix_pair.cpp @@ -21,6 +21,7 @@ #include "memory.h" #include "pair.h" #include "update.h" +#include "fmt/format.h" using namespace LAMMPS_NS; using namespace FixConst; @@ -36,7 +37,7 @@ FixPair::FixPair(LAMMPS *lmp, int narg, char **arg) : if (nevery < 1) error->all(FLERR,"Illegal fix pair every value: {}", nevery); pairname = utils::strdup(arg[4]); - pstyle = force->pair_match(pairname,1,0); + query_pstyle(lmp); if (pstyle == nullptr) error->all(FLERR,"Pair style {} for fix pair not found", pairname); nfield = (narg-5) / 2; @@ -130,6 +131,28 @@ FixPair::FixPair(LAMMPS *lmp, int narg, char **arg) : lasttime = -1; } +/* ---------------------------------------------------------------------- */ + +void FixPair::query_pstyle(LAMMPS *lmp) { + char *cptr=nullptr; + int nsub = 0; + if ((cptr = strchr(pairname, ':'))) { + *cptr = '\0'; + nsub = utils::inumeric(FLERR,cptr+1,false,lmp); + } + pstyle = nullptr; + if (lmp->suffix_enable) { + if (lmp->suffix) { + pstyle = force->pair_match(fmt::format("{}/{}", pairname, lmp->suffix), 1, nsub); + if (pstyle == nullptr && (lmp->suffix2)) { + pstyle = force->pair_match(fmt::format("{}/{}", pairname, lmp->suffix2), 1, nsub); + } + } + } + if (pstyle == nullptr) pstyle = force->pair_match(pairname, 1, nsub); +} + + /* ---------------------------------------------------------------------- */ FixPair::~FixPair() @@ -171,7 +194,7 @@ void FixPair::init() { // insure pair style still exists - pstyle = force->pair_match(pairname,1,0); + query_pstyle(lmp); if (pstyle == nullptr) error->all(FLERR,"Pair style {} for fix pair not found", pairname); } diff --git a/src/fix_pair.h b/src/fix_pair.h index 765b261ee5..57fbdf8ecb 100644 --- a/src/fix_pair.h +++ b/src/fix_pair.h @@ -56,6 +56,8 @@ class FixPair : public Fix { class Pair *pstyle; double *vector; double **array; + + void query_pstyle(LAMMPS *lmp); }; } // namespace LAMMPS_NS