From c95eb73e8539beeb8581266f07dd894d5d7a528b Mon Sep 17 00:00:00 2001
From: Elliott Sales de Andrade <quantum.analyst@gmail.com>
Date: Thu, 3 May 2018 01:23:27 -0400
Subject: [PATCH 3/4] Unbundle arpack.
Signed-off-by: Elliott Sales de Andrade <quantum.analyst@gmail.com>
---
MD5 | 28 --
src/Makevars.in | 6 +-
src/dgetv0.f | 419 -------------------
src/dlaqrb.f | 521 -----------------------
src/dmout.f | 167 --------
src/dnaitr.f | 840 --------------------------------------
src/dnapps.f | 647 -----------------------------
src/dnaup2.f | 838 -------------------------------------
src/dnaupd.f | 655 -----------------------------
src/dnconv.f | 146 -------
src/dneigh.f | 315 --------------
src/dneupd.f | 1044 -----------------------------------------------
src/dngets.f | 231 -----------
src/dsaitr.f | 854 --------------------------------------
src/dsapps.f | 516 -----------------------
src/dsaup2.f | 853 --------------------------------------
src/dsaupd.f | 653 -----------------------------
src/dsconv.f | 138 -------
src/dseigt.f | 181 --------
src/dsesrt.f | 217 ----------
src/dseupd.f | 905 ----------------------------------------
src/dsgets.f | 220 ----------
src/dsortc.f | 344 ----------------
src/dsortr.f | 218 ----------
src/dstatn.f | 61 ---
src/dstats.f | 47 ---
src/dstqrb.f | 594 ---------------------------
src/dvout.f | 122 ------
src/ivout.f | 120 ------
src/second.f | 35 --
src/wrap.f | 8 +-
31 files changed, 7 insertions(+), 11936 deletions(-)
delete mode 100644 src/dgetv0.f
delete mode 100644 src/dlaqrb.f
delete mode 100644 src/dmout.f
delete mode 100644 src/dnaitr.f
delete mode 100644 src/dnapps.f
delete mode 100644 src/dnaup2.f
delete mode 100644 src/dnaupd.f
delete mode 100644 src/dnconv.f
delete mode 100644 src/dneigh.f
delete mode 100644 src/dneupd.f
delete mode 100644 src/dngets.f
delete mode 100644 src/dsaitr.f
delete mode 100644 src/dsapps.f
delete mode 100644 src/dsaup2.f
delete mode 100644 src/dsaupd.f
delete mode 100644 src/dsconv.f
delete mode 100644 src/dseigt.f
delete mode 100644 src/dsesrt.f
delete mode 100644 src/dseupd.f
delete mode 100644 src/dsgets.f
delete mode 100644 src/dsortc.f
delete mode 100644 src/dsortr.f
delete mode 100644 src/dstatn.f
delete mode 100644 src/dstats.f
delete mode 100644 src/dstqrb.f
delete mode 100644 src/dvout.f
delete mode 100644 src/ivout.f
delete mode 100644 src/second.f
diff --git a/MD5 b/MD5
index bca1ab5..deeb9ad 100644
--- a/MD5
+++ b/MD5
@@ -706,18 +706,7 @@ ed31244ed5ef4ab0c2caa42b1a92dec0 *src/cs/cs_sqr.c
74e3d5634309a7716491939ecd8b993a *src/cs/cs_utsolve.c
ae2b99c6930b9d78a067b9f304e4d021 *src/debug.h
c36fc0d316783ca73c33594df813b191 *src/decomposition.c
-bc623b699b4c2d87ac2c4a0b82002276 *src/dgetv0.f
53aa0b92a01343a9780f33409ff71448 *src/distances.c
-ae7917a56c25a07b9860819bebf32f40 *src/dlaqrb.f
-334cfcb89b71acd8bcf5e8398923f7f5 *src/dmout.f
-0e11f9b76a7e46477224bebd83080f25 *src/dnaitr.f
-7d4f11d47644fbbf52ed09e58e174dc4 *src/dnapps.f
-22de713abf558787ed9c5b33eb4b83d4 *src/dnaup2.f
-13ef3f91e6a93a0fb365d456cbd51d9d *src/dnaupd.f
-8285764ecec3f0da1831503affd69067 *src/dnconv.f
-7e7766bc466e28155a85211734e36426 *src/dneigh.f
-00daa2578ee9f4ade26d3cab1b4076b8 *src/dneupd.f
-238271976008654f1e512760f71943b4 *src/dngets.f
375ff494ab18d30adad217d6c5406a6d *src/dotproduct.c
03a845c6af6e800d15575f831ea2f18e *src/dqueue.c
e2ddc9e8d520337ca4fafc08d4bab6d1 *src/dqueue.pmt
@@ -733,21 +722,6 @@ a77f381105b0246c7a0719c0b669365b *src/drl_layout_3d.cpp
7e4c69a183df51fc7662e2a3f5c6e6be *src/drl_layout_3d.h
4b5e3c6311f4c7a87eac902316f38b95 *src/drl_parse.cpp
14f8e5de9f1b7e850614ccf71c93bff0 *src/drl_parse.h
-ef22d5267a5f3e54a66b5c6fc97e8785 *src/dsaitr.f
-f226039f08b329d7a276b9c920c757b0 *src/dsapps.f
-4ccdc4e43c8b3f590f7ed53783b30cee *src/dsaup2.f
-221f58799c95c17f73a5043d9edb959f *src/dsaupd.f
-573fb11e41307018f2fdb32ce3111be5 *src/dsconv.f
-f976b4529dead76e497c2f35fe067b00 *src/dseigt.f
-0f7c847fa63252f466a7c312a9baa052 *src/dsesrt.f
-6e2dd99b6e2450fa315e9132806eae90 *src/dseupd.f
-604cef634a570edd5e9e1f0e57b85800 *src/dsgets.f
-d37e30b6becbd695f77bb83e86fc8845 *src/dsortc.f
-8baf60e7aaca0c70f8ce165fa60f0eb4 *src/dsortr.f
-d4ead7e7ae03b16c06bc2eee64bc99fd *src/dstatn.f
-40dc3cb9ded24c012fd5810e6175d7f9 *src/dstats.f
-de4792cfaab6cdda8d557902c2310fcc *src/dstqrb.f
-10246dd04cc987d389f1f369f4b1813b *src/dvout.f
d971c3cba371000e3ee5232179b380c3 *src/eigen.c
0accc0fa9659dc8f9f4c741decc84b1b *src/embedding.c
7a18f357ae90d62a9be31318d8e4d152 *src/fast_community.c
@@ -936,7 +910,6 @@ bbf84d35c2016510d97be2b41be84017 *src/infomap_FlowGraph.h
1eb40fbf0a581bddadec6d0faf8c685f *src/init.c
14be091d75db4df0c8261c571a3c235f *src/interrupt.c
491b61dbc3c8a265485f6b29eb5b84aa *src/iterators.c
-e9e8f2dac33c5cc7bfe1da70a95cc05f *src/ivout.f
a21872db43ab0ab40a4660117c02cf94 *src/lad.c
f95ab29a3f1862dc2133f145ef2b8387 *src/lapack.c
a7df6e16bbf2c8daee0f5392b3d04dc1 *src/layout.c
@@ -1024,7 +997,6 @@ f02cb493011fc03a7afd0f73429e7444 *src/scg_headers.h
026c19e5e315a61afa720d1a1a02b2b2 *src/scg_kmeans.c
689526007c1e806566487866a1507dfd *src/scg_optimal_method.c
bd4eee538520a213640c06c511215412 *src/scg_utils.c
-86e001901ddbd58540c49d9e1440358e *src/second.f
525dd7ca0c9d60cb909e6a50bb5cdfe6 *src/separators.c
af447f07a45af2b4f7edaee5d0a877a7 *src/simpleraytracer/Color.cpp
be39147aa9a658a401d5d8e304bfbb68 *src/simpleraytracer/Color.h
diff --git a/src/Makevars.in b/src/Makevars.in
index 0d01558..3067221 100644
--- a/src/Makevars.in
+++ b/src/Makevars.in
@@ -3,14 +3,14 @@ PKG_CFLAGS=-DUSING_R -I. -Iinclude -Ics -Iplfit \
-ICHOLMOD/Include -IAMD/Include -ICOLAMD/Include \
-ISuiteSparse_config \
@CPPFLAGS@ @CFLAGS@ -DNDEBUG -DNPARTITION -DNTIMER -DNCAMD -DNPRINT\
- -DPACKAGE_VERSION=\"@PACKAGE_VERSION@\" -DINTERNAL_ARPACK \
+ -DPACKAGE_VERSION=\"@PACKAGE_VERSION@\" -UINTERNAL_ARPACK $(shell pkg-config --cflags arpack) \
-DIGRAPH_THREAD_LOCAL=/**/ \
$(shell pkg-config --cflags uuid)
PKG_CXXFLAGS= -DUSING_R -DIGRAPH_THREAD_LOCAL=/**/ -DNDEBUG -Iprpack -I. \
-Iinclude -DPRPACK_IGRAPH_SUPPORT
PKG_LIBS=@XML2_LIBS@ @GMP_LIBS@ @GLPK_LIBS@ $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) \
- $(shell pkg-config --libs uuid)
+ $(shell pkg-config --libs arpack uuid)
all: $(SHLIB)
-OBJECTS=AMD/Source/amd.o AMD/Source/amd_1.o AMD/Source/amd_2.o AMD/Source/amd_aat.o AMD/Source/amd_control.o AMD/Source/amd_defaults.o AMD/Source/amd_dump.o AMD/Source/amd_global.o AMD/Source/amd_info.o AMD/Source/amd_order.o AMD/Source/amd_post_tree.o AMD/Source/amd_postorder.o AMD/Source/amd_preprocess.o AMD/Source/amd_valid.o AMD/Source/amdbar.o CHOLMOD/Check/cholmod_check.o CHOLMOD/Check/cholmod_read.o CHOLMOD/Check/cholmod_write.o CHOLMOD/Cholesky/cholmod_amd.o CHOLMOD/Cholesky/cholmod_analyze.o CHOLMOD/Cholesky/cholmod_colamd.o CHOLMOD/Cholesky/cholmod_etree.o CHOLMOD/Cholesky/cholmod_factorize.o CHOLMOD/Cholesky/cholmod_postorder.o CHOLMOD/Cholesky/cholmod_rcond.o CHOLMOD/Cholesky/cholmod_resymbol.o CHOLMOD/Cholesky/cholmod_rowcolcounts.o CHOLMOD/Cholesky/cholmod_rowfac.o CHOLMOD/Cholesky/cholmod_solve.o CHOLMOD/Cholesky/cholmod_spsolve.o CHOLMOD/Core/cholmod_aat.o CHOLMOD/Core/cholmod_add.o CHOLMOD/Core/cholmod_band.o CHOLMOD/Core/cholmod_change_factor.o CHOLMOD/Core/cholmod_common.o CHOLMOD/Core/cholmod_complex.o CHOLMOD/Core/cholmod_copy.o CHOLMOD/Core/cholmod_dense.o CHOLMOD/Core/cholmod_error.o CHOLMOD/Core/cholmod_factor.o CHOLMOD/Core/cholmod_memory.o CHOLMOD/Core/cholmod_sparse.o CHOLMOD/Core/cholmod_transpose.o CHOLMOD/Core/cholmod_triplet.o CHOLMOD/Core/cholmod_version.o CHOLMOD/MatrixOps/cholmod_drop.o CHOLMOD/MatrixOps/cholmod_horzcat.o CHOLMOD/MatrixOps/cholmod_norm.o CHOLMOD/MatrixOps/cholmod_scale.o CHOLMOD/MatrixOps/cholmod_sdmult.o CHOLMOD/MatrixOps/cholmod_ssmult.o CHOLMOD/MatrixOps/cholmod_submatrix.o CHOLMOD/MatrixOps/cholmod_symmetry.o CHOLMOD/MatrixOps/cholmod_vertcat.o CHOLMOD/Modify/cholmod_rowadd.o CHOLMOD/Modify/cholmod_rowdel.o CHOLMOD/Modify/cholmod_updown.o CHOLMOD/Partition/cholmod_camd.o CHOLMOD/Partition/cholmod_ccolamd.o CHOLMOD/Partition/cholmod_csymamd.o CHOLMOD/Partition/cholmod_metis.o CHOLMOD/Partition/cholmod_nesdis.o CHOLMOD/Supernodal/cholmod_super_numeric.o CHOLMOD/Supernodal/cholmod_super_solve.o CHOLMOD/Supernodal/cholmod_super_symbolic.o COLAMD/Source/colamd.o COLAMD/Source/colamd_global.o DensityGrid.o DensityGrid_3d.o NetDataTypes.o NetRoutines.o SuiteSparse_config/SuiteSparse_config.o adjlist.o arpack.o array.o atlas.o attributes.o basic_query.o bfgs.o bigint.o bignum.o bipartite.o blas.o bliss.o bliss/bliss_heap.o bliss/defs.o bliss/graph.o bliss/orbit.o bliss/partition.o bliss/uintseqhash.o bliss/utils.o cattributes.o centrality.o cliquer/cliquer.o cliquer/cliquer_graph.o cliquer/reorder.o cliques.o clustertool.o cocitation.o cohesive_blocks.o coloring.o community.o complex.o components.o conversion.o cores.o cs/cs_add.o cs/cs_amd.o cs/cs_chol.o cs/cs_cholsol.o cs/cs_compress.o cs/cs_counts.o cs/cs_cumsum.o cs/cs_dfs.o cs/cs_dmperm.o cs/cs_droptol.o cs/cs_dropzeros.o cs/cs_dupl.o cs/cs_entry.o cs/cs_ereach.o cs/cs_etree.o cs/cs_fkeep.o cs/cs_gaxpy.o cs/cs_happly.o cs/cs_house.o cs/cs_ipvec.o cs/cs_leaf.o cs/cs_load.o cs/cs_lsolve.o cs/cs_ltsolve.o cs/cs_lu.o cs/cs_lusol.o cs/cs_malloc.o cs/cs_maxtrans.o cs/cs_multiply.o cs/cs_norm.o cs/cs_permute.o cs/cs_pinv.o cs/cs_post.o cs/cs_print.o cs/cs_pvec.o cs/cs_qr.o cs/cs_qrsol.o cs/cs_randperm.o cs/cs_reach.o cs/cs_scatter.o cs/cs_scc.o cs/cs_schol.o cs/cs_spsolve.o cs/cs_sqr.o cs/cs_symperm.o cs/cs_tdfs.o cs/cs_transpose.o cs/cs_updown.o cs/cs_usolve.o cs/cs_util.o cs/cs_utsolve.o decomposition.o distances.o dotproduct.o dqueue.o drl_graph.o drl_graph_3d.o drl_layout.o drl_layout_3d.o drl_parse.o eigen.o embedding.o fast_community.o feedback_arc_set.o flow.o foreign-dl-lexer.o foreign-dl-parser.o foreign-gml-lexer.o foreign-gml-parser.o foreign-graphml.o foreign-lgl-lexer.o foreign-lgl-parser.o foreign-ncol-lexer.o foreign-ncol-parser.o foreign-pajek-lexer.o foreign-pajek-parser.o foreign.o forestfire.o fortran_intrinsics.o games.o gengraph_box_list.o gengraph_degree_sequence.o gengraph_graph_molloy_hash.o gengraph_graph_molloy_optimized.o gengraph_mr-connected.o gengraph_powerlaw.o gengraph_random.o glet.o glpk_support.o gml_tree.o hacks.o heap.o igraph_buckets.o igraph_cliquer.o igraph_error.o igraph_estack.o igraph_fixed_vectorlist.o igraph_grid.o igraph_hashtable.o igraph_heap.o igraph_hrg.o igraph_hrg_types.o igraph_marked_queue.o igraph_psumtree.o igraph_set.o igraph_stack.o igraph_strvector.o igraph_trie.o infomap.o infomap_FlowGraph.o infomap_Greedy.o infomap_Node.o interrupt.o iterators.o lad.o lapack.o layout.o layout_dh.o layout_fr.o layout_gem.o layout_kk.o lsap.o matching.o math.o matrix.o maximal_cliques.o memory.o microscopic_update.o mixing.o motifs.o operators.o optimal_modularity.o other.o paths.o plfit/error.o plfit/gss.o plfit/kolmogorov.o plfit/lbfgs.o plfit/options.o plfit/plfit.o plfit/zeta.o pottsmodel_2.o progress.o prpack.o prpack/prpack_base_graph.o prpack/prpack_igraph_graph.o prpack/prpack_preprocessed_ge_graph.o prpack/prpack_preprocessed_gs_graph.o prpack/prpack_preprocessed_scc_graph.o prpack/prpack_preprocessed_schur_graph.o prpack/prpack_result.o prpack/prpack_solver.o prpack/prpack_utils.o qsort.o qsort_r.o random.o random_walk.o sbm.o scan.o scg.o scg_approximate_methods.o scg_exact_scg.o scg_kmeans.o scg_optimal_method.o scg_utils.o separators.o sir.o spanning_trees.o sparsemat.o spectral_properties.o spmatrix.o st-cuts.o statusbar.o structural_properties.o structure_generators.o sugiyama.o topology.o triangles.o type_indexededgelist.o types.o vector.o vector_ptr.o version.o visitors.o walktrap.o walktrap_communities.o walktrap_graph.o walktrap_heap.o zeroin.o dgetv0.o dlaqrb.o dmout.o dnaitr.o dnapps.o dnaup2.o dnaupd.o dnconv.o dneigh.o dneupd.o dngets.o dsaitr.o dsapps.o dsaup2.o dsaupd.o dsconv.o dseigt.o dsesrt.o dseupd.o dsgets.o dsortc.o dsortr.o dstatn.o dstats.o dstqrb.o dvout.o ivout.o second.o wrap.o simpleraytracer/Color.o simpleraytracer/Light.o simpleraytracer/Point.o simpleraytracer/RIgraphRay.o simpleraytracer/Ray.o simpleraytracer/RayTracer.o simpleraytracer/RayVector.o simpleraytracer/Shape.o simpleraytracer/Sphere.o simpleraytracer/Triangle.o simpleraytracer/unit_limiter.o rinterface.o rinterface_extra.o lazyeval.o
+OBJECTS=AMD/Source/amd.o AMD/Source/amd_1.o AMD/Source/amd_2.o AMD/Source/amd_aat.o AMD/Source/amd_control.o AMD/Source/amd_defaults.o AMD/Source/amd_dump.o AMD/Source/amd_global.o AMD/Source/amd_info.o AMD/Source/amd_order.o AMD/Source/amd_post_tree.o AMD/Source/amd_postorder.o AMD/Source/amd_preprocess.o AMD/Source/amd_valid.o AMD/Source/amdbar.o CHOLMOD/Check/cholmod_check.o CHOLMOD/Check/cholmod_read.o CHOLMOD/Check/cholmod_write.o CHOLMOD/Cholesky/cholmod_amd.o CHOLMOD/Cholesky/cholmod_analyze.o CHOLMOD/Cholesky/cholmod_colamd.o CHOLMOD/Cholesky/cholmod_etree.o CHOLMOD/Cholesky/cholmod_factorize.o CHOLMOD/Cholesky/cholmod_postorder.o CHOLMOD/Cholesky/cholmod_rcond.o CHOLMOD/Cholesky/cholmod_resymbol.o CHOLMOD/Cholesky/cholmod_rowcolcounts.o CHOLMOD/Cholesky/cholmod_rowfac.o CHOLMOD/Cholesky/cholmod_solve.o CHOLMOD/Cholesky/cholmod_spsolve.o CHOLMOD/Core/cholmod_aat.o CHOLMOD/Core/cholmod_add.o CHOLMOD/Core/cholmod_band.o CHOLMOD/Core/cholmod_change_factor.o CHOLMOD/Core/cholmod_common.o CHOLMOD/Core/cholmod_complex.o CHOLMOD/Core/cholmod_copy.o CHOLMOD/Core/cholmod_dense.o CHOLMOD/Core/cholmod_error.o CHOLMOD/Core/cholmod_factor.o CHOLMOD/Core/cholmod_memory.o CHOLMOD/Core/cholmod_sparse.o CHOLMOD/Core/cholmod_transpose.o CHOLMOD/Core/cholmod_triplet.o CHOLMOD/Core/cholmod_version.o CHOLMOD/MatrixOps/cholmod_drop.o CHOLMOD/MatrixOps/cholmod_horzcat.o CHOLMOD/MatrixOps/cholmod_norm.o CHOLMOD/MatrixOps/cholmod_scale.o CHOLMOD/MatrixOps/cholmod_sdmult.o CHOLMOD/MatrixOps/cholmod_ssmult.o CHOLMOD/MatrixOps/cholmod_submatrix.o CHOLMOD/MatrixOps/cholmod_symmetry.o CHOLMOD/MatrixOps/cholmod_vertcat.o CHOLMOD/Modify/cholmod_rowadd.o CHOLMOD/Modify/cholmod_rowdel.o CHOLMOD/Modify/cholmod_updown.o CHOLMOD/Partition/cholmod_camd.o CHOLMOD/Partition/cholmod_ccolamd.o CHOLMOD/Partition/cholmod_csymamd.o CHOLMOD/Partition/cholmod_metis.o CHOLMOD/Partition/cholmod_nesdis.o CHOLMOD/Supernodal/cholmod_super_numeric.o CHOLMOD/Supernodal/cholmod_super_solve.o CHOLMOD/Supernodal/cholmod_super_symbolic.o COLAMD/Source/colamd.o COLAMD/Source/colamd_global.o DensityGrid.o DensityGrid_3d.o NetDataTypes.o NetRoutines.o SuiteSparse_config/SuiteSparse_config.o adjlist.o arpack.o array.o atlas.o attributes.o basic_query.o bfgs.o bigint.o bignum.o bipartite.o blas.o bliss.o bliss/bliss_heap.o bliss/defs.o bliss/graph.o bliss/orbit.o bliss/partition.o bliss/uintseqhash.o bliss/utils.o cattributes.o centrality.o cliquer/cliquer.o cliquer/cliquer_graph.o cliquer/reorder.o cliques.o clustertool.o cocitation.o cohesive_blocks.o coloring.o community.o complex.o components.o conversion.o cores.o cs/cs_add.o cs/cs_amd.o cs/cs_chol.o cs/cs_cholsol.o cs/cs_compress.o cs/cs_counts.o cs/cs_cumsum.o cs/cs_dfs.o cs/cs_dmperm.o cs/cs_droptol.o cs/cs_dropzeros.o cs/cs_dupl.o cs/cs_entry.o cs/cs_ereach.o cs/cs_etree.o cs/cs_fkeep.o cs/cs_gaxpy.o cs/cs_happly.o cs/cs_house.o cs/cs_ipvec.o cs/cs_leaf.o cs/cs_load.o cs/cs_lsolve.o cs/cs_ltsolve.o cs/cs_lu.o cs/cs_lusol.o cs/cs_malloc.o cs/cs_maxtrans.o cs/cs_multiply.o cs/cs_norm.o cs/cs_permute.o cs/cs_pinv.o cs/cs_post.o cs/cs_print.o cs/cs_pvec.o cs/cs_qr.o cs/cs_qrsol.o cs/cs_randperm.o cs/cs_reach.o cs/cs_scatter.o cs/cs_scc.o cs/cs_schol.o cs/cs_spsolve.o cs/cs_sqr.o cs/cs_symperm.o cs/cs_tdfs.o cs/cs_transpose.o cs/cs_updown.o cs/cs_usolve.o cs/cs_util.o cs/cs_utsolve.o decomposition.o distances.o dotproduct.o dqueue.o drl_graph.o drl_graph_3d.o drl_layout.o drl_layout_3d.o drl_parse.o eigen.o embedding.o fast_community.o feedback_arc_set.o flow.o foreign-dl-lexer.o foreign-dl-parser.o foreign-gml-lexer.o foreign-gml-parser.o foreign-graphml.o foreign-lgl-lexer.o foreign-lgl-parser.o foreign-ncol-lexer.o foreign-ncol-parser.o foreign-pajek-lexer.o foreign-pajek-parser.o foreign.o forestfire.o fortran_intrinsics.o games.o gengraph_box_list.o gengraph_degree_sequence.o gengraph_graph_molloy_hash.o gengraph_graph_molloy_optimized.o gengraph_mr-connected.o gengraph_powerlaw.o gengraph_random.o glet.o glpk_support.o gml_tree.o hacks.o heap.o igraph_buckets.o igraph_cliquer.o igraph_error.o igraph_estack.o igraph_fixed_vectorlist.o igraph_grid.o igraph_hashtable.o igraph_heap.o igraph_hrg.o igraph_hrg_types.o igraph_marked_queue.o igraph_psumtree.o igraph_set.o igraph_stack.o igraph_strvector.o igraph_trie.o infomap.o infomap_FlowGraph.o infomap_Greedy.o infomap_Node.o interrupt.o iterators.o lad.o lapack.o layout.o layout_dh.o layout_fr.o layout_gem.o layout_kk.o lsap.o matching.o math.o matrix.o maximal_cliques.o memory.o microscopic_update.o mixing.o motifs.o operators.o optimal_modularity.o other.o paths.o plfit/error.o plfit/gss.o plfit/kolmogorov.o plfit/lbfgs.o plfit/options.o plfit/plfit.o plfit/zeta.o pottsmodel_2.o progress.o prpack.o prpack/prpack_base_graph.o prpack/prpack_igraph_graph.o prpack/prpack_preprocessed_ge_graph.o prpack/prpack_preprocessed_gs_graph.o prpack/prpack_preprocessed_scc_graph.o prpack/prpack_preprocessed_schur_graph.o prpack/prpack_result.o prpack/prpack_solver.o prpack/prpack_utils.o qsort.o qsort_r.o random.o random_walk.o sbm.o scan.o scg.o scg_approximate_methods.o scg_exact_scg.o scg_kmeans.o scg_optimal_method.o scg_utils.o separators.o sir.o spanning_trees.o sparsemat.o spectral_properties.o spmatrix.o st-cuts.o statusbar.o structural_properties.o structure_generators.o sugiyama.o topology.o triangles.o type_indexededgelist.o types.o vector.o vector_ptr.o version.o visitors.o walktrap.o walktrap_communities.o walktrap_graph.o walktrap_heap.o zeroin.o wrap.o simpleraytracer/Color.o simpleraytracer/Light.o simpleraytracer/Point.o simpleraytracer/RIgraphRay.o simpleraytracer/Ray.o simpleraytracer/RayTracer.o simpleraytracer/RayVector.o simpleraytracer/Shape.o simpleraytracer/Sphere.o simpleraytracer/Triangle.o simpleraytracer/unit_limiter.o rinterface.o rinterface_extra.o lazyeval.o
diff --git a/src/dgetv0.f b/src/dgetv0.f
deleted file mode 100644
index b64d47a..0000000
--- a/src/dgetv0.f
+++ /dev/null
@@ -1,419 +0,0 @@
-c-----------------------------------------------------------------------
-c\BeginDoc
-c
-c\Name: igraphdgetv0
-c
-c\Description:
-c Generate a random initial residual vector for the Arnoldi process.
-c Force the residual vector to be in the range of the operator OP.
-c
-c\Usage:
-c call igraphdgetv0
-c ( IDO, BMAT, ITRY, INITV, N, J, V, LDV, RESID, RNORM,
-c IPNTR, WORKD, IERR )
-c
-c\Arguments
-c IDO Integer. (INPUT/OUTPUT)
-c Reverse communication flag. IDO must be zero on the first
-c call to igraphdgetv0.
-c -------------------------------------------------------------
-c IDO = 0: first call to the reverse communication interface
-c IDO = -1: compute Y = OP * X where
-c IPNTR(1) is the pointer into WORKD for X,
-c IPNTR(2) is the pointer into WORKD for Y.
-c This is for the initialization phase to force the
-c starting vector into the range of OP.
-c IDO = 2: compute Y = B * X where
-c IPNTR(1) is the pointer into WORKD for X,
-c IPNTR(2) is the pointer into WORKD for Y.
-c IDO = 99: done
-c -------------------------------------------------------------
-c
-c BMAT Character*1. (INPUT)
-c BMAT specifies the type of the matrix B in the (generalized)
-c eigenvalue problem A*x = lambda*B*x.
-c B = 'I' -> standard eigenvalue problem A*x = lambda*x
-c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x
-c
-c ITRY Integer. (INPUT)
-c ITRY counts the number of times that igraphdgetv0 is called.
-c It should be set to 1 on the initial call to igraphdgetv0.
-c
-c INITV Logical variable. (INPUT)
-c .TRUE. => the initial residual vector is given in RESID.
-c .FALSE. => generate a random initial residual vector.
-c
-c N Integer. (INPUT)
-c Dimension of the problem.
-c
-c J Integer. (INPUT)
-c Index of the residual vector to be generated, with respect to
-c the Arnoldi process. J > 1 in case of a "restart".
-c
-c V Double precision N by J array. (INPUT)
-c The first J-1 columns of V contain the current Arnoldi basis
-c if this is a "restart".
-c
-c LDV Integer. (INPUT)
-c Leading dimension of V exactly as declared in the calling
-c program.
-c
-c RESID Double precision array of length N. (INPUT/OUTPUT)
-c Initial residual vector to be generated. If RESID is
-c provided, force RESID into the range of the operator OP.
-c
-c RNORM Double precision scalar. (OUTPUT)
-c B-norm of the generated residual.
-c
-c IPNTR Integer array of length 3. (OUTPUT)
-c
-c WORKD Double precision work array of length 2*N. (REVERSE COMMUNICATION).
-c On exit, WORK(1:N) = B*RESID to be used in SSAITR.
-c
-c IERR Integer. (OUTPUT)
-c = 0: Normal exit.
-c = -1: Cannot generate a nontrivial restarted residual vector
-c in the range of the operator OP.
-c
-c\EndDoc
-c
-c-----------------------------------------------------------------------
-c
-c\BeginLib
-c
-c\Local variables:
-c xxxxxx real
-c
-c\References:
-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
-c pp 357-385.
-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
-c Restarted Arnoldi Iteration", Rice University Technical Report
-c TR95-13, Department of Computational and Applied Mathematics.
-c
-c\Routines called:
-c igraphsecond ARPACK utility routine for timing.
-c igraphdvout ARPACK utility routine for vector output.
-c dlarnv LAPACK routine for generating a random vector.
-c dgemv Level 2 BLAS routine for matrix vector multiplication.
-c dcopy Level 1 BLAS that copies one vector to another.
-c ddot Level 1 BLAS that computes the scalar product of two vectors.
-c dnrm2 Level 1 BLAS that computes the norm of a vector.
-c
-c\Author
-c Danny Sorensen Phuong Vu
-c Richard Lehoucq CRPC / Rice University
-c Dept. of Computational & Houston, Texas
-c Applied Mathematics
-c Rice University
-c Houston, Texas
-c
-c\SCCS Information: @(#)
-c FILE: getv0.F SID: 2.6 DATE OF SID: 8/27/96 RELEASE: 2
-c
-c\EndLib
-c
-c-----------------------------------------------------------------------
-c
- subroutine igraphdgetv0
- & ( ido, bmat, itry, initv, n, j, v, ldv, resid, rnorm,
- & ipntr, workd, ierr )
-c
-c %----------------------------------------------------%
-c | Include files for debugging and timing information |
-c %----------------------------------------------------%
-c
- include 'debug.h'
- include 'stat.h'
-c
-c %------------------%
-c | Scalar Arguments |
-c %------------------%
-c
- character bmat*1
- logical initv
- integer ido, ierr, itry, j, ldv, n
- Double precision
- & rnorm
-c
-c %-----------------%
-c | Array Arguments |
-c %-----------------%
-c
- integer ipntr(3)
- Double precision
- & resid(n), v(ldv,j), workd(2*n)
-c
-c %------------%
-c | Parameters |
-c %------------%
-c
- Double precision
- & one, zero
- parameter (one = 1.0D+0, zero = 0.0D+0)
-c
-c %------------------------%
-c | Local Scalars & Arrays |
-c %------------------------%
-c
- logical first, inits, orth
- integer idist, iseed(4), iter, msglvl, jj
- Double precision
- & rnorm0
- save first, iseed, inits, iter, msglvl, orth, rnorm0
-c
-c %----------------------%
-c | External Subroutines |
-c %----------------------%
-c
- external dlarnv, igraphdvout, dcopy, dgemv, igraphsecond
-c
-c %--------------------%
-c | External Functions |
-c %--------------------%
-c
- Double precision
- & ddot, dnrm2
- external ddot, dnrm2
-c
-c %---------------------%
-c | Intrinsic Functions |
-c %---------------------%
-c
- intrinsic abs, sqrt
-c
-c %-----------------%
-c | Data Statements |
-c %-----------------%
-c
- data inits /.true./
-c
-c %-----------------------%
-c | Executable Statements |
-c %-----------------------%
-c
-c
-c %-----------------------------------%
-c | Initialize the seed of the LAPACK |
-c | random number generator |
-c %-----------------------------------%
-c
- if (inits) then
- iseed(1) = 1
- iseed(2) = 3
- iseed(3) = 5
- iseed(4) = 7
- inits = .false.
- end if
-c
- if (ido .eq. 0) then
-c
-c %-------------------------------%
-c | Initialize timing statistics |
-c | & message level for debugging |
-c %-------------------------------%
-c
- call igraphsecond (t0)
- msglvl = mgetv0
-c
- ierr = 0
- iter = 0
- first = .FALSE.
- orth = .FALSE.
-c
-c %-----------------------------------------------------%
-c | Possibly generate a random starting vector in RESID |
-c | Use a LAPACK random number generator used by the |
-c | matrix generation routines. |
-c | idist = 1: uniform (0,1) distribution; |
-c | idist = 2: uniform (-1,1) distribution; |
-c | idist = 3: normal (0,1) distribution; |
-c %-----------------------------------------------------%
-c
- if (.not.initv) then
- idist = 2
- call dlarnv (idist, iseed, n, resid)
- end if
-c
-c %----------------------------------------------------------%
-c | Force the starting vector into the range of OP to handle |
-c | the generalized problem when B is possibly (singular). |
-c %----------------------------------------------------------%
-c
- call igraphsecond (t2)
- if (bmat .eq. 'G') then
- nopx = nopx + 1
- ipntr(1) = 1
- ipntr(2) = n + 1
- call dcopy (n, resid, 1, workd, 1)
- ido = -1
- go to 9000
- end if
- end if
-c
-c %-----------------------------------------%
-c | Back from computing OP*(initial-vector) |
-c %-----------------------------------------%
-c
- if (first) go to 20
-c
-c %-----------------------------------------------%
-c | Back from computing B*(orthogonalized-vector) |
-c %-----------------------------------------------%
-c
- if (orth) go to 40
-c
- if (bmat .eq. 'G') then
- call igraphsecond (t3)
- tmvopx = tmvopx + (t3 - t2)
- end if
-c
-c %------------------------------------------------------%
-c | Starting vector is now in the range of OP; r = OP*r; |
-c | Compute B-norm of starting vector. |
-c %------------------------------------------------------%
-c
- call igraphsecond (t2)
- first = .TRUE.
- if (bmat .eq. 'G') then
- nbx = nbx + 1
- call dcopy (n, workd(n+1), 1, resid, 1)
- ipntr(1) = n + 1
- ipntr(2) = 1
- ido = 2
- go to 9000
- else if (bmat .eq. 'I') then
- call dcopy (n, resid, 1, workd, 1)
- end if
-c
- 20 continue
-c
- if (bmat .eq. 'G') then
- call igraphsecond (t3)
- tmvbx = tmvbx + (t3 - t2)
- end if
-c
- first = .FALSE.
- if (bmat .eq. 'G') then
- rnorm0 = ddot (n, resid, 1, workd, 1)
- rnorm0 = sqrt(abs(rnorm0))
- else if (bmat .eq. 'I') then
- rnorm0 = dnrm2(n, resid, 1)
- end if
- rnorm = rnorm0
-c
-c %---------------------------------------------%
-c | Exit if this is the very first Arnoldi step |
-c %---------------------------------------------%
-c
- if (j .eq. 1) go to 50
-c
-c %----------------------------------------------------------------
-c | Otherwise need to B-orthogonalize the starting vector against |
-c | the current Arnoldi basis using Gram-Schmidt with iter. ref. |
-c | This is the case where an invariant subspace is encountered |
-c | in the middle of the Arnoldi factorization. |
-c | |
-c | s = V^{T}*B*r; r = r - V*s; |
-c | |
-c | Stopping criteria used for iter. ref. is discussed in |
-c | Parlett's book, page 107 and in Gragg & Reichel TOMS paper. |
-c %---------------------------------------------------------------%
-c
- orth = .TRUE.
- 30 continue
-c
- call dgemv ('T', n, j-1, one, v, ldv, workd, 1,
- & zero, workd(n+1), 1)
- call dgemv ('N', n, j-1, -one, v, ldv, workd(n+1), 1,
- & one, resid, 1)
-c
-c %----------------------------------------------------------%
-c | Compute the B-norm of the orthogonalized starting vector |
-c %----------------------------------------------------------%
-c
- call igraphsecond (t2)
- if (bmat .eq. 'G') then
- nbx = nbx + 1
- call dcopy (n, resid, 1, workd(n+1), 1)
- ipntr(1) = n + 1
- ipntr(2) = 1
- ido = 2
- go to 9000
- else if (bmat .eq. 'I') then
- call dcopy (n, resid, 1, workd, 1)
- end if
-c
- 40 continue
-c
- if (bmat .eq. 'G') then
- call igraphsecond (t3)
- tmvbx = tmvbx + (t3 - t2)
- end if
-c
- if (bmat .eq. 'G') then
- rnorm = ddot (n, resid, 1, workd, 1)
- rnorm = sqrt(abs(rnorm))
- else if (bmat .eq. 'I') then
- rnorm = dnrm2(n, resid, 1)
- end if
-c
-c %--------------------------------------%
-c | Check for further orthogonalization. |
-c %--------------------------------------%
-c
- if (msglvl .gt. 2) then
- call igraphdvout (logfil, 1, [rnorm0], ndigit,
- & '_getv0: re-orthonalization ; rnorm0 is')
- call igraphdvout (logfil, 1, [rnorm], ndigit,
- & '_getv0: re-orthonalization ; rnorm is')
- end if
-c
- if (rnorm .gt. 0.717*rnorm0) go to 50
-c
- iter = iter + 1
- if (iter .le. 1) then
-c
-c %-----------------------------------%
-c | Perform iterative refinement step |
-c %-----------------------------------%
-c
- rnorm0 = rnorm
- go to 30
- else
-c
-c %------------------------------------%
-c | Iterative refinement step "failed" |
-c %------------------------------------%
-c
- do 45 jj = 1, n
- resid(jj) = zero
- 45 continue
- rnorm = zero
- ierr = -1
- end if
-c
- 50 continue
-c
- if (msglvl .gt. 0) then
- call igraphdvout (logfil, 1, [rnorm], ndigit,
- & '_getv0: B-norm of initial / restarted starting vector')
- end if
- if (msglvl .gt. 2) then
- call igraphdvout (logfil, n, resid, ndigit,
- & '_getv0: initial / restarted starting vector')
- end if
- ido = 99
-c
- call igraphsecond (t1)
- tgetv0 = tgetv0 + (t1 - t0)
-c
- 9000 continue
- return
-c
-c %---------------%
-c | End of igraphdgetv0 |
-c %---------------%
-c
- end
diff --git a/src/dlaqrb.f b/src/dlaqrb.f
deleted file mode 100644
index 5fcefec..0000000
--- a/src/dlaqrb.f
+++ /dev/null
@@ -1,521 +0,0 @@
-c-----------------------------------------------------------------------
-c\BeginDoc
-c
-c\Name: igraphdlaqrb
-c
-c\Description:
-c Compute the eigenvalues and the Schur decomposition of an upper
-c Hessenberg submatrix in rows and columns ILO to IHI. Only the
-c last component of the Schur vectors are computed.
-c
-c This is mostly a modification of the LAPACK routine dlahqr.
-c
-c\Usage:
-c call igraphdlaqrb
-c ( WANTT, N, ILO, IHI, H, LDH, WR, WI, Z, INFO )
-c
-c\Arguments
-c WANTT Logical variable. (INPUT)
-c = .TRUE. : the full Schur form T is required;
-c = .FALSE.: only eigenvalues are required.
-c
-c N Integer. (INPUT)
-c The order of the matrix H. N >= 0.
-c
-c ILO Integer. (INPUT)
-c IHI Integer. (INPUT)
-c It is assumed that H is already upper quasi-triangular in
-c rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless
-c ILO = 1). SLAQRB works primarily with the Hessenberg
-c submatrix in rows and columns ILO to IHI, but applies
-c transformations to all of H if WANTT is .TRUE..
-c 1 <= ILO <= max(1,IHI); IHI <= N.
-c
-c H Double precision array, dimension (LDH,N). (INPUT/OUTPUT)
-c On entry, the upper Hessenberg matrix H.
-c On exit, if WANTT is .TRUE., H is upper quasi-triangular in
-c rows and columns ILO:IHI, with any 2-by-2 diagonal blocks in
-c standard form. If WANTT is .FALSE., the contents of H are
-c unspecified on exit.
-c
-c LDH Integer. (INPUT)
-c The leading dimension of the array H. LDH >= max(1,N).
-c
-c WR Double precision array, dimension (N). (OUTPUT)
-c WI Double precision array, dimension (N). (OUTPUT)
-c The real and imaginary parts, respectively, of the computed
-c eigenvalues ILO to IHI are stored in the corresponding
-c elements of WR and WI. If two eigenvalues are computed as a
-c complex conjugate pair, they are stored in consecutive
-c elements of WR and WI, say the i-th and (i+1)th, with
-c WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the
-c eigenvalues are stored in the same order as on the diagonal
-c of the Schur form returned in H, with WR(i) = H(i,i), and, if
-c H(i:i+1,i:i+1) is a 2-by-2 diagonal block,
-c WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i).
-c
-c Z Double precision array, dimension (N). (OUTPUT)
-c On exit Z contains the last components of the Schur vectors.
-c
-c INFO Integer. (OUPUT)
-c = 0: successful exit
-c > 0: SLAQRB failed to compute all the eigenvalues ILO to IHI
-c in a total of 30*(IHI-ILO+1) iterations; if INFO = i,
-c elements i+1:ihi of WR and WI contain those eigenvalues
-c which have been successfully computed.
-c
-c\Remarks
-c 1. None.
-c
-c-----------------------------------------------------------------------
-c
-c\BeginLib
-c
-c\Local variables:
-c xxxxxx real
-c
-c\Routines called:
-c dlabad LAPACK routine that computes machine constants.
-c dlamch LAPACK routine that determines machine constants.
-c dlanhs LAPACK routine that computes various norms of a matrix.
-c dlanv2 LAPACK routine that computes the Schur factorization of
-c 2 by 2 nonsymmetric matrix in standard form.
-c dlarfg LAPACK Householder reflection construction routine.
-c dcopy Level 1 BLAS that copies one vector to another.
-c drot Level 1 BLAS that applies a rotation to a 2 by 2 matrix.
-
-c
-c\Author
-c Danny Sorensen Phuong Vu
-c Richard Lehoucq CRPC / Rice University
-c Dept. of Computational & Houston, Texas
-c Applied Mathematics
-c Rice University
-c Houston, Texas
-c
-c\Revision history:
-c xx/xx/92: Version ' 2.4'
-c Modified from the LAPACK routine dlahqr so that only the
-c last component of the Schur vectors are computed.
-c
-c\SCCS Information: @(#)
-c FILE: laqrb.F SID: 2.2 DATE OF SID: 8/27/96 RELEASE: 2
-c
-c\Remarks
-c 1. None
-c
-c\EndLib
-c
-c-----------------------------------------------------------------------
-c
- subroutine igraphdlaqrb ( wantt, n, ilo, ihi, h, ldh, wr, wi,
- & z, info )
-c
-c %------------------%
-c | Scalar Arguments |
-c %------------------%
-c
- logical wantt
- integer ihi, ilo, info, ldh, n
-c
-c %-----------------%
-c | Array Arguments |
-c %-----------------%
-c
- Double precision
- & h( ldh, * ), wi( * ), wr( * ), z( * )
-c
-c %------------%
-c | Parameters |
-c %------------%
-c
- Double precision
- & zero, one, dat1, dat2
- parameter (zero = 0.0D+0, one = 1.0D+0, dat1 = 7.5D-1,
- & dat2 = -4.375D-1)
-c
-c %------------------------%
-c | Local Scalars & Arrays |
-c %------------------------%
-c
- integer i, i1, i2, itn, its, j, k, l, m, nh, nr
- Double precision
- & cs, h00, h10, h11, h12, h21, h22, h33, h33s,
- & h43h34, h44, h44s, ovfl, s, smlnum, sn, sum,
- & t1, t2, t3, tst1, ulp, unfl, v1, v2, v3
- Double precision
- & v( 3 ), work( 1 )
-c
-c %--------------------%
-c | External Functions |
-c %--------------------%
-c
- Double precision
- & dlamch, dlanhs
- external dlamch, dlanhs
-c
-c %----------------------%
-c | External Subroutines |
-c %----------------------%
-c
- external dcopy, dlabad, dlanv2, dlarfg, drot
-c
-c %-----------------------%
-c | Executable Statements |
-c %-----------------------%
-c
- info = 0
-c
-c %--------------------------%
-c | Quick return if possible |
-c %--------------------------%
-c
- if( n.eq.0 )
- & return
- if( ilo.eq.ihi ) then
- wr( ilo ) = h( ilo, ilo )
- wi( ilo ) = zero
- return
- end if
-c
-c %---------------------------------------------%
-c | Initialize the vector of last components of |
-c | the Schur vectors for accumulation. |
-c %---------------------------------------------%
-c
- do 5 j = 1, n-1
- z(j) = zero
- 5 continue
- z(n) = one
-c
- nh = ihi - ilo + 1
-c
-c %-------------------------------------------------------------%
-c | Set machine-dependent constants for the stopping criterion. |
-c | If norm(H) <= sqrt(OVFL), overflow should not occur. |
-c %-------------------------------------------------------------%
-c
- unfl = dlamch( 'safe minimum' )
- ovfl = one / unfl
- call dlabad( unfl, ovfl )
- ulp = dlamch( 'precision' )
- smlnum = unfl*( nh / ulp )
-c
-c %---------------------------------------------------------------%
-c | I1 and I2 are the indices of the first row and last column |
-c | of H to which transformations must be applied. If eigenvalues |
-c | only are computed, I1 and I2 are set inside the main loop. |
-c | Zero out H(J+2,J) = ZERO for J=1:N if WANTT = .TRUE. |
-c | else H(J+2,J) for J=ILO:IHI-ILO-1 if WANTT = .FALSE. |
-c %---------------------------------------------------------------%
-c
- if( wantt ) then
- i1 = 1
- i2 = n
- do 8 i=1,i2-2
- h(i1+i+1,i) = zero
- 8 continue
- else
- do 9 i=1, ihi-ilo-1
- h(ilo+i+1,ilo+i-1) = zero
- 9 continue
- end if
-c
-c %---------------------------------------------------%
-c | ITN is the total number of QR iterations allowed. |
-c %---------------------------------------------------%
-c
- itn = 30*nh
-c
-c ------------------------------------------------------------------
-c The main loop begins here. I is the loop index and decreases from
-c IHI to ILO in steps of 1 or 2. Each iteration of the loop works
-c with the active submatrix in rows and columns L to I.
-c Eigenvalues I+1 to IHI have already converged. Either L = ILO or
-c H(L,L-1) is negligible so that the matrix splits.
-c ------------------------------------------------------------------
-c
- i = ihi
- 10 continue
- l = ilo
- if( i.lt.ilo )
- & go to 150
-
-c %--------------------------------------------------------------%
-c | Perform QR iterations on rows and columns ILO to I until a |
-c | submatrix of order 1 or 2 splits off at the bottom because a |
-c | subdiagonal element has become negligible. |
-c %--------------------------------------------------------------%
-
- do 130 its = 0, itn
-c
-c %----------------------------------------------%
-c | Look for a single small subdiagonal element. |
-c %----------------------------------------------%
-c
- do 20 k = i, l + 1, -1
- tst1 = abs( h( k-1, k-1 ) ) + abs( h( k, k ) )
- if( tst1.eq.zero )
- & tst1 = dlanhs( '1', i-l+1, h( l, l ), ldh, work )
- if( abs( h( k, k-1 ) ).le.max( ulp*tst1, smlnum ) )
- & go to 30
- 20 continue
- 30 continue
- l = k
- if( l.gt.ilo ) then
-c
-c %------------------------%
-c | H(L,L-1) is negligible |
-c %------------------------%
-c
- h( l, l-1 ) = zero
- end if
-c
-c %-------------------------------------------------------------%
-c | Exit from loop if a submatrix of order 1 or 2 has split off |
-c %-------------------------------------------------------------%
-c
- if( l.ge.i-1 )
- & go to 140
-c
-c %---------------------------------------------------------%
-c | Now the active submatrix is in rows and columns L to I. |
-c | If eigenvalues only are being computed, only the active |
-c | submatrix need be transformed. |
-c %---------------------------------------------------------%
-c
- if( .not.wantt ) then
- i1 = l
- i2 = i
- end if
-c
- if( its.eq.10 .or. its.eq.20 ) then
-c
-c %-------------------%
-c | Exceptional shift |
-c %-------------------%
-c
- s = abs( h( i, i-1 ) ) + abs( h( i-1, i-2 ) )
- h44 = dat1*s
- h33 = h44
- h43h34 = dat2*s*s
-c
- else
-c
-c %-----------------------------------------%
-c | Prepare to use Wilkinson's double shift |
-c %-----------------------------------------%
-c
- h44 = h( i, i )
- h33 = h( i-1, i-1 )
- h43h34 = h( i, i-1 )*h( i-1, i )
- end if
-c
-c %-----------------------------------------------------%
-c | Look for two consecutive small subdiagonal elements |
-c %-----------------------------------------------------%
-c
- do 40 m = i - 2, l, -1
-c
-c %---------------------------------------------------------%
-c | Determine the effect of starting the double-shift QR |
-c | iteration at row M, and see if this would make H(M,M-1) |
-c | negligible. |
-c %---------------------------------------------------------%
-c
- h11 = h( m, m )
- h22 = h( m+1, m+1 )
- h21 = h( m+1, m )
- h12 = h( m, m+1 )
- h44s = h44 - h11
- h33s = h33 - h11
- v1 = ( h33s*h44s-h43h34 ) / h21 + h12
- v2 = h22 - h11 - h33s - h44s
- v3 = h( m+2, m+1 )
- s = abs( v1 ) + abs( v2 ) + abs( v3 )
- v1 = v1 / s
- v2 = v2 / s
- v3 = v3 / s
- v( 1 ) = v1
- v( 2 ) = v2
- v( 3 ) = v3
- if( m.eq.l )
- & go to 50
- h00 = h( m-1, m-1 )
- h10 = h( m, m-1 )
- tst1 = abs( v1 )*( abs( h00 )+abs( h11 )+abs( h22 ) )
- if( abs( h10 )*( abs( v2 )+abs( v3 ) ).le.ulp*tst1 )
- & go to 50
- 40 continue
- 50 continue
-c
-c %----------------------%
-c | Double-shift QR step |
-c %----------------------%
-c
- do 120 k = m, i - 1
-c
-c ------------------------------------------------------------
-c The first iteration of this loop determines a reflection G
-c from the vector V and applies it from left and right to H,
-c thus creating a nonzero bulge below the subdiagonal.
-c
-c Each subsequent iteration determines a reflection G to
-c restore the Hessenberg form in the (K-1)th column, and thus
-c chases the bulge one step toward the bottom of the active
-c submatrix. NR is the order of G.
-c ------------------------------------------------------------
-c
- nr = min( 3, i-k+1 )
- if( k.gt.m )
- & call dcopy( nr, h( k, k-1 ), 1, v, 1 )
- call dlarfg( nr, v( 1 ), v( 2 ), 1, t1 )
- if( k.gt.m ) then
- h( k, k-1 ) = v( 1 )
- h( k+1, k-1 ) = zero
- if( k.lt.i-1 )
- & h( k+2, k-1 ) = zero
- else if( m.gt.l ) then
- h( k, k-1 ) = -h( k, k-1 )
- end if
- v2 = v( 2 )
- t2 = t1*v2
- if( nr.eq.3 ) then
- v3 = v( 3 )
- t3 = t1*v3
-c
-c %------------------------------------------------%
-c | Apply G from the left to transform the rows of |
-c | the matrix in columns K to I2. |
-c %------------------------------------------------%
-c
- do 60 j = k, i2
- sum = h( k, j ) + v2*h( k+1, j ) + v3*h( k+2, j )
- h( k, j ) = h( k, j ) - sum*t1
- h( k+1, j ) = h( k+1, j ) - sum*t2
- h( k+2, j ) = h( k+2, j ) - sum*t3
- 60 continue
-c
-c %----------------------------------------------------%
-c | Apply G from the right to transform the columns of |
-c | the matrix in rows I1 to min(K+3,I). |
-c %----------------------------------------------------%
-c
- do 70 j = i1, min( k+3, i )
- sum = h( j, k ) + v2*h( j, k+1 ) + v3*h( j, k+2 )
- h( j, k ) = h( j, k ) - sum*t1
- h( j, k+1 ) = h( j, k+1 ) - sum*t2
- h( j, k+2 ) = h( j, k+2 ) - sum*t3
- 70 continue
-c
-c %----------------------------------%
-c | Accumulate transformations for Z |
-c %----------------------------------%
-c
- sum = z( k ) + v2*z( k+1 ) + v3*z( k+2 )
- z( k ) = z( k ) - sum*t1
- z( k+1 ) = z( k+1 ) - sum*t2
- z( k+2 ) = z( k+2 ) - sum*t3
-
- else if( nr.eq.2 ) then
-c
-c %------------------------------------------------%
-c | Apply G from the left to transform the rows of |
-c | the matrix in columns K to I2. |
-c %------------------------------------------------%
-c
- do 90 j = k, i2
- sum = h( k, j ) + v2*h( k+1, j )
- h( k, j ) = h( k, j ) - sum*t1
- h( k+1, j ) = h( k+1, j ) - sum*t2
- 90 continue
-c
-c %----------------------------------------------------%
-c | Apply G from the right to transform the columns of |
-c | the matrix in rows I1 to min(K+3,I). |
-c %----------------------------------------------------%
-c
- do 100 j = i1, i
- sum = h( j, k ) + v2*h( j, k+1 )
- h( j, k ) = h( j, k ) - sum*t1
- h( j, k+1 ) = h( j, k+1 ) - sum*t2
- 100 continue
-c
-c %----------------------------------%
-c | Accumulate transformations for Z |
-c %----------------------------------%
-c
- sum = z( k ) + v2*z( k+1 )
- z( k ) = z( k ) - sum*t1
- z( k+1 ) = z( k+1 ) - sum*t2
- end if
- 120 continue
-
- 130 continue
-c
-c %-------------------------------------------------------%
-c | Failure to converge in remaining number of iterations |
-c %-------------------------------------------------------%
-c
- info = i
- return
-
- 140 continue
-
- if( l.eq.i ) then
-c
-c %------------------------------------------------------%
-c | H(I,I-1) is negligible: one eigenvalue has converged |
-c %------------------------------------------------------%
-c
- wr( i ) = h( i, i )
- wi( i ) = zero
-
- else if( l.eq.i-1 ) then
-c
-c %--------------------------------------------------------%
-c | H(I-1,I-2) is negligible; |
-c | a pair of eigenvalues have converged. |
-c | |
-c | Transform the 2-by-2 submatrix to standard Schur form, |
-c | and compute and store the eigenvalues. |
-c %--------------------------------------------------------%
-c
- call dlanv2( h( i-1, i-1 ), h( i-1, i ), h( i, i-1 ),
- & h( i, i ), wr( i-1 ), wi( i-1 ), wr( i ), wi( i ),
- & cs, sn )
-
- if( wantt ) then
-c
-c %-----------------------------------------------------%
-c | Apply the transformation to the rest of H and to Z, |
-c | as required. |
-c %-----------------------------------------------------%
-c
- if( i2.gt.i )
- & call drot( i2-i, h( i-1, i+1 ), ldh, h( i, i+1 ), ldh,
- & cs, sn )
- call drot( i-i1-1, h( i1, i-1 ), 1, h( i1, i ), 1, cs, sn )
- sum = cs*z( i-1 ) + sn*z( i )
- z( i ) = cs*z( i ) - sn*z( i-1 )
- z( i-1 ) = sum
- end if
- end if
-c
-c %---------------------------------------------------------%
-c | Decrement number of remaining iterations, and return to |
-c | start of the main loop with new value of I. |
-c %---------------------------------------------------------%
-c
- itn = itn - its
- i = l - 1
- go to 10
-
- 150 continue
- return
-c
-c %---------------%
-c | End of igraphdlaqrb |
-c %---------------%
-c
- end
diff --git a/src/dmout.f b/src/dmout.f
deleted file mode 100644
index 6204d64..0000000
--- a/src/dmout.f
+++ /dev/null
@@ -1,167 +0,0 @@
-*-----------------------------------------------------------------------
-* Routine: DMOUT
-*
-* Purpose: Real matrix output routine.
-*
-* Usage: CALL DMOUT (LOUT, M, N, A, LDA, IDIGIT, IFMT)
-*
-* Arguments
-* M - Number of rows of A. (Input)
-* N - Number of columns of A. (Input)
-* A - Real M by N matrix to be printed. (Input)
-* LDA - Leading dimension of A exactly as specified in the
-* dimension statement of the calling program. (Input)
-* IFMT - Format to be used in printing matrix A. (Input)
-* IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In)
-* If IDIGIT .LT. 0, printing is done with 72 columns.
-* If IDIGIT .GT. 0, printing is done with 132 columns.
-*
-*-----------------------------------------------------------------------
-*
- SUBROUTINE IGRAPHDMOUT( LOUT, M, N, A, LDA, IDIGIT, IFMT )
-* ...
-* ... SPECIFICATIONS FOR ARGUMENTS
-* ...
-* ... SPECIFICATIONS FOR LOCAL VARIABLES
-* .. Scalar Arguments ..
- CHARACTER*( * ) IFMT
- INTEGER IDIGIT, LDA, LOUT, M, N
-* ..
-* .. Array Arguments ..
- DOUBLE PRECISION A( LDA, * )
-* ..
-* .. Local Scalars ..
- CHARACTER*80 LINE
- INTEGER I, J, K1, K2, LLL, NDIGIT
-* ..
-* .. Local Arrays ..
- CHARACTER ICOL( 3 )
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC LEN, MIN, MIN0
-* ..
-* .. Data statements ..
- DATA ICOL( 1 ), ICOL( 2 ), ICOL( 3 ) / 'C', 'o',
- $ 'l' /
-* ..
-* .. Executable Statements ..
-* ...
-* ... FIRST EXECUTABLE STATEMENT
-*
-c$$$ LLL = MIN( LEN( IFMT ), 80 )
-c$$$ DO 10 I = 1, LLL
-c$$$ LINE( I: I ) = '-'
-c$$$ 10 CONTINUE
-c$$$*
-c$$$ DO 20 I = LLL + 1, 80
-c$$$ LINE( I: I ) = ' '
-c$$$ 20 CONTINUE
-c$$$*
-c$$$ WRITE( LOUT, FMT = 9999 )IFMT, LINE( 1: LLL )
-c$$$ 9999 FORMAT( / 1X, A, / 1X, A )
-c$$$*
-c$$$ IF( M.LE.0 .OR. N.LE.0 .OR. LDA.LE.0 )
-c$$$ $ RETURN
-c$$$ NDIGIT = IDIGIT
-c$$$ IF( IDIGIT.EQ.0 )
-c$$$ $ NDIGIT = 4
-c$$$*
-c$$$*=======================================================================
-c$$$* CODE FOR OUTPUT USING 72 COLUMNS FORMAT
-c$$$*=======================================================================
-c$$$*
-c$$$ IF( IDIGIT.LT.0 ) THEN
-c$$$ NDIGIT = -IDIGIT
-c$$$ IF( NDIGIT.LE.4 ) THEN
-c$$$ DO 40 K1 = 1, N, 5
-c$$$ K2 = MIN0( N, K1+4 )
-c$$$ WRITE( LOUT, FMT = 9998 )( ICOL, I, I = K1, K2 )
-c$$$ DO 30 I = 1, M
-c$$$ WRITE( LOUT, FMT = 9994 )I, ( A( I, J ), J = K1, K2 )
-c$$$ 30 CONTINUE
-c$$$ 40 CONTINUE
-c$$$*
-c$$$ ELSE IF( NDIGIT.LE.6 ) THEN
-c$$$ DO 60 K1 = 1, N, 4
-c$$$ K2 = MIN0( N, K1+3 )
-c$$$ WRITE( LOUT, FMT = 9997 )( ICOL, I, I = K1, K2 )
-c$$$ DO 50 I = 1, M
-c$$$ WRITE( LOUT, FMT = 9993 )I, ( A( I, J ), J = K1, K2 )
-c$$$ 50 CONTINUE
-c$$$ 60 CONTINUE
-c$$$*
-c$$$ ELSE IF( NDIGIT.LE.10 ) THEN
-c$$$ DO 80 K1 = 1, N, 3
-c$$$ K2 = MIN0( N, K1+2 )
-c$$$ WRITE( LOUT, FMT = 9996 )( ICOL, I, I = K1, K2 )
-c$$$ DO 70 I = 1, M
-c$$$ WRITE( LOUT, FMT = 9992 )I, ( A( I, J ), J = K1, K2 )
-c$$$ 70 CONTINUE
-c$$$ 80 CONTINUE
-c$$$*
-c$$$ ELSE
-c$$$ DO 100 K1 = 1, N, 2
-c$$$ K2 = MIN0( N, K1+1 )
-c$$$ WRITE( LOUT, FMT = 9995 )( ICOL, I, I = K1, K2 )
-c$$$ DO 90 I = 1, M
-c$$$ WRITE( LOUT, FMT = 9991 )I, ( A( I, J ), J = K1, K2 )
-c$$$ 90 CONTINUE
-c$$$ 100 CONTINUE
-c$$$ END IF
-c$$$*
-c$$$*=======================================================================
-c$$$* CODE FOR OUTPUT USING 132 COLUMNS FORMAT
-c$$$*=======================================================================
-c$$$*
-c$$$ ELSE
-c$$$ IF( NDIGIT.LE.4 ) THEN
-c$$$ DO 120 K1 = 1, N, 10
-c$$$ K2 = MIN0( N, K1+9 )
-c$$$ WRITE( LOUT, FMT = 9998 )( ICOL, I, I = K1, K2 )
-c$$$ DO 110 I = 1, M
-c$$$ WRITE( LOUT, FMT = 9994 )I, ( A( I, J ), J = K1, K2 )
-c$$$ 110 CONTINUE
-c$$$ 120 CONTINUE
-c$$$*
-c$$$ ELSE IF( NDIGIT.LE.6 ) THEN
-c$$$ DO 140 K1 = 1, N, 8
-c$$$ K2 = MIN0( N, K1+7 )
-c$$$ WRITE( LOUT, FMT = 9997 )( ICOL, I, I = K1, K2 )
-c$$$ DO 130 I = 1, M
-c$$$ WRITE( LOUT, FMT = 9993 )I, ( A( I, J ), J = K1, K2 )
-c$$$ 130 CONTINUE
-c$$$ 140 CONTINUE
-c$$$*
-c$$$ ELSE IF( NDIGIT.LE.10 ) THEN
-c$$$ DO 160 K1 = 1, N, 6
-c$$$ K2 = MIN0( N, K1+5 )
-c$$$ WRITE( LOUT, FMT = 9996 )( ICOL, I, I = K1, K2 )
-c$$$ DO 150 I = 1, M
-c$$$ WRITE( LOUT, FMT = 9992 )I, ( A( I, J ), J = K1, K2 )
-c$$$ 150 CONTINUE
-c$$$ 160 CONTINUE
-c$$$*
-c$$$ ELSE
-c$$$ DO 180 K1 = 1, N, 5
-c$$$ K2 = MIN0( N, K1+4 )
-c$$$ WRITE( LOUT, FMT = 9995 )( ICOL, I, I = K1, K2 )
-c$$$ DO 170 I = 1, M
-c$$$ WRITE( LOUT, FMT = 9991 )I, ( A( I, J ), J = K1, K2 )
-c$$$ 170 CONTINUE
-c$$$ 180 CONTINUE
-c$$$ END IF
-c$$$ END IF
-c$$$ WRITE( LOUT, FMT = 9990 )
-c$$$*
-c$$$ 9998 FORMAT( 10X, 10( 4X, 3A1, I4, 1X ) )
-c$$$ 9997 FORMAT( 10X, 8( 5X, 3A1, I4, 2X ) )
-c$$$ 9996 FORMAT( 10X, 6( 7X, 3A1, I4, 4X ) )
-c$$$ 9995 FORMAT( 10X, 5( 9X, 3A1, I4, 6X ) )
-c$$$ 9994 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 10D12.3 )
-c$$$ 9993 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 8D14.5 )
-c$$$ 9992 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 6D18.9 )
-c$$$ 9991 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 5D22.13 )
-c$$$ 9990 FORMAT( 1X, ' ' )
-*
- RETURN
- END
diff --git a/src/dnaitr.f b/src/dnaitr.f
deleted file mode 100644
index 8ec2569..0000000
--- a/src/dnaitr.f
+++ /dev/null
@@ -1,840 +0,0 @@
-c-----------------------------------------------------------------------
-c\BeginDoc
-c
-c\Name: igraphdnaitr
-c
-c\Description:
-c Reverse communication interface for applying NP additional steps to
-c a K step nonsymmetric Arnoldi factorization.
-c
-c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T
-c
-c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0.
-c
-c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T
-c
-c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0.
-c
-c where OP and B are as in igraphdnaupd. The B-norm of r_{k+p} is also
-c computed and returned.
-c
-c\Usage:
-c call igraphdnaitr
-c ( IDO, BMAT, N, K, NP, NB, RESID, RNORM, V, LDV, H, LDH,
-c IPNTR, WORKD, INFO )
-c
-c\Arguments
-c IDO Integer. (INPUT/OUTPUT)
-c Reverse communication flag.
-c -------------------------------------------------------------
-c IDO = 0: first call to the reverse communication interface
-c IDO = -1: compute Y = OP * X where
-c IPNTR(1) is the pointer into WORK for X,
-c IPNTR(2) is the pointer into WORK for Y.
-c This is for the restart phase to force the new
-c starting vector into the range of OP.
-c IDO = 1: compute Y = OP * X where
-c IPNTR(1) is the pointer into WORK for X,
-c IPNTR(2) is the pointer into WORK for Y,
-c IPNTR(3) is the pointer into WORK for B * X.
-c IDO = 2: compute Y = B * X where
-c IPNTR(1) is the pointer into WORK for X,
-c IPNTR(2) is the pointer into WORK for Y.
-c IDO = 99: done
-c -------------------------------------------------------------
-c When the routine is used in the "shift-and-invert" mode, the
-c vector B * Q is already available and do not need to be
-c recompute in forming OP * Q.
-c
-c BMAT Character*1. (INPUT)
-c BMAT specifies the type of the matrix B that defines the
-c semi-inner product for the operator OP. See igraphdnaupd.
-c B = 'I' -> standard eigenvalue problem A*x = lambda*x
-c B = 'G' -> generalized eigenvalue problem A*x = lambda*M**x
-c
-c N Integer. (INPUT)
-c Dimension of the eigenproblem.
-c
-c K Integer. (INPUT)
-c Current size of V and H.
-c
-c NP Integer. (INPUT)
-c Number of additional Arnoldi steps to take.
-c
-c NB Integer. (INPUT)
-c Blocksize to be used in the recurrence.
-c Only work for NB = 1 right now. The goal is to have a
-c program that implement both the block and non-block method.
-c
-c RESID Double precision array of length N. (INPUT/OUTPUT)
-c On INPUT: RESID contains the residual vector r_{k}.
-c On OUTPUT: RESID contains the residual vector r_{k+p}.
-c
-c RNORM Double precision scalar. (INPUT/OUTPUT)
-c B-norm of the starting residual on input.
-c B-norm of the updated residual r_{k+p} on output.
-c
-c V Double precision N by K+NP array. (INPUT/OUTPUT)
-c On INPUT: V contains the Arnoldi vectors in the first K
-c columns.
-c On OUTPUT: V contains the new NP Arnoldi vectors in the next
-c NP columns. The first K columns are unchanged.
-c
-c LDV Integer. (INPUT)
-c Leading dimension of V exactly as declared in the calling
-c program.
-c
-c H Double precision (K+NP) by (K+NP) array. (INPUT/OUTPUT)
-c H is used to store the generated upper Hessenberg matrix.
-c
-c LDH Integer. (INPUT)
-c Leading dimension of H exactly as declared in the calling
-c program.
-c
-c IPNTR Integer array of length 3. (OUTPUT)
-c Pointer to mark the starting locations in the WORK for
-c vectors used by the Arnoldi iteration.
-c -------------------------------------------------------------
-c IPNTR(1): pointer to the current operand vector X.
-c IPNTR(2): pointer to the current result vector Y.
-c IPNTR(3): pointer to the vector B * X when used in the
-c shift-and-invert mode. X is the current operand.
-c -------------------------------------------------------------
-c
-c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION)
-c Distributed array to be used in the basic Arnoldi iteration
-c for reverse communication. The calling program should not
-c use WORKD as temporary workspace during the iteration !!!!!!
-c On input, WORKD(1:N) = B*RESID and is used to save some
-c computation at the first step.
-c
-c INFO Integer. (OUTPUT)
-c = 0: Normal exit.
-c > 0: Size of the spanning invariant subspace of OP found.
-c
-c\EndDoc
-c
-c-----------------------------------------------------------------------
-c
-c\BeginLib
-c
-c\Local variables:
-c xxxxxx real
-c
-c\References:
-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
-c pp 357-385.
-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
-c Restarted Arnoldi Iteration", Rice University Technical Report
-c TR95-13, Department of Computational and Applied Mathematics.
-c
-c\Routines called:
-c igraphdgetv0 ARPACK routine to generate the initial vector.
-c igraphivout ARPACK utility routine that prints integers.
-c igraphsecond ARPACK utility routine for timing.
-c igraphdmout ARPACK utility routine that prints matrices
-c igraphdvout ARPACK utility routine that prints vectors.
-c dlabad LAPACK routine that computes machine constants.
-c dlamch LAPACK routine that determines machine constants.
-c dlascl LAPACK routine for careful scaling of a matrix.
-c dlanhs LAPACK routine that computes various norms of a matrix.
-c dgemv Level 2 BLAS routine for matrix vector multiplication.
-c daxpy Level 1 BLAS that computes a vector triad.
-c dscal Level 1 BLAS that scales a vector.
-c dcopy Level 1 BLAS that copies one vector to another .
-c ddot Level 1 BLAS that computes the scalar product of two vectors.
-c dnrm2 Level 1 BLAS that computes the norm of a vector.
-c
-c\Author
-c Danny Sorensen Phuong Vu
-c Richard Lehoucq CRPC / Rice University
-c Dept. of Computational & Houston, Texas
-c Applied Mathematics
-c Rice University
-c Houston, Texas
-c
-c\Revision history:
-c xx/xx/92: Version ' 2.4'
-c
-c\SCCS Information: @(#)
-c FILE: naitr.F SID: 2.4 DATE OF SID: 8/27/96 RELEASE: 2
-c
-c\Remarks
-c The algorithm implemented is:
-c
-c restart = .false.
-c Given V_{k} = [v_{1}, ..., v_{k}], r_{k};
-c r_{k} contains the initial residual vector even for k = 0;
-c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already
-c computed by the calling program.
-c
-c betaj = rnorm ; p_{k+1} = B*r_{k} ;
-c For j = k+1, ..., k+np Do
-c 1) if ( betaj < tol ) stop or restart depending on j.
-c ( At present tol is zero )
-c if ( restart ) generate a new starting vector.
-c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}];
-c p_{j} = p_{j}/betaj
-c 3) r_{j} = OP*v_{j} where OP is defined as in igraphdnaupd
-c For shift-invert mode p_{j} = B*v_{j} is already available.
-c wnorm = || OP*v_{j} ||
-c 4) Compute the j-th step residual vector.
-c w_{j} = V_{j}^T * B * OP * v_{j}
-c r_{j} = OP*v_{j} - V_{j} * w_{j}
-c H(:,j) = w_{j};
-c H(j,j-1) = rnorm
-c rnorm = || r_(j) ||
-c If (rnorm > 0.717*wnorm) accept step and go back to 1)
-c 5) Re-orthogonalization step:
-c s = V_{j}'*B*r_{j}
-c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} ||
-c alphaj = alphaj + s_{j};
-c 6) Iterative refinement step:
-c If (rnorm1 > 0.717*rnorm) then
-c rnorm = rnorm1
-c accept step and go back to 1)
-c Else
-c rnorm = rnorm1
-c If this is the first time in step 6), go to 5)
-c Else r_{j} lies in the span of V_{j} numerically.
-c Set r_{j} = 0 and rnorm = 0; go to 1)
-c EndIf
-c End Do
-c
-c\EndLib
-c
-c-----------------------------------------------------------------------
-c
- subroutine igraphdnaitr
- & (ido, bmat, n, k, np, nb, resid, rnorm, v, ldv, h, ldh,
- & ipntr, workd, info)
-c
-c %----------------------------------------------------%
-c | Include files for debugging and timing information |
-c %----------------------------------------------------%
-c
- include 'debug.h'
- include 'stat.h'
-c
-c %------------------%
-c | Scalar Arguments |
-c %------------------%
-c
- character bmat*1
- integer ido, info, k, ldh, ldv, n, nb, np
- Double precision
- & rnorm
-c
-c %-----------------%
-c | Array Arguments |
-c %-----------------%
-c
- integer ipntr(3)
- Double precision
- & h(ldh,k+np), resid(n), v(ldv,k+np), workd(3*n)
-c
-c %------------%
-c | Parameters |
-c %------------%
-c
- Double precision
- & one, zero
- parameter (one = 1.0D+0, zero = 0.0D+0)
-c
-c %---------------%
-c | Local Scalars |
-c %---------------%
-c
- logical first, orth1, orth2, rstart, step3, step4
- integer ierr, i, infol, ipj, irj, ivj, iter, itry, j, msglvl,
- & jj
- Double precision
- & betaj, ovfl, temp1, rnorm1, smlnum, tst1, ulp, unfl,
- & wnorm
- save first, orth1, orth2, rstart, step3, step4,
- & ierr, ipj, irj, ivj, iter, itry, j, msglvl, ovfl,
- & betaj, rnorm1, smlnum, ulp, unfl, wnorm
-c
-c %-----------------------%
-c | Local Array Arguments |
-c %-----------------------%
-c
- Double precision
- & xtemp(2)
-c
-c %----------------------%
-c | External Subroutines |
-c %----------------------%
-c
- external daxpy, dcopy, dscal, dgemv, igraphdgetv0, dlabad,
- & igraphdvout, igraphdmout, igraphivout, igraphsecond
-c
-c %--------------------%
-c | External Functions |
-c %--------------------%
-c
- Double precision
- & ddot, dnrm2, dlanhs, dlamch
- external ddot, dnrm2, dlanhs, dlamch
-c
-c %---------------------%
-c | Intrinsic Functions |
-c %---------------------%
-c
- intrinsic abs, sqrt
-c
-c %-----------------%
-c | Data statements |
-c %-----------------%
-c
- data first / .true. /
-c
-c %-----------------------%
-c | Executable Statements |
-c %-----------------------%
-c
- if (first) then
-c
-c %-----------------------------------------%
-c | Set machine-dependent constants for the |
-c | the splitting and deflation criterion. |
-c | If norm(H) <= sqrt(OVFL), |
-c | overflow should not occur. |
-c | REFERENCE: LAPACK subroutine dlahqr |
-c %-----------------------------------------%
-c
- unfl = dlamch( 'safe minimum' )
- ovfl = one / unfl
- call dlabad( unfl, ovfl )
- ulp = dlamch( 'precision' )
- smlnum = unfl*( n / ulp )
- first = .false.
- end if
-c
- if (ido .eq. 0) then
-c
-c %-------------------------------%
-c | Initialize timing statistics |
-c | & message level for debugging |
-c %-------------------------------%
-c
- call igraphsecond (t0)
- msglvl = mnaitr
-c
-c %------------------------------%
-c | Initial call to this routine |
-c %------------------------------%
-c
- info = 0
- step3 = .false.
- step4 = .false.
- rstart = .false.
- orth1 = .false.
- orth2 = .false.
- j = k + 1
- ipj = 1
- irj = ipj + n
- ivj = irj + n
- end if
-c
-c %-------------------------------------------------%
-c | When in reverse communication mode one of: |
-c | STEP3, STEP4, ORTH1, ORTH2, RSTART |
-c | will be .true. when .... |
-c | STEP3: return from computing OP*v_{j}. |
-c | STEP4: return from computing B-norm of OP*v_{j} |
-c | ORTH1: return from computing B-norm of r_{j+1} |
-c | ORTH2: return from computing B-norm of |
-c | correction to the residual vector. |
-c | RSTART: return from OP computations needed by |
-c | igraphdgetv0. |
-c %-------------------------------------------------%
-c
- if (step3) go to 50
- if (step4) go to 60
- if (orth1) go to 70
- if (orth2) go to 90
- if (rstart) go to 30
-c
-c %-----------------------------%
-c | Else this is the first step |
-c %-----------------------------%
-c
-c %--------------------------------------------------------------%
-c | |
-c | A R N O L D I I T E R A T I O N L O O P |
-c | |
-c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) |
-c %--------------------------------------------------------------%
-
- 1000 continue
-c
- if (msglvl .gt. 1) then
- call igraphivout (logfil, 1, [j], ndigit,
- & '_naitr: generating Arnoldi vector number')
- call igraphdvout (logfil, 1, [rnorm], ndigit,
- & '_naitr: B-norm of the current residual is')
- end if
-c
-c %---------------------------------------------------%
-c | STEP 1: Check if the B norm of j-th residual |
-c | vector is zero. Equivalent to determing whether |
-c | an exact j-step Arnoldi factorization is present. |
-c %---------------------------------------------------%
-c
- betaj = rnorm
- if (rnorm .gt. zero) go to 40
-c
-c %---------------------------------------------------%
-c | Invariant subspace found, generate a new starting |
-c | vector which is orthogonal to the current Arnoldi |
-c | basis and continue the iteration. |
-c %---------------------------------------------------%
-c
- if (msglvl .gt. 0) then
- call igraphivout (logfil, 1, [j], ndigit,
- & '_naitr: ****** RESTART AT STEP ******')
- end if
-c
-c %---------------------------------------------%
-c | ITRY is the loop variable that controls the |
-c | maximum amount of times that a restart is |
-c | attempted. NRSTRT is used by stat.h |
-c %---------------------------------------------%
-c
- betaj = zero
- nrstrt = nrstrt + 1
- itry = 1
- 20 continue
- rstart = .true.
- ido = 0
- 30 continue
-c
-c %--------------------------------------%
-c | If in reverse communication mode and |
-c | RSTART = .true. flow returns here. |
-c %--------------------------------------%
-c
- call igraphdgetv0 (ido, bmat, itry, .false., n, j, v, ldv,
- & resid, rnorm, ipntr, workd, ierr)
- if (ido .ne. 99) go to 9000
- if (ierr .lt. 0) then
- itry = itry + 1
- if (itry .le. 3) go to 20
-c
-c %------------------------------------------------%
-c | Give up after several restart attempts. |
-c | Set INFO to the size of the invariant subspace |
-c | which spans OP and exit. |
-c %------------------------------------------------%
-c
- info = j - 1
- call igraphsecond (t1)
- tnaitr = tnaitr + (t1 - t0)
- ido = 99
- go to 9000
- end if
-c
- 40 continue
-c
-c %---------------------------------------------------------%
-c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm |
-c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow |
-c | when reciprocating a small RNORM, test against lower |
-c | machine bound. |
-c %---------------------------------------------------------%
-c
- call dcopy (n, resid, 1, v(1,j), 1)
- if (rnorm .ge. unfl) then
- temp1 = one / rnorm
- call dscal (n, temp1, v(1,j), 1)
- call dscal (n, temp1, workd(ipj), 1)
- else
-c
-c %-----------------------------------------%
-c | To scale both v_{j} and p_{j} carefully |
-c | use LAPACK routine SLASCL |
-c %-----------------------------------------%
-c
- call dlascl ('General', i, i, rnorm, one, n, 1,
- & v(1,j), n, infol)
- call dlascl ('General', i, i, rnorm, one, n, 1,
- & workd(ipj), n, infol)
- end if
-c
-c %------------------------------------------------------%
-c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} |
-c | Note that this is not quite yet r_{j}. See STEP 4 |
-c %------------------------------------------------------%
-c
- step3 = .true.
- nopx = nopx + 1
- call igraphsecond (t2)
- call dcopy (n, v(1,j), 1, workd(ivj), 1)
- ipntr(1) = ivj
- ipntr(2) = irj
- ipntr(3) = ipj
- ido = 1
-c
-c %-----------------------------------%
-c | Exit in order to compute OP*v_{j} |
-c %-----------------------------------%
-c
- go to 9000
- 50 continue
-c
-c %----------------------------------%
-c | Back from reverse communication; |
-c | WORKD(IRJ:IRJ+N-1) := OP*v_{j} |
-c | if step3 = .true. |
-c %----------------------------------%
-c
- call igraphsecond (t3)
- tmvopx = tmvopx + (t3 - t2)
-
- step3 = .false.
-c
-c %------------------------------------------%
-c | Put another copy of OP*v_{j} into RESID. |
-c %------------------------------------------%
-c
- call dcopy (n, workd(irj), 1, resid, 1)
-c
-c %---------------------------------------%
-c | STEP 4: Finish extending the Arnoldi |
-c | factorization to length j. |
-c %---------------------------------------%
-c
- call igraphsecond (t2)
- if (bmat .eq. 'G') then
- nbx = nbx + 1
- step4 = .true.
- ipntr(1) = irj
- ipntr(2) = ipj
- ido = 2
-c
-c %-------------------------------------%
-c | Exit in order to compute B*OP*v_{j} |
-c %-------------------------------------%
-c
- go to 9000
- else if (bmat .eq. 'I') then
- call dcopy (n, resid, 1, workd(ipj), 1)
- end if
- 60 continue
-c
-c %----------------------------------%
-c | Back from reverse communication; |
-c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} |
-c | if step4 = .true. |
-c %----------------------------------%
-c
- if (bmat .eq. 'G') then
- call igraphsecond (t3)
- tmvbx = tmvbx + (t3 - t2)
- end if
-c
- step4 = .false.
-c
-c %-------------------------------------%
-c | The following is needed for STEP 5. |
-c | Compute the B-norm of OP*v_{j}. |
-c %-------------------------------------%
-c
- if (bmat .eq. 'G') then
- wnorm = ddot (n, resid, 1, workd(ipj), 1)
- wnorm = sqrt(abs(wnorm))
- else if (bmat .eq. 'I') then
- wnorm = dnrm2(n, resid, 1)
- end if
-c
-c %-----------------------------------------%
-c | Compute the j-th residual corresponding |
-c | to the j step factorization. |
-c | Use Classical Gram Schmidt and compute: |
-c | w_{j} <- V_{j}^T * B * OP * v_{j} |
-c | r_{j} <- OP*v_{j} - V_{j} * w_{j} |
-c %-----------------------------------------%
-c
-c
-c %------------------------------------------%
-c | Compute the j Fourier coefficients w_{j} |
-c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. |
-c %------------------------------------------%
-c
- call dgemv ('T', n, j, one, v, ldv, workd(ipj), 1,
- & zero, h(1,j), 1)
-c
-c %--------------------------------------%
-c | Orthogonalize r_{j} against V_{j}. |
-c | RESID contains OP*v_{j}. See STEP 3. |
-c %--------------------------------------%
-c
- call dgemv ('N', n, j, -one, v, ldv, h(1,j), 1,
- & one, resid, 1)
-c
- if (j .gt. 1) h(j,j-1) = betaj
-c
- call igraphsecond (t4)
-c
- orth1 = .true.
-c
- call igraphsecond (t2)
- if (bmat .eq. 'G') then
- nbx = nbx + 1
- call dcopy (n, resid, 1, workd(irj), 1)
- ipntr(1) = irj
- ipntr(2) = ipj
- ido = 2
-c
-c %----------------------------------%
-c | Exit in order to compute B*r_{j} |
-c %----------------------------------%
-c
- go to 9000
- else if (bmat .eq. 'I') then
- call dcopy (n, resid, 1, workd(ipj), 1)
- end if
- 70 continue
-c
-c %---------------------------------------------------%
-c | Back from reverse communication if ORTH1 = .true. |
-c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. |
-c %---------------------------------------------------%
-c
- if (bmat .eq. 'G') then
- call igraphsecond (t3)
- tmvbx = tmvbx + (t3 - t2)
- end if
-c
- orth1 = .false.
-c
-c %------------------------------%
-c | Compute the B-norm of r_{j}. |
-c %------------------------------%
-c
- if (bmat .eq. 'G') then
- rnorm = ddot (n, resid, 1, workd(ipj), 1)
- rnorm = sqrt(abs(rnorm))
- else if (bmat .eq. 'I') then
- rnorm = dnrm2(n, resid, 1)
- end if
-c
-c %-----------------------------------------------------------%
-c | STEP 5: Re-orthogonalization / Iterative refinement phase |
-c | Maximum NITER_ITREF tries. |
-c | |
-c | s = V_{j}^T * B * r_{j} |
-c | r_{j} = r_{j} - V_{j}*s |
-c | alphaj = alphaj + s_{j} |
-c | |
-c | The stopping criteria used for iterative refinement is |
-c | discussed in Parlett's book SEP, page 107 and in Gragg & |
-c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. |
-c | Determine if we need to correct the residual. The goal is |
-c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || |
-c | The following test determines whether the sine of the |
-c | angle between OP*x and the computed residual is less |
-c | than or equal to 0.717. |
-c %-----------------------------------------------------------%
-c
- if (rnorm .gt. 0.717*wnorm) go to 100
- iter = 0
- nrorth = nrorth + 1
-c
-c %---------------------------------------------------%
-c | Enter the Iterative refinement phase. If further |
-c | refinement is necessary, loop back here. The loop |
-c | variable is ITER. Perform a step of Classical |
-c | Gram-Schmidt using all the Arnoldi vectors V_{j} |
-c %---------------------------------------------------%
-c
- 80 continue
-c
- if (msglvl .gt. 2) then
- xtemp(1) = wnorm
- xtemp(2) = rnorm
- call igraphdvout (logfil, 2, xtemp, ndigit,
- & '_naitr: re-orthonalization; wnorm and rnorm are')
- call igraphdvout (logfil, j, h(1,j), ndigit,
- & '_naitr: j-th column of H')
- end if
-c
-c %----------------------------------------------------%
-c | Compute V_{j}^T * B * r_{j}. |
-c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). |
-c %----------------------------------------------------%
-c
- call dgemv ('T', n, j, one, v, ldv, workd(ipj), 1,
- & zero, workd(irj), 1)
-c
-c %---------------------------------------------%
-c | Compute the correction to the residual: |
-c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). |
-c | The correction to H is v(:,1:J)*H(1:J,1:J) |
-c | + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. |
-c %---------------------------------------------%
-c
- call dgemv ('N', n, j, -one, v, ldv, workd(irj), 1,
- & one, resid, 1)
- call daxpy (j, one, workd(irj), 1, h(1,j), 1)
-c
- orth2 = .true.
- call igraphsecond (t2)
- if (bmat .eq. 'G') then
- nbx = nbx + 1
- call dcopy (n, resid, 1, workd(irj), 1)
- ipntr(1) = irj
- ipntr(2) = ipj
- ido = 2
-c
-c %-----------------------------------%
-c | Exit in order to compute B*r_{j}. |
-c | r_{j} is the corrected residual. |
-c %-----------------------------------%
-c
- go to 9000
- else if (bmat .eq. 'I') then
- call dcopy (n, resid, 1, workd(ipj), 1)
- end if
- 90 continue
-c
-c %---------------------------------------------------%
-c | Back from reverse communication if ORTH2 = .true. |
-c %---------------------------------------------------%
-c
- if (bmat .eq. 'G') then
- call igraphsecond (t3)
- tmvbx = tmvbx + (t3 - t2)
- end if
-c
-c %-----------------------------------------------------%
-c | Compute the B-norm of the corrected residual r_{j}. |
-c %-----------------------------------------------------%
-c
- if (bmat .eq. 'G') then
- rnorm1 = ddot (n, resid, 1, workd(ipj), 1)
- rnorm1 = sqrt(abs(rnorm1))
- else if (bmat .eq. 'I') then
- rnorm1 = dnrm2(n, resid, 1)
- end if
-c
- if (msglvl .gt. 0 .and. iter .gt. 0) then
- call igraphivout (logfil, 1, [j], ndigit,
- & '_naitr: Iterative refinement for Arnoldi residual')
- if (msglvl .gt. 2) then
- xtemp(1) = rnorm
- xtemp(2) = rnorm1
- call igraphdvout (logfil, 2, xtemp, ndigit,
- & '_naitr: iterative refinement ; rnorm and rnorm1 are')
- end if
- end if
-c
-c %-----------------------------------------%
-c | Determine if we need to perform another |
-c | step of re-orthogonalization. |
-c %-----------------------------------------%
-c
- if (rnorm1 .gt. 0.717*rnorm) then
-c
-c %---------------------------------------%
-c | No need for further refinement. |
-c | The cosine of the angle between the |
-c | corrected residual vector and the old |
-c | residual vector is greater than 0.717 |
-c | In other words the corrected residual |
-c | and the old residual vector share an |
-c | angle of less than arcCOS(0.717) |
-c %---------------------------------------%
-c
- rnorm = rnorm1
-c
- else
-c
-c %-------------------------------------------%
-c | Another step of iterative refinement step |
-c | is required. NITREF is used by stat.h |
-c %-------------------------------------------%
-c
- nitref = nitref + 1
- rnorm = rnorm1
- iter = iter + 1
- if (iter .le. 1) go to 80
-c
-c %-------------------------------------------------%
-c | Otherwise RESID is numerically in the span of V |
-c %-------------------------------------------------%
-c
- do 95 jj = 1, n
- resid(jj) = zero
- 95 continue
- rnorm = zero
- end if
-c
-c %----------------------------------------------%
-c | Branch here directly if iterative refinement |
-c | wasn't necessary or after at most NITER_REF |
-c | steps of iterative refinement. |
-c %----------------------------------------------%
-c
- 100 continue
-c
- rstart = .false.
- orth2 = .false.
-c
- call igraphsecond (t5)
- titref = titref + (t5 - t4)
-c
-c %------------------------------------%
-c | STEP 6: Update j = j+1; Continue |
-c %------------------------------------%
-c
- j = j + 1
- if (j .gt. k+np) then
- call igraphsecond (t1)
- tnaitr = tnaitr + (t1 - t0)
- ido = 99
- do 110 i = max(1,k), k+np-1
-c
-c %--------------------------------------------%
-c | Check for splitting and deflation. |
-c | Use a standard test as in the QR algorithm |
-c | REFERENCE: LAPACK subroutine dlahqr |
-c %--------------------------------------------%
-c
- tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) )
- if( tst1.eq.zero )
- & tst1 = dlanhs( '1', k+np, h, ldh, workd(n+1) )
- if( abs( h( i+1,i ) ).le.max( ulp*tst1, smlnum ) )
- & h(i+1,i) = zero
- 110 continue
-c
- if (msglvl .gt. 2) then
- call igraphdmout (logfil, k+np, k+np, h, ldh, ndigit,
- & '_naitr: Final upper Hessenberg matrix H of order K+NP')
- end if
-c
- go to 9000
- end if
-c
-c %--------------------------------------------------------%
-c | Loop back to extend the factorization by another step. |
-c %--------------------------------------------------------%
-c
- go to 1000
-c
-c %---------------------------------------------------------------%
-c | |
-c | E N D O F M A I N I T E R A T I O N L O O P |
-c | |
-c %---------------------------------------------------------------%
-c
- 9000 continue
- return
-c
-c %---------------%
-c | End of igraphdnaitr |
-c %---------------%
-c
- end
diff --git a/src/dnapps.f b/src/dnapps.f
deleted file mode 100644
index 247e66b..0000000
--- a/src/dnapps.f
+++ /dev/null
@@ -1,647 +0,0 @@
-c-----------------------------------------------------------------------
-c\BeginDoc
-c
-c\Name: igraphdnapps
-c
-c\Description:
-c Given the Arnoldi factorization
-c
-c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T,
-c
-c apply NP implicit shifts resulting in
-c
-c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q
-c
-c where Q is an orthogonal matrix which is the product of rotations
-c and reflections resulting from the NP bulge chage sweeps.
-c The updated Arnoldi factorization becomes:
-c
-c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T.
-c
-c\Usage:
-c call igraphdnapps
-c ( N, KEV, NP, SHIFTR, SHIFTI, V, LDV, H, LDH, RESID, Q, LDQ,
-c WORKL, WORKD )
-c
-c\Arguments
-c N Integer. (INPUT)
-c Problem size, i.e. size of matrix A.
-c
-c KEV Integer. (INPUT/OUTPUT)
-c KEV+NP is the size of the input matrix H.
-c KEV is the size of the updated matrix HNEW. KEV is only
-c updated on ouput when fewer than NP shifts are applied in
-c order to keep the conjugate pair together.
-c
-c NP Integer. (INPUT)
-c Number of implicit shifts to be applied.
-c
-c SHIFTR, Double precision array of length NP. (INPUT)
-c SHIFTI Real and imaginary part of the shifts to be applied.
-c Upon, entry to igraphdnapps, the shifts must be sorted so that the
-c conjugate pairs are in consecutive locations.
-c
-c V Double precision N by (KEV+NP) array. (INPUT/OUTPUT)
-c On INPUT, V contains the current KEV+NP Arnoldi vectors.
-c On OUTPUT, V contains the updated KEV Arnoldi vectors
-c in the first KEV columns of V.
-c
-c LDV Integer. (INPUT)
-c Leading dimension of V exactly as declared in the calling
-c program.
-c
-c H Double precision (KEV+NP) by (KEV+NP) array. (INPUT/OUTPUT)
-c On INPUT, H contains the current KEV+NP by KEV+NP upper
-c Hessenber matrix of the Arnoldi factorization.
-c On OUTPUT, H contains the updated KEV by KEV upper Hessenberg
-c matrix in the KEV leading submatrix.
-c
-c LDH Integer. (INPUT)
-c Leading dimension of H exactly as declared in the calling
-c program.
-c
-c RESID Double precision array of length N. (INPUT/OUTPUT)
-c On INPUT, RESID contains the the residual vector r_{k+p}.
-c On OUTPUT, RESID is the update residual vector rnew_{k}
-c in the first KEV locations.
-c
-c Q Double precision KEV+NP by KEV+NP work array. (WORKSPACE)
-c Work array used to accumulate the rotations and reflections
-c during the bulge chase sweep.
-c
-c LDQ Integer. (INPUT)
-c Leading dimension of Q exactly as declared in the calling
-c program.
-c
-c WORKL Double precision work array of length (KEV+NP). (WORKSPACE)
-c Private (replicated) array on each PE or array allocated on
-c the front end.
-c
-c WORKD Double precision work array of length 2*N. (WORKSPACE)
-c Distributed array used in the application of the accumulated
-c orthogonal matrix Q.
-c
-c\EndDoc
-c
-c-----------------------------------------------------------------------
-c
-c\BeginLib
-c
-c\Local variables:
-c xxxxxx real
-c
-c\References:
-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
-c pp 357-385.
-c
-c\Routines called:
-c igraphivout ARPACK utility routine that prints integers.
-c igraphsecond ARPACK utility routine for timing.
-c igraphdmout ARPACK utility routine that prints matrices.
-c igraphdvout ARPACK utility routine that prints vectors.
-c dlabad LAPACK routine that computes machine constants.
-c dlacpy LAPACK matrix copy routine.
-c dlamch LAPACK routine that determines machine constants.
-c dlanhs LAPACK routine that computes various norms of a matrix.
-c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully.
-c dlarf LAPACK routine that applies Householder reflection to
-c a matrix.
-c dlarfg LAPACK Householder reflection construction routine.
-c dlartg LAPACK Givens rotation construction routine.
-c dlaset LAPACK matrix initialization routine.
-c dgemv Level 2 BLAS routine for matrix vector multiplication.
-c daxpy Level 1 BLAS that computes a vector triad.
-c dcopy Level 1 BLAS that copies one vector to another .
-c dscal Level 1 BLAS that scales a vector.
-c
-c\Author
-c Danny Sorensen Phuong Vu
-c Richard Lehoucq CRPC / Rice University
-c Dept. of Computational & Houston, Texas
-c Applied Mathematics
-c Rice University
-c Houston, Texas
-c
-c\Revision history:
-c xx/xx/92: Version ' 2.1'
-c
-c\SCCS Information: @(#)
-c FILE: napps.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2
-c
-c\Remarks
-c 1. In this version, each shift is applied to all the sublocks of
-c the Hessenberg matrix H and not just to the submatrix that it
-c comes from. Deflation as in LAPACK routine dlahqr (QR algorithm
-c for upper Hessenberg matrices ) is used.
-c The subdiagonals of H are enforced to be non-negative.
-c
-c\EndLib
-c
-c-----------------------------------------------------------------------
-c
- subroutine igraphdnapps
- & ( n, kev, np, shiftr, shifti, v, ldv, h, ldh, resid, q, ldq,
- & workl, workd )
-c
-c %----------------------------------------------------%
-c | Include files for debugging and timing information |
-c %----------------------------------------------------%
-c
- include 'debug.h'
- include 'stat.h'
-c
-c %------------------%
-c | Scalar Arguments |
-c %------------------%
-c
- integer kev, ldh, ldq, ldv, n, np
-c
-c %-----------------%
-c | Array Arguments |
-c %-----------------%
-c
- Double precision
- & h(ldh,kev+np), resid(n), shifti(np), shiftr(np),
- & v(ldv,kev+np), q(ldq,kev+np), workd(2*n), workl(kev+np)
-c
-c %------------%
-c | Parameters |
-c %------------%
-c
- Double precision
- & one, zero
- parameter (one = 1.0D+0, zero = 0.0D+0)
-c
-c %------------------------%
-c | Local Scalars & Arrays |
-c %------------------------%
-c
- integer i, iend, ir, istart, j, jj, kplusp, msglvl, nr
- logical cconj, first
- Double precision
- & c, f, g, h11, h12, h21, h22, h32, ovfl, r, s, sigmai,
- & sigmar, smlnum, ulp, unfl, u(3), t, tau, tst1
- save first, ovfl, smlnum, ulp, unfl
-c
-c %----------------------%
-c | External Subroutines |
-c %----------------------%
-c
- external daxpy, dcopy, dscal, dlacpy, dlarfg, dlarf,
- & dlaset, dlabad, igraphsecond, dlartg
-c
-c %--------------------%
-c | External Functions |
-c %--------------------%
-c
- Double precision
- & dlamch, dlanhs, dlapy2
- external dlamch, dlanhs, dlapy2
-c
-c %----------------------%
-c | Intrinsics Functions |
-c %----------------------%
-c
- intrinsic abs, max, min
-c
-c %----------------%
-c | Data statments |
-c %----------------%
-c
- data first / .true. /
-c
-c %-----------------------%
-c | Executable Statements |
-c %-----------------------%
-c
- if (first) then
-c
-c %-----------------------------------------------%
-c | Set machine-dependent constants for the |
-c | stopping criterion. If norm(H) <= sqrt(OVFL), |
-c | overflow should not occur. |
-c | REFERENCE: LAPACK subroutine dlahqr |
-c %-----------------------------------------------%
-c
- unfl = dlamch( 'safe minimum' )
- ovfl = one / unfl
- call dlabad( unfl, ovfl )
- ulp = dlamch( 'precision' )
- smlnum = unfl*( n / ulp )
- first = .false.
- end if
-c
-c %-------------------------------%
-c | Initialize timing statistics |
-c | & message level for debugging |
-c %-------------------------------%
-c
- call igraphsecond (t0)
- msglvl = mnapps
- kplusp = kev + np
-c
-c %--------------------------------------------%
-c | Initialize Q to the identity to accumulate |
-c | the rotations and reflections |
-c %--------------------------------------------%
-c
- call dlaset ('All', kplusp, kplusp, zero, one, q, ldq)
-c
-c %----------------------------------------------%
-c | Quick return if there are no shifts to apply |
-c %----------------------------------------------%
-c
- if (np .eq. 0) go to 9000
-c
-c %----------------------------------------------%
-c | Chase the bulge with the application of each |
-c | implicit shift. Each shift is applied to the |
-c | whole matrix including each block. |
-c %----------------------------------------------%
-c
- cconj = .false.
- do 110 jj = 1, np
- sigmar = shiftr(jj)
- sigmai = shifti(jj)
-c
- if (msglvl .gt. 2 ) then
- call igraphivout (logfil, 1, [jj], ndigit,
- & '_napps: shift number.')
- call igraphdvout (logfil, 1, [sigmar], ndigit,
- & '_napps: The real part of the shift ')
- call igraphdvout (logfil, 1, [sigmai], ndigit,
- & '_napps: The imaginary part of the shift ')
- end if
-c
-c %-------------------------------------------------%
-c | The following set of conditionals is necessary |
-c | in order that complex conjugate pairs of shifts |
-c | are applied together or not at all. |
-c %-------------------------------------------------%
-c
- if ( cconj ) then
-c
-c %-----------------------------------------%
-c | cconj = .true. means the previous shift |
-c | had non-zero imaginary part. |
-c %-----------------------------------------%
-c
- cconj = .false.
- go to 110
- else if ( jj .lt. np .and. abs( sigmai ) .gt. zero ) then
-c
-c %------------------------------------%
-c | Start of a complex conjugate pair. |
-c %------------------------------------%
-c
- cconj = .true.
- else if ( jj .eq. np .and. abs( sigmai ) .gt. zero ) then
-c
-c %----------------------------------------------%
-c | The last shift has a nonzero imaginary part. |
-c | Don't apply it; thus the order of the |
-c | compressed H is order KEV+1 since only np-1 |
-c | were applied. |
-c %----------------------------------------------%
-c
- kev = kev + 1
- go to 110
- end if
- istart = 1
- 20 continue
-c
-c %--------------------------------------------------%
-c | if sigmai = 0 then |
-c | Apply the jj-th shift ... |
-c | else |
-c | Apply the jj-th and (jj+1)-th together ... |
-c | (Note that jj < np at this point in the code) |
-c | end |
-c | to the current block of H. The next do loop |
-c | determines the current block ; |
-c %--------------------------------------------------%
-c
- do 30 i = istart, kplusp-1
-c
-c %----------------------------------------%
-c | Check for splitting and deflation. Use |
-c | a standard test as in the QR algorithm |
-c | REFERENCE: LAPACK subroutine dlahqr |
-c %----------------------------------------%
-c
- tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) )
- if( tst1.eq.zero )
- & tst1 = dlanhs( '1', kplusp-jj+1, h, ldh, workl )
- if( abs( h( i+1,i ) ).le.max( ulp*tst1, smlnum ) ) then
- if (msglvl .gt. 0) then
- call igraphivout (logfil, 1, [i], ndigit,
- & '_napps: matrix splitting at row/column no.')
- call igraphivout (logfil, 1, [jj], ndigit,
- & '_napps: matrix splitting with shift number.')
- call igraphdvout (logfil, 1, h(i+1,i), ndigit,
- & '_napps: off diagonal element.')
- end if
- iend = i
- h(i+1,i) = zero
- go to 40
- end if
- 30 continue
- iend = kplusp
- 40 continue
-c
- if (msglvl .gt. 2) then
- call igraphivout (logfil, 1, [istart], ndigit,
- & '_napps: Start of current block ')
- call igraphivout (logfil, 1, [iend], ndigit,
- & '_napps: End of current block ')
- end if
-c
-c %------------------------------------------------%
-c | No reason to apply a shift to block of order 1 |
-c %------------------------------------------------%
-c
- if ( istart .eq. iend ) go to 100
-c
-c %------------------------------------------------------%
-c | If istart + 1 = iend then no reason to apply a |
-c | complex conjugate pair of shifts on a 2 by 2 matrix. |
-c %------------------------------------------------------%
-c
- if ( istart + 1 .eq. iend .and. abs( sigmai ) .gt. zero )
- & go to 100
-c
- h11 = h(istart,istart)
- h21 = h(istart+1,istart)
- if ( abs( sigmai ) .le. zero ) then
-c
-c %---------------------------------------------%
-c | Real-valued shift ==> apply single shift QR |
-c %---------------------------------------------%
-c
- f = h11 - sigmar
- g = h21
-c
- do 80 i = istart, iend-1
-c
-c %-----------------------------------------------------%
-c | Contruct the plane rotation G to zero out the bulge |
-c %-----------------------------------------------------%
-c
- call dlartg (f, g, c, s, r)
- if (i .gt. istart) then
-c
-c %-------------------------------------------%
-c | The following ensures that h(1:iend-1,1), |
-c | the first iend-2 off diagonal of elements |
-c | H, remain non negative. |
-c %-------------------------------------------%
-c
- if (r .lt. zero) then
- r = -r
- c = -c
- s = -s
- end if
- h(i,i-1) = r
- h(i+1,i-1) = zero
- end if
-c
-c %---------------------------------------------%
-c | Apply rotation to the left of H; H <- G'*H |
-c %---------------------------------------------%
-c
- do 50 j = i, kplusp
- t = c*h(i,j) + s*h(i+1,j)
- h(i+1,j) = -s*h(i,j) + c*h(i+1,j)
- h(i,j) = t
- 50 continue
-c
-c %---------------------------------------------%
-c | Apply rotation to the right of H; H <- H*G |
-c %---------------------------------------------%
-c
- do 60 j = 1, min(i+2,iend)
- t = c*h(j,i) + s*h(j,i+1)
- h(j,i+1) = -s*h(j,i) + c*h(j,i+1)
- h(j,i) = t
- 60 continue
-c
-c %----------------------------------------------------%
-c | Accumulate the rotation in the matrix Q; Q <- Q*G |
-c %----------------------------------------------------%
-c
- do 70 j = 1, min( j+jj, kplusp )
- t = c*q(j,i) + s*q(j,i+1)
- q(j,i+1) = - s*q(j,i) + c*q(j,i+1)
- q(j,i) = t
- 70 continue
-c
-c %---------------------------%
-c | Prepare for next rotation |
-c %---------------------------%
-c
- if (i .lt. iend-1) then
- f = h(i+1,i)
- g = h(i+2,i)
- end if
- 80 continue
-c
-c %-----------------------------------%
-c | Finished applying the real shift. |
-c %-----------------------------------%
-c
- else
-c
-c %----------------------------------------------------%
-c | Complex conjugate shifts ==> apply double shift QR |
-c %----------------------------------------------------%
-c
- h12 = h(istart,istart+1)
- h22 = h(istart+1,istart+1)
- h32 = h(istart+2,istart+1)
-c
-c %---------------------------------------------------------%
-c | Compute 1st column of (H - shift*I)*(H - conj(shift)*I) |
-c %---------------------------------------------------------%
-c
- s = 2.0*sigmar
- t = dlapy2 ( sigmar, sigmai )
- u(1) = ( h11 * (h11 - s) + t * t ) / h21 + h12
- u(2) = h11 + h22 - s
- u(3) = h32
-c
- do 90 i = istart, iend-1
-c
- nr = min ( 3, iend-i+1 )
-c
-c %-----------------------------------------------------%
-c | Construct Householder reflector G to zero out u(1). |
-c | G is of the form I - tau*( 1 u )' * ( 1 u' ). |
-c %-----------------------------------------------------%
-c
- call dlarfg ( nr, u(1), u(2), 1, tau )
-c
- if (i .gt. istart) then
- h(i,i-1) = u(1)
- h(i+1,i-1) = zero
- if (i .lt. iend-1) h(i+2,i-1) = zero
- end if
- u(1) = one
-c
-c %--------------------------------------%
-c | Apply the reflector to the left of H |
-c %--------------------------------------%
-c
- call dlarf ('Left', nr, kplusp-i+1, u, 1, tau,
- & h(i,i), ldh, workl)
-c
-c %---------------------------------------%
-c | Apply the reflector to the right of H |
-c %---------------------------------------%
-c
- ir = min ( i+3, iend )
- call dlarf ('Right', ir, nr, u, 1, tau,
- & h(1,i), ldh, workl)
-c
-c %-----------------------------------------------------%
-c | Accumulate the reflector in the matrix Q; Q <- Q*G |
-c %-----------------------------------------------------%
-c
- call dlarf ('Right', kplusp, nr, u, 1, tau,
- & q(1,i), ldq, workl)
-c
-c %----------------------------%
-c | Prepare for next reflector |
-c %----------------------------%
-c
- if (i .lt. iend-1) then
- u(1) = h(i+1,i)
- u(2) = h(i+2,i)
- if (i .lt. iend-2) u(3) = h(i+3,i)
- end if
-c
- 90 continue
-c
-c %--------------------------------------------%
-c | Finished applying a complex pair of shifts |
-c | to the current block |
-c %--------------------------------------------%
-c
- end if
-c
- 100 continue
-c
-c %---------------------------------------------------------%
-c | Apply the same shift to the next block if there is any. |
-c %---------------------------------------------------------%
-c
- istart = iend + 1
- if (iend .lt. kplusp) go to 20
-c
-c %---------------------------------------------%
-c | Loop back to the top to get the next shift. |
-c %---------------------------------------------%
-c
- 110 continue
-c
-c %--------------------------------------------------%
-c | Perform a similarity transformation that makes |
-c | sure that H will have non negative sub diagonals |
-c %--------------------------------------------------%
-c
- do 120 j=1,kev
- if ( h(j+1,j) .lt. zero ) then
- call dscal( kplusp-j+1, -one, h(j+1,j), ldh )
- call dscal( min(j+2, kplusp), -one, h(1,j+1), 1 )
- call dscal( min(j+np+1,kplusp), -one, q(1,j+1), 1 )
- end if
- 120 continue
-c
- do 130 i = 1, kev
-c
-c %--------------------------------------------%
-c | Final check for splitting and deflation. |
-c | Use a standard test as in the QR algorithm |
-c | REFERENCE: LAPACK subroutine dlahqr |
-c %--------------------------------------------%
-c
- tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) )
- if( tst1.eq.zero )
- & tst1 = dlanhs( '1', kev, h, ldh, workl )
- if( h( i+1,i ) .le. max( ulp*tst1, smlnum ) )
- & h(i+1,i) = zero
- 130 continue
-c
-c %-------------------------------------------------%
-c | Compute the (kev+1)-st column of (V*Q) and |
-c | temporarily store the result in WORKD(N+1:2*N). |
-c | This is needed in the residual update since we |
-c | cannot GUARANTEE that the corresponding entry |
-c | of H would be zero as in exact arithmetic. |
-c %-------------------------------------------------%
-c
- if (h(kev+1,kev) .gt. zero)
- & call dgemv ('N', n, kplusp, one, v, ldv, q(1,kev+1), 1, zero,
- & workd(n+1), 1)
-c
-c %----------------------------------------------------------%
-c | Compute column 1 to kev of (V*Q) in backward order |
-c | taking advantage of the upper Hessenberg structure of Q. |
-c %----------------------------------------------------------%
-c
- do 140 i = 1, kev
- call dgemv ('N', n, kplusp-i+1, one, v, ldv,
- & q(1,kev-i+1), 1, zero, workd, 1)
- call dcopy (n, workd, 1, v(1,kplusp-i+1), 1)
- 140 continue
-c
-c %-------------------------------------------------%
-c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). |
-c %-------------------------------------------------%
-c
- call dlacpy ('A', n, kev, v(1,kplusp-kev+1), ldv, v, ldv)
-c
-c %--------------------------------------------------------------%
-c | Copy the (kev+1)-st column of (V*Q) in the appropriate place |
-c %--------------------------------------------------------------%
-c
- if (h(kev+1,kev) .gt. zero)
- & call dcopy (n, workd(n+1), 1, v(1,kev+1), 1)
-c
-c %-------------------------------------%
-c | Update the residual vector: |
-c | r <- sigmak*r + betak*v(:,kev+1) |
-c | where |
-c | sigmak = (e_{kplusp}'*Q)*e_{kev} |
-c | betak = e_{kev+1}'*H*e_{kev} |
-c %-------------------------------------%
-c
- call dscal (n, q(kplusp,kev), resid, 1)
- if (h(kev+1,kev) .gt. zero)
- & call daxpy (n, h(kev+1,kev), v(1,kev+1), 1, resid, 1)
-c
- if (msglvl .gt. 1) then
- call igraphdvout (logfil, 1, q(kplusp,kev), ndigit,
- & '_napps: sigmak = (e_{kev+p}^T*Q)*e_{kev}')
- call igraphdvout (logfil, 1, h(kev+1,kev), ndigit,
- & '_napps: betak = e_{kev+1}^T*H*e_{kev}')
- call igraphivout (logfil, 1, [kev], ndigit,
- & '_napps: Order of the final Hessenberg matrix ')
- if (msglvl .gt. 2) then
- call igraphdmout (logfil, kev, kev, h, ldh, ndigit,
- & '_napps: updated Hessenberg matrix H for next iteration')
- end if
-c
- end if
-c
- 9000 continue
- call igraphsecond (t1)
- tnapps = tnapps + (t1 - t0)
-c
- return
-c
-c %---------------%
-c | End of igraphdnapps |
-c %---------------%
-c
- end
diff --git a/src/dnaup2.f b/src/dnaup2.f
deleted file mode 100644
index e060689..0000000
--- a/src/dnaup2.f
+++ /dev/null
@@ -1,838 +0,0 @@
-c\BeginDoc
-c
-c\Name: igraphdnaup2
-c
-c\Description:
-c Intermediate level interface called by igraphdnaupd.
-c
-c\Usage:
-c call igraphdnaup2
-c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD,
-c ISHIFT, MXITER, V, LDV, H, LDH, RITZR, RITZI, BOUNDS,
-c Q, LDQ, WORKL, IPNTR, WORKD, INFO )
-c
-c\Arguments
-c
-c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in igraphdnaupd.
-c MODE, ISHIFT, MXITER: see the definition of IPARAM in igraphdnaupd.
-c
-c NP Integer. (INPUT/OUTPUT)
-c Contains the number of implicit shifts to apply during
-c each Arnoldi iteration.
-c If ISHIFT=1, NP is adjusted dynamically at each iteration
-c to accelerate convergence and prevent stagnation.
-c This is also roughly equal to the number of matrix-vector
-c products (involving the operator OP) per Arnoldi iteration.
-c The logic for adjusting is contained within the current
-c subroutine.
-c If ISHIFT=0, NP is the number of shifts the user needs
-c to provide via reverse comunication. 0 < NP < NCV-NEV.
-c NP may be less than NCV-NEV for two reasons. The first, is
-c to keep complex conjugate pairs of "wanted" Ritz values
-c together. The igraphsecond, is that a leading block of the current
-c upper Hessenberg matrix has split off and contains "unwanted"
-c Ritz values.
-c Upon termination of the IRA iteration, NP contains the number
-c of "converged" wanted Ritz values.
-c
-c IUPD Integer. (INPUT)
-c IUPD .EQ. 0: use explicit restart instead implicit update.
-c IUPD .NE. 0: use implicit update.
-c
-c V Double precision N by (NEV+NP) array. (INPUT/OUTPUT)
-c The Arnoldi basis vectors are returned in the first NEV
-c columns of V.
-c
-c LDV Integer. (INPUT)
-c Leading dimension of V exactly as declared in the calling
-c program.
-c
-c H Double precision (NEV+NP) by (NEV+NP) array. (OUTPUT)
-c H is used to store the generated upper Hessenberg matrix
-c
-c LDH Integer. (INPUT)
-c Leading dimension of H exactly as declared in the calling
-c program.
-c
-c RITZR, Double precision arrays of length NEV+NP. (OUTPUT)
-c RITZI RITZR(1:NEV) (resp. RITZI(1:NEV)) contains the real (resp.
-c imaginary) part of the computed Ritz values of OP.
-c
-c BOUNDS Double precision array of length NEV+NP. (OUTPUT)
-c BOUNDS(1:NEV) contain the error bounds corresponding to
-c the computed Ritz values.
-c
-c Q Double precision (NEV+NP) by (NEV+NP) array. (WORKSPACE)
-c Private (replicated) work array used to accumulate the
-c rotation in the shift application step.
-c
-c LDQ Integer. (INPUT)
-c Leading dimension of Q exactly as declared in the calling
-c program.
-c
-c WORKL Double precision work array of length at least
-c (NEV+NP)**2 + 3*(NEV+NP). (INPUT/WORKSPACE)
-c Private (replicated) array on each PE or array allocated on
-c the front end. It is used in shifts calculation, shifts
-c application and convergence checking.
-c
-c On exit, the last 3*(NEV+NP) locations of WORKL contain
-c the Ritz values (real,imaginary) and associated Ritz
-c estimates of the current Hessenberg matrix. They are
-c listed in the same order as returned from igraphdneigh.
-c
-c If ISHIFT .EQ. O and IDO .EQ. 3, the first 2*NP locations
-c of WORKL are used in reverse communication to hold the user
-c supplied shifts.
-c
-c IPNTR Integer array of length 3. (OUTPUT)
-c Pointer to mark the starting locations in the WORKD for
-c vectors used by the Arnoldi iteration.
-c -------------------------------------------------------------
-c IPNTR(1): pointer to the current operand vector X.
-c IPNTR(2): pointer to the current result vector Y.
-c IPNTR(3): pointer to the vector B * X when used in the
-c shift-and-invert mode. X is the current operand.
-c -------------------------------------------------------------
-c
-c WORKD Double precision work array of length 3*N. (WORKSPACE)
-c Distributed array to be used in the basic Arnoldi iteration
-c for reverse communication. The user should not use WORKD
-c as temporary workspace during the iteration !!!!!!!!!!
-c See Data Distribution Note in DNAUPD.
-c
-c INFO Integer. (INPUT/OUTPUT)
-c If INFO .EQ. 0, a randomly initial residual vector is used.
-c If INFO .NE. 0, RESID contains the initial residual vector,
-c possibly from a previous run.
-c Error flag on output.
-c = 0: Normal return.
-c = 1: Maximum number of iterations taken.
-c All possible eigenvalues of OP has been found.
-c NP returns the number of converged Ritz values.
-c = 2: No shifts could be applied.
-c = -8: Error return from LAPACK eigenvalue calculation;
-c This should never happen.
-c = -9: Starting vector is zero.
-c = -9999: Could not build an Arnoldi factorization.
-c Size that was built in returned in NP.
-c
-c\EndDoc
-c
-c-----------------------------------------------------------------------
-c
-c\BeginLib
-c
-c\Local variables:
-c xxxxxx real
-c
-c\References:
-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
-c pp 357-385.
-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
-c Restarted Arnoldi Iteration", Rice University Technical Report
-c TR95-13, Department of Computational and Applied Mathematics.
-c
-c\Routines called:
-c igraphdgetv0 ARPACK initial vector generation routine.
-c igraphdnaitr ARPACK Arnoldi factorization routine.
-c igraphdnapps ARPACK application of implicit shifts routine.
-c igraphdnconv ARPACK convergence of Ritz values routine.
-c igraphdneigh ARPACK compute Ritz values and error bounds routine.
-c igraphdngets ARPACK reorder Ritz values and error bounds routine.
-c igraphdsortc ARPACK sorting routine.
-c igraphivout ARPACK utility routine that prints integers.
-c igraphsecond ARPACK utility routine for timing.
-c igraphdmout ARPACK utility routine that prints matrices
-c igraphdvout ARPACK utility routine that prints vectors.
-c dlamch LAPACK routine that determines machine constants.
-c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully.
-c dcopy Level 1 BLAS that copies one vector to another .
-c ddot Level 1 BLAS that computes the scalar product of two vectors.
-c dnrm2 Level 1 BLAS that computes the norm of a vector.
-c dswap Level 1 BLAS that swaps two vectors.
-c
-c\Author
-c Danny Sorensen Phuong Vu
-c Richard Lehoucq CRPC / Rice University
-c Dept. of Computational & Houston, Texas
-c Applied Mathematics
-c Rice University
-c Houston, Texas
-c
-c\SCCS Information: @(#)
-c FILE: naup2.F SID: 2.4 DATE OF SID: 7/30/96 RELEASE: 2
-c
-c\Remarks
-c 1. None
-c
-c\EndLib
-c
-c-----------------------------------------------------------------------
-c
- subroutine igraphdnaup2
- & ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd,
- & ishift, mxiter, v, ldv, h, ldh, ritzr, ritzi, bounds,
- & q, ldq, workl, ipntr, workd, info )
-c
-c %----------------------------------------------------%
-c | Include files for debugging and timing information |
-c %----------------------------------------------------%
-c
- include 'debug.h'
- include 'stat.h'
-c
-c %------------------%
-c | Scalar Arguments |
-c %------------------%
-c
- character bmat*1, which*2
- integer ido, info, ishift, iupd, mode, ldh, ldq, ldv, mxiter,
- & n, nev, np
- Double precision
- & tol
-c
-c %-----------------%
-c | Array Arguments |
-c %-----------------%
-c
- integer ipntr(13)
- Double precision
- & bounds(nev+np), h(ldh,nev+np), q(ldq,nev+np), resid(n),
- & ritzi(nev+np), ritzr(nev+np), v(ldv,nev+np),
- & workd(3*n), workl( (nev+np)*(nev+np+3) )
-c
-c %------------%
-c | Parameters |
-c %------------%
-c
- Double precision
- & one, zero
- parameter (one = 1.0D+0, zero = 0.0D+0)
-c
-c %---------------%
-c | Local Scalars |
-c %---------------%
-c
- character wprime*2
- logical cnorm, getv0, initv, update, ushift
- integer ierr, iter, j, kplusp, msglvl, nconv, nevbef, nev0,
- & np0, nptemp, numcnv
- Double precision
- & rnorm, temp, eps23
-c
-c %-----------------------%
-c | Local array arguments |
-c %-----------------------%
-c
- integer kp(4)
- save
-c
-c %----------------------%
-c | External Subroutines |
-c %----------------------%
-c
- external dcopy, igraphdgetv0, igraphdnaitr, igraphdnconv,
- & igraphdneigh, igraphdngets, igraphdnapps,
- & igraphdvout, igraphivout, igraphsecond
-c
-c %--------------------%
-c | External Functions |
-c %--------------------%
-c
- Double precision
- & ddot, dnrm2, dlapy2, dlamch
- external ddot, dnrm2, dlapy2, dlamch
-c
-c %---------------------%
-c | Intrinsic Functions |
-c %---------------------%
-c
- intrinsic min, max, abs, sqrt
-c
-c %-----------------------%
-c | Executable Statements |
-c %-----------------------%
-c
- if (ido .eq. 0) then
-c
- call igraphsecond (t0)
-c
- msglvl = mnaup2
-c
-c %-------------------------------------%
-c | Get the machine dependent constant. |
-c %-------------------------------------%
-c
- eps23 = dlamch('Epsilon-Machine')
- eps23 = eps23**(2.0D+0 / 3.0D+0)
-c
- nev0 = nev
- np0 = np
-c
-c %-------------------------------------%
-c | kplusp is the bound on the largest |
-c | Lanczos factorization built. |
-c | nconv is the current number of |
-c | "converged" eigenvlues. |
-c | iter is the counter on the current |
-c | iteration step. |
-c %-------------------------------------%
-c
- kplusp = nev + np
- nconv = 0
- iter = 0
-c
-c %---------------------------------------%
-c | Set flags for computing the first NEV |
-c | steps of the Arnoldi factorization. |
-c %---------------------------------------%
-c
- getv0 = .true.
- update = .false.
- ushift = .false.
- cnorm = .false.
-c
- if (info .ne. 0) then
-c
-c %--------------------------------------------%
-c | User provides the initial residual vector. |
-c %--------------------------------------------%
-c
- initv = .true.
- info = 0
- else
- initv = .false.
- end if
- end if
-c
-c %---------------------------------------------%
-c | Get a possibly random starting vector and |
-c | force it into the range of the operator OP. |
-c %---------------------------------------------%
-c
- 10 continue
-c
- if (getv0) then
- call igraphdgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid,
- & rnorm, ipntr, workd, info)
-c
- if (ido .ne. 99) go to 9000
-c
- if (rnorm .eq. zero) then
-c
-c %-----------------------------------------%
-c | The initial vector is zero. Error exit. |
-c %-----------------------------------------%
-c
- info = -9
- go to 1100
- end if
- getv0 = .false.
- ido = 0
- end if
-c
-c %-----------------------------------%
-c | Back from reverse communication : |
-c | continue with update step |
-c %-----------------------------------%
-c
- if (update) go to 20
-c
-c %-------------------------------------------%
-c | Back from computing user specified shifts |
-c %-------------------------------------------%
-c
- if (ushift) go to 50
-c
-c %-------------------------------------%
-c | Back from computing residual norm |
-c | at the end of the current iteration |
-c %-------------------------------------%
-c
- if (cnorm) go to 100
-c
-c %----------------------------------------------------------%
-c | Compute the first NEV steps of the Arnoldi factorization |
-c %----------------------------------------------------------%
-c
- call igraphdnaitr (ido, bmat, n, 0, nev, mode, resid, rnorm, v,
- & ldv, h, ldh, ipntr, workd, info)
-c
-c %---------------------------------------------------%
-c | ido .ne. 99 implies use of reverse communication |
-c | to compute operations involving OP and possibly B |
-c %---------------------------------------------------%
-c
- if (ido .ne. 99) go to 9000
-c
- if (info .gt. 0) then
- np = info
- mxiter = iter
- info = -9999
- go to 1200
- end if
-c
-c %--------------------------------------------------------------%
-c | |
-c | M A I N ARNOLDI I T E R A T I O N L O O P |
-c | Each iteration implicitly restarts the Arnoldi |
-c | factorization in place. |
-c | |
-c %--------------------------------------------------------------%
-c
- 1000 continue
-c
- iter = iter + 1
-c
- if (msglvl .gt. 0) then
- call igraphivout (logfil, 1, [iter], ndigit,
- & '_naup2: **** Start of major iteration number ****')
- end if
-c
-c %-----------------------------------------------------------%
-c | Compute NP additional steps of the Arnoldi factorization. |
-c | Adjust NP since NEV might have been updated by last call |
-c | to the shift application routine igraphdnapps. |
-c %-----------------------------------------------------------%
-c
- np = kplusp - nev
-c
- if (msglvl .gt. 1) then
- call igraphivout (logfil, 1, [nev], ndigit,
- & '_naup2: The length of the current Arnoldi factorization')
- call igraphivout (logfil, 1, [np], ndigit,
- & '_naup2: Extend the Arnoldi factorization by')
- end if
-c
-c %-----------------------------------------------------------%
-c | Compute NP additional steps of the Arnoldi factorization. |
-c %-----------------------------------------------------------%
-c
- ido = 0
- 20 continue
- update = .true.
-c
- call igraphdnaitr (ido, bmat, n, nev, np, mode, resid, rnorm,
- & v, ldv, h, ldh, ipntr, workd, info)
-c
-c %---------------------------------------------------%
-c | ido .ne. 99 implies use of reverse communication |
-c | to compute operations involving OP and possibly B |
-c %---------------------------------------------------%
-c
- if (ido .ne. 99) go to 9000
-c
- if (info .gt. 0) then
- np = info
- mxiter = iter
- info = -9999
- go to 1200
- end if
- update = .false.
-c
- if (msglvl .gt. 1) then
- call igraphdvout (logfil, 1, [rnorm], ndigit,
- & '_naup2: Corresponding B-norm of the residual')
- end if
-c
-c %--------------------------------------------------------%
-c | Compute the eigenvalues and corresponding error bounds |
-c | of the current upper Hessenberg matrix. |
-c %--------------------------------------------------------%
-c
- call igraphdneigh (rnorm, kplusp, h, ldh, ritzr, ritzi, bounds,
- & q, ldq, workl, ierr)
-c
- if (ierr .ne. 0) then
- info = -8
- go to 1200
- end if
-c
-c %----------------------------------------------------%
-c | Make a copy of eigenvalues and corresponding error |
-c | bounds obtained from igraphdneigh. |
-c %----------------------------------------------------%
-c
- call dcopy(kplusp, ritzr, 1, workl(kplusp**2+1), 1)
- call dcopy(kplusp, ritzi, 1, workl(kplusp**2+kplusp+1), 1)
- call dcopy(kplusp, bounds, 1, workl(kplusp**2+2*kplusp+1), 1)
-c
-c %---------------------------------------------------%
-c | Select the wanted Ritz values and their bounds |
-c | to be used in the convergence test. |
-c | The wanted part of the spectrum and corresponding |
-c | error bounds are in the last NEV loc. of RITZR, |
-c | RITZI and BOUNDS respectively. The variables NEV |
-c | and NP may be updated if the NEV-th wanted Ritz |
-c | value has a non zero imaginary part. In this case |
-c | NEV is increased by one and NP decreased by one. |
-c | NOTE: The last two arguments of igraphdngets are no |
-c | longer used as of version 2.1. |
-c %---------------------------------------------------%
-c
- nev = nev0
- np = np0
- numcnv = nev
- call igraphdngets (ishift, which, nev, np, ritzr, ritzi,
- & bounds, workl, workl(np+1))
- if (nev .eq. nev0+1) numcnv = nev0+1
-c
-c %-------------------%
-c | Convergence test. |
-c %-------------------%
-c
- call dcopy (nev, bounds(np+1), 1, workl(2*np+1), 1)
- call igraphdnconv (nev, ritzr(np+1), ritzi(np+1),
- & workl(2*np+1), tol, nconv)
-c
- if (msglvl .gt. 2) then
- kp(1) = nev
- kp(2) = np
- kp(3) = numcnv
- kp(4) = nconv
- call igraphivout (logfil, 4, kp, ndigit,
- & '_naup2: NEV, NP, NUMCNV, NCONV are')
- call igraphdvout (logfil, kplusp, ritzr, ndigit,
- & '_naup2: Real part of the eigenvalues of H')
- call igraphdvout (logfil, kplusp, ritzi, ndigit,
- & '_naup2: Imaginary part of the eigenvalues of H')
- call igraphdvout (logfil, kplusp, bounds, ndigit,
- & '_naup2: Ritz estimates of the current NCV Ritz values')
- end if
-c
-c %---------------------------------------------------------%
-c | Count the number of unwanted Ritz values that have zero |
-c | Ritz estimates. If any Ritz estimates are equal to zero |
-c | then a leading block of H of order equal to at least |
-c | the number of Ritz values with zero Ritz estimates has |
-c | split off. None of these Ritz values may be removed by |
-c | shifting. Decrease NP the number of shifts to apply. If |
-c | no shifts may be applied, then prepare to exit |
-c %---------------------------------------------------------%
-c
- nptemp = np
- do 30 j=1, nptemp
- if (bounds(j) .eq. zero) then
- np = np - 1
- nev = nev + 1
- end if
- 30 continue
-c
- if ( (nconv .ge. numcnv) .or.
- & (iter .gt. mxiter) .or.
- & (np .eq. 0) ) then
-c
- if (msglvl .gt. 4) then
- call igraphdvout(logfil, kplusp, workl(kplusp**2+1),
- & ndigit,
- & '_naup2: Real part of the eig computed by _neigh:')
- call igraphdvout(logfil, kplusp,
- & workl(kplusp**2+kplusp+1), ndigit,
- & '_naup2: Imag part of the eig computed by _neigh:')
- call igraphdvout(logfil, kplusp,
- & workl(kplusp**2+kplusp*2+1), ndigit,
- & '_naup2: Ritz eistmates computed by _neigh:')
- end if
-c
-c %------------------------------------------------%
-c | Prepare to exit. Put the converged Ritz values |
-c | and corresponding bounds in RITZ(1:NCONV) and |
-c | BOUNDS(1:NCONV) respectively. Then sort. Be |
-c | careful when NCONV > NP |
-c %------------------------------------------------%
-c
-c %------------------------------------------%
-c | Use h( 3,1 ) as storage to communicate |
-c | rnorm to _neupd if needed |
-c %------------------------------------------%
-
- h(3,1) = rnorm
-c
-c %----------------------------------------------%
-c | To be consistent with igraphdngets, we first do a |
-c | pre-processing sort in order to keep complex |
-c | conjugate pairs together. This is similar |
-c | to the pre-processing sort used in igraphdngets |
-c | except that the sort is done in the opposite |
-c | order. |
-c %----------------------------------------------%
-c
- if (which .eq. 'LM') wprime = 'SR'
- if (which .eq. 'SM') wprime = 'LR'
- if (which .eq. 'LR') wprime = 'SM'
- if (which .eq. 'SR') wprime = 'LM'
- if (which .eq. 'LI') wprime = 'SM'
- if (which .eq. 'SI') wprime = 'LM'
-c
- call igraphdsortc (wprime, .true., kplusp, ritzr, ritzi,
- & bounds)
-c
-c %----------------------------------------------%
-c | Now sort Ritz values so that converged Ritz |
-c | values appear within the first NEV locations |
-c | of ritzr, ritzi and bounds, and the most |
-c | desired one appears at the front. |
-c %----------------------------------------------%
-c
- if (which .eq. 'LM') wprime = 'SM'
- if (which .eq. 'SM') wprime = 'LM'
- if (which .eq. 'LR') wprime = 'SR'
- if (which .eq. 'SR') wprime = 'LR'
- if (which .eq. 'LI') wprime = 'SI'
- if (which .eq. 'SI') wprime = 'LI'
-c
- call igraphdsortc(wprime, .true., kplusp, ritzr, ritzi,
- & bounds)
-c
-c %--------------------------------------------------%
-c | Scale the Ritz estimate of each Ritz value |
-c | by 1 / max(eps23,magnitude of the Ritz value). |
-c %--------------------------------------------------%
-c
- do 35 j = 1, nev0
- temp = max(eps23,dlapy2(ritzr(j),
- & ritzi(j)))
- bounds(j) = bounds(j)/temp
- 35 continue
-c
-c %----------------------------------------------------%
-c | Sort the Ritz values according to the scaled Ritz |
-c | esitmates. This will push all the converged ones |
-c | towards the front of ritzr, ritzi, bounds |
-c | (in the case when NCONV < NEV.) |
-c %----------------------------------------------------%
-c
- wprime = 'LR'
- call igraphdsortc(wprime, .true., nev0, bounds, ritzr,
- & ritzi)
-c
-c %----------------------------------------------%
-c | Scale the Ritz estimate back to its original |
-c | value. |
-c %----------------------------------------------%
-c
- do 40 j = 1, nev0
- temp = max(eps23, dlapy2(ritzr(j),
- & ritzi(j)))
- bounds(j) = bounds(j)*temp
- 40 continue
-c
-c %------------------------------------------------%
-c | Sort the converged Ritz values again so that |
-c | the "threshold" value appears at the front of |
-c | ritzr, ritzi and bound. |
-c %------------------------------------------------%
-c
- call igraphdsortc(which, .true., nconv, ritzr, ritzi,
- & bounds)
-c
- if (msglvl .gt. 1) then
- call igraphdvout (logfil, kplusp, ritzr, ndigit,
- & '_naup2: Sorted real part of the eigenvalues')
- call igraphdvout (logfil, kplusp, ritzi, ndigit,
- & '_naup2: Sorted imaginary part of the eigenvalues')
- call igraphdvout (logfil, kplusp, bounds, ndigit,
- & '_naup2: Sorted ritz estimates.')
- end if
-c
-c %------------------------------------%
-c | Max iterations have been exceeded. |
-c %------------------------------------%
-c
- if (iter .gt. mxiter .and. nconv .lt. numcnv) info = 1
-c
-c %---------------------%
-c | No shifts to apply. |
-c %---------------------%
-c
- if (np .eq. 0 .and. nconv .lt. numcnv) info = 2
-c
- np = nconv
- go to 1100
-c
- else if ( (nconv .lt. numcnv) .and. (ishift .eq. 1) ) then
-c
-c %-------------------------------------------------%
-c | Do not have all the requested eigenvalues yet. |
-c | To prevent possible stagnation, adjust the size |
-c | of NEV. |
-c %-------------------------------------------------%
-c
- nevbef = nev
- nev = nev + min(nconv, np/2)
- if (nev .eq. 1 .and. kplusp .ge. 6) then
- nev = kplusp / 2
- else if (nev .eq. 1 .and. kplusp .gt. 3) then
- nev = 2
- end if
- np = kplusp - nev
-c
-c %---------------------------------------%
-c | If the size of NEV was just increased |
-c | resort the eigenvalues. |
-c %---------------------------------------%
-c
- if (nevbef .lt. nev)
- & call igraphdngets (ishift, which, nev, np, ritzr, ritzi,
- & bounds, workl, workl(np+1))
-c
- end if
-c
- if (msglvl .gt. 0) then
- call igraphivout (logfil, 1, [nconv], ndigit,
- & '_naup2: no. of "converged" Ritz values at this iter.')
- if (msglvl .gt. 1) then
- kp(1) = nev
- kp(2) = np
- call igraphivout (logfil, 2, kp, ndigit,
- & '_naup2: NEV and NP are')
- call igraphdvout (logfil, nev, ritzr(np+1), ndigit,
- & '_naup2: "wanted" Ritz values -- real part')
- call igraphdvout (logfil, nev, ritzi(np+1), ndigit,
- & '_naup2: "wanted" Ritz values -- imag part')
- call igraphdvout (logfil, nev, bounds(np+1), ndigit,
- & '_naup2: Ritz estimates of the "wanted" values ')
- end if
- end if
-c
- if (ishift .eq. 0) then
-c
-c %-------------------------------------------------------%
-c | User specified shifts: reverse comminucation to |
-c | compute the shifts. They are returned in the first |
-c | 2*NP locations of WORKL. |
-c %-------------------------------------------------------%
-c
- ushift = .true.
- ido = 3
- go to 9000
- end if
-c
- 50 continue
-c
-c %------------------------------------%
-c | Back from reverse communication; |
-c | User specified shifts are returned |
-c | in WORKL(1:2*NP) |
-c %------------------------------------%
-c
- ushift = .false.
-c
- if ( ishift .eq. 0 ) then
-c
-c %----------------------------------%
-c | Move the NP shifts from WORKL to |
-c | RITZR, RITZI to free up WORKL |
-c | for non-exact shift case. |
-c %----------------------------------%
-c
- call dcopy (np, workl, 1, ritzr, 1)
- call dcopy (np, workl(np+1), 1, ritzi, 1)
- end if
-c
- if (msglvl .gt. 2) then
- call igraphivout (logfil, 1, [np], ndigit,
- & '_naup2: The number of shifts to apply ')
- call igraphdvout (logfil, np, ritzr, ndigit,
- & '_naup2: Real part of the shifts')
- call igraphdvout (logfil, np, ritzi, ndigit,
- & '_naup2: Imaginary part of the shifts')
- if ( ishift .eq. 1 )
- & call igraphdvout (logfil, np, bounds, ndigit,
- & '_naup2: Ritz estimates of the shifts')
- end if
-c
-c %---------------------------------------------------------%
-c | Apply the NP implicit shifts by QR bulge chasing. |
-c | Each shift is applied to the whole upper Hessenberg |
-c | matrix H. |
-c | The first 2*N locations of WORKD are used as workspace. |
-c %---------------------------------------------------------%
-c
- call igraphdnapps (n, nev, np, ritzr, ritzi, v, ldv,
- & h, ldh, resid, q, ldq, workl, workd)
-c
-c %---------------------------------------------%
-c | Compute the B-norm of the updated residual. |
-c | Keep B*RESID in WORKD(1:N) to be used in |
-c | the first step of the next call to igraphdnaitr. |
-c %---------------------------------------------%
-c
- cnorm = .true.
- call igraphsecond (t2)
- if (bmat .eq. 'G') then
- nbx = nbx + 1
- call dcopy (n, resid, 1, workd(n+1), 1)
- ipntr(1) = n + 1
- ipntr(2) = 1
- ido = 2
-c
-c %----------------------------------%
-c | Exit in order to compute B*RESID |
-c %----------------------------------%
-c
- go to 9000
- else if (bmat .eq. 'I') then
- call dcopy (n, resid, 1, workd, 1)
- end if
-c
- 100 continue
-c
-c %----------------------------------%
-c | Back from reverse communication; |
-c | WORKD(1:N) := B*RESID |
-c %----------------------------------%
-c
- if (bmat .eq. 'G') then
- call igraphsecond (t3)
- tmvbx = tmvbx + (t3 - t2)
- end if
-c
- if (bmat .eq. 'G') then
- rnorm = ddot (n, resid, 1, workd, 1)
- rnorm = sqrt(abs(rnorm))
- else if (bmat .eq. 'I') then
- rnorm = dnrm2(n, resid, 1)
- end if
- cnorm = .false.
-c
- if (msglvl .gt. 2) then
- call igraphdvout (logfil, 1, [rnorm], ndigit,
- & '_naup2: B-norm of residual for compressed factorization')
- call igraphdmout (logfil, nev, nev, h, ldh, ndigit,
- & '_naup2: Compressed upper Hessenberg matrix H')
- end if
-c
- go to 1000
-c
-c %---------------------------------------------------------------%
-c | |
-c | E N D O F M A I N I T E R A T I O N L O O P |
-c | |
-c %---------------------------------------------------------------%
-c
- 1100 continue
-c
- mxiter = iter
- nev = numcnv
-c
- 1200 continue
- ido = 99
-c
-c %------------%
-c | Error Exit |
-c %------------%
-c
- call igraphsecond (t1)
- tnaup2 = t1 - t0
-c
- 9000 continue
-c
-c %---------------%
-c | End of igraphdnaup2 |
-c %---------------%
-c
- return
- end
diff --git a/src/dnaupd.f b/src/dnaupd.f
deleted file mode 100644
index 4133022..0000000
--- a/src/dnaupd.f
+++ /dev/null
@@ -1,655 +0,0 @@
-c\BeginDoc
-c
-c\Name: igraphdnaupd
-c
-c\Description:
-c Reverse communication interface for the Implicitly Restarted Arnoldi
-c iteration. This subroutine computes approximations to a few eigenpairs
-c of a linear operator "OP" with respect to a semi-inner product defined by
-c a symmetric positive semi-definite real matrix B. B may be the identity
-c matrix. NOTE: If the linear operator "OP" is real and symmetric
-c with respect to the real positive semi-definite symmetric matrix B,
-c i.e. B*OP = (OP')*B, then subroutine ssaupd should be used instead.
-c
-c The computed approximate eigenvalues are called Ritz values and
-c the corresponding approximate eigenvectors are called Ritz vectors.
-c
-c igraphdnaupd is usually called iteratively to solve one of the
-c following problems:
-c
-c Mode 1: A*x = lambda*x.
-c ===> OP = A and B = I.
-c
-c Mode 2: A*x = lambda*M*x, M symmetric positive definite
-c ===> OP = inv[M]*A and B = M.
-c ===> (If M can be factored see remark 3 below)
-c
-c Mode 3: A*x = lambda*M*x, M symmetric semi-definite
-c ===> OP = Real_Part{ inv[A - sigma*M]*M } and B = M.
-c ===> shift-and-invert mode (in real arithmetic)
-c If OP*x = amu*x, then
-c amu = 1/2 * [ 1/(lambda-sigma) + 1/(lambda-conjg(sigma)) ].
-c Note: If sigma is real, i.e. imaginary part of sigma is zero;
-c Real_Part{ inv[A - sigma*M]*M } == inv[A - sigma*M]*M
-c amu == 1/(lambda-sigma).
-c
-c Mode 4: A*x = lambda*M*x, M symmetric semi-definite
-c ===> OP = Imaginary_Part{ inv[A - sigma*M]*M } and B = M.
-c ===> shift-and-invert mode (in real arithmetic)
-c If OP*x = amu*x, then
-c amu = 1/2i * [ 1/(lambda-sigma) - 1/(lambda-conjg(sigma)) ].
-c
-c Both mode 3 and 4 give the same enhancement to eigenvalues close to
-c the (complex) shift sigma. However, as lambda goes to infinity,
-c the operator OP in mode 4 dampens the eigenvalues more strongly than
-c does OP defined in mode 3.
-c
-c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v
-c should be accomplished either by a direct method
-c using a sparse matrix factorization and solving
-c
-c [A - sigma*M]*w = v or M*w = v,
-c
-c or through an iterative method for solving these
-c systems. If an iterative method is used, the
-c convergence test must be more stringent than
-c the accuracy requirements for the eigenvalue
-c approximations.
-c
-c\Usage:
-c call igraphdnaupd
-c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM,
-c IPNTR, WORKD, WORKL, LWORKL, INFO )
-c
-c\Arguments
-c IDO Integer. (INPUT/OUTPUT)
-c Reverse communication flag. IDO must be zero on the first
-c call to igraphdnaupd. IDO will be set internally to
-c indicate the type of operation to be performed. Control is
-c then given back to the calling routine which has the
-c responsibility to carry out the requested operation and call
-c igraphdnaupd with the result. The operand is given in
-c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)).
-c -------------------------------------------------------------
-c IDO = 0: first call to the reverse communication interface
-c IDO = -1: compute Y = OP * X where
-c IPNTR(1) is the pointer into WORKD for X,
-c IPNTR(2) is the pointer into WORKD for Y.
-c This is for the initialization phase to force the
-c starting vector into the range of OP.
-c IDO = 1: compute Y = OP * X where
-c IPNTR(1) is the pointer into WORKD for X,
-c IPNTR(2) is the pointer into WORKD for Y.
-c In mode 3 and 4, the vector B * X is already
-c available in WORKD(ipntr(3)). It does not
-c need to be recomputed in forming OP * X.
-c IDO = 2: compute Y = B * X where
-c IPNTR(1) is the pointer into WORKD for X,
-c IPNTR(2) is the pointer into WORKD for Y.
-c IDO = 3: compute the IPARAM(8) real and imaginary parts
-c of the shifts where INPTR(14) is the pointer
-c into WORKL for placing the shifts. See Remark
-c 5 below.
-c IDO = 99: done
-c -------------------------------------------------------------
-c
-c BMAT Character*1. (INPUT)
-c BMAT specifies the type of the matrix B that defines the
-c semi-inner product for the operator OP.
-c BMAT = 'I' -> standard eigenvalue problem A*x = lambda*x
-c BMAT = 'G' -> generalized eigenvalue problem A*x = lambda*B*x
-c
-c N Integer. (INPUT)
-c Dimension of the eigenproblem.
-c
-c WHICH Character*2. (INPUT)
-c 'LM' -> want the NEV eigenvalues of largest magnitude.
-c 'SM' -> want the NEV eigenvalues of smallest magnitude.
-c 'LR' -> want the NEV eigenvalues of largest real part.
-c 'SR' -> want the NEV eigenvalues of smallest real part.
-c 'LI' -> want the NEV eigenvalues of largest imaginary part.
-c 'SI' -> want the NEV eigenvalues of smallest imaginary part.
-c
-c NEV Integer. (INPUT)
-c Number of eigenvalues of OP to be computed. 0 < NEV < N-1.
-c
-c TOL Double precision scalar. (INPUT)
-c Stopping criterion: the relative accuracy of the Ritz value
-c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I))
-c where ABS(RITZ(I)) is the magnitude when RITZ(I) is complex.
-c DEFAULT = DLAMCH('EPS') (machine precision as computed
-c by the LAPACK auxiliary subroutine DLAMCH).
-c
-c RESID Double precision array of length N. (INPUT/OUTPUT)
-c On INPUT:
-c If INFO .EQ. 0, a random initial residual vector is used.
-c If INFO .NE. 0, RESID contains the initial residual vector,
-c possibly from a previous run.
-c On OUTPUT:
-c RESID contains the final residual vector.
-c
-c NCV Integer. (INPUT)
-c Number of columns of the matrix V. NCV must satisfy the two
-c inequalities 2 <= NCV-NEV and NCV <= N.
-c This will indicate how many Arnoldi vectors are generated
-c at each iteration. After the startup phase in which NEV
-c Arnoldi vectors are generated, the algorithm generates
-c approximately NCV-NEV Arnoldi vectors at each subsequent update
-c iteration. Most of the cost in generating each Arnoldi vector is
-c in the matrix-vector operation OP*x.
-c NOTE: 2 <= NCV-NEV in order that complex conjugate pairs of Ritz
-c values are kept together. (See remark 4 below)
-c
-c V Double precision array N by NCV. (OUTPUT)
-c Contains the final set of Arnoldi basis vectors.
-c
-c LDV Integer. (INPUT)
-c Leading dimension of V exactly as declared in the calling program.
-c
-c IPARAM Integer array of length 11. (INPUT/OUTPUT)
-c IPARAM(1) = ISHIFT: method for selecting the implicit shifts.
-c The shifts selected at each iteration are used to restart
-c the Arnoldi iteration in an implicit fashion.
-c -------------------------------------------------------------
-c ISHIFT = 0: the shifts are provided by the user via
-c reverse communication. The real and imaginary
-c parts of the NCV eigenvalues of the Hessenberg
-c matrix H are returned in the part of the WORKL
-c array corresponding to RITZR and RITZI. See remark
-c 5 below.
-c ISHIFT = 1: exact shifts with respect to the current
-c Hessenberg matrix H. This is equivalent to
-c restarting the iteration with a starting vector
-c that is a linear combination of approximate Schur
-c vectors associated with the "wanted" Ritz values.
-c -------------------------------------------------------------
-c
-c IPARAM(2) = No longer referenced.
-c
-c IPARAM(3) = MXITER
-c On INPUT: maximum number of Arnoldi update iterations allowed.
-c On OUTPUT: actual number of Arnoldi update iterations taken.
-c
-c IPARAM(4) = NB: blocksize to be used in the recurrence.
-c The code currently works only for NB = 1.
-c
-c IPARAM(5) = NCONV: number of "converged" Ritz values.
-c This represents the number of Ritz values that satisfy
-c the convergence criterion.
-c
-c IPARAM(6) = IUPD
-c No longer referenced. Implicit restarting is ALWAYS used.
-c
-c IPARAM(7) = MODE
-c On INPUT determines what type of eigenproblem is being solved.
-c Must be 1,2,3,4; See under \Description of igraphdnaupd for the
-c four modes available.
-c
-c IPARAM(8) = NP
-c When ido = 3 and the user provides shifts through reverse
-c communication (IPARAM(1)=0), igraphdnaupd returns NP, the number
-c of shifts the user is to provide. 0 < NP <=NCV-NEV. See Remark
-c 5 below.
-c
-c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO,
-c OUTPUT: NUMOP = total number of OP*x operations,
-c NUMOPB = total number of B*x operations if BMAT='G',
-c NUMREO = total number of steps of re-orthogonalization.
-c
-c IPNTR Integer array of length 14. (OUTPUT)
-c Pointer to mark the starting locations in the WORKD and WORKL
-c arrays for matrices/vectors used by the Arnoldi iteration.
-c -------------------------------------------------------------
-c IPNTR(1): pointer to the current operand vector X in WORKD.
-c IPNTR(2): pointer to the current result vector Y in WORKD.
-c IPNTR(3): pointer to the vector B * X in WORKD when used in
-c the shift-and-invert mode.
-c IPNTR(4): pointer to the next available location in WORKL
-c that is untouched by the program.
-c IPNTR(5): pointer to the NCV by NCV upper Hessenberg matrix
-c H in WORKL.
-c IPNTR(6): pointer to the real part of the ritz value array
-c RITZR in WORKL.
-c IPNTR(7): pointer to the imaginary part of the ritz value array
-c RITZI in WORKL.
-c IPNTR(8): pointer to the Ritz estimates in array WORKL associated
-c with the Ritz values located in RITZR and RITZI in WORKL.
-c
-c IPNTR(14): pointer to the NP shifts in WORKL. See Remark 5 below.
-c
-c Note: IPNTR(9:13) is only referenced by igraphdneupd. See Remark 2 below.
-c
-c IPNTR(9): pointer to the real part of the NCV RITZ values of the
-c original system.
-c IPNTR(10): pointer to the imaginary part of the NCV RITZ values of
-c the original system.
-c IPNTR(11): pointer to the NCV corresponding error bounds.
-c IPNTR(12): pointer to the NCV by NCV upper quasi-triangular
-c Schur matrix for H.
-c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors
-c of the upper Hessenberg matrix H. Only referenced by
-c igraphdneupd if RVEC = .TRUE. See Remark 2 below.
-c -------------------------------------------------------------
-c
-c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION)
-c Distributed array to be used in the basic Arnoldi iteration
-c for reverse communication. The user should not use WORKD
-c as temporary workspace during the iteration. Upon termination
-c WORKD(1:N) contains B*RESID(1:N). If an invariant subspace
-c associated with the converged Ritz values is desired, see remark
-c 2 below, subroutine igraphdneupd uses this output.
-c See Data Distribution Note below.
-c
-c WORKL Double precision work array of length LWORKL. (OUTPUT/WORKSPACE)
-c Private (replicated) array on each PE or array allocated on
-c the front end. See Data Distribution Note below.
-c
-c LWORKL Integer. (INPUT)
-c LWORKL must be at least 3*NCV**2 + 6*NCV.
-c
-c INFO Integer. (INPUT/OUTPUT)
-c If INFO .EQ. 0, a randomly initial residual vector is used.
-c If INFO .NE. 0, RESID contains the initial residual vector,
-c possibly from a previous run.
-c Error flag on output.
-c = 0: Normal exit.
-c = 1: Maximum number of iterations taken.
-c All possible eigenvalues of OP has been found. IPARAM(5)
-c returns the number of wanted converged Ritz values.
-c = 2: No longer an informational error. Deprecated starting
-c with release 2 of ARPACK.
-c = 3: No shifts could be applied during a cycle of the
-c Implicitly restarted Arnoldi iteration. One possibility
-c is to increase the size of NCV relative to NEV.
-c See remark 4 below.
-c = -1: N must be positive.
-c = -2: NEV must be positive.
-c = -3: NCV-NEV >= 2 and less than or equal to N.
-c = -4: The maximum number of Arnoldi update iteration
-c must be greater than zero.
-c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI'
-c = -6: BMAT must be one of 'I' or 'G'.
-c = -7: Length of private work array is not sufficient.
-c = -8: Error return from LAPACK eigenvalue calculation;
-c = -9: Starting vector is zero.
-c = -10: IPARAM(7) must be 1,2,3,4.
-c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatable.
-c = -12: IPARAM(1) must be equal to 0 or 1.
-c = -9999: Could not build an Arnoldi factorization.
-c IPARAM(5) returns the size of the current Arnoldi
-c factorization.
-c
-c\Remarks
-c 1. The computed Ritz values are approximate eigenvalues of OP. The
-c selection of WHICH should be made with this in mind when
-c Mode = 3 and 4. After convergence, approximate eigenvalues of the
-c original problem may be obtained with the ARPACK subroutine igraphdneupd.
-c
-c 2. If a basis for the invariant subspace corresponding to the converged Ritz
-c values is needed, the user must call igraphdneupd immediately following
-c completion of igraphdnaupd. This is new starting with release 2 of ARPACK.
-c
-c 3. If M can be factored into a Cholesky factorization M = LL'
-c then Mode = 2 should not be selected. Instead one should use
-c Mode = 1 with OP = inv(L)*A*inv(L'). Appropriate triangular
-c linear systems should be solved with L and L' rather
-c than computing inverses. After convergence, an approximate
-c eigenvector z of the original problem is recovered by solving
-c L'z = x where x is a Ritz vector of OP.
-c
-c 4. At present there is no a-priori analysis to guide the selection
-c of NCV relative to NEV. The only formal requrement is that NCV > NEV + 2.
-c However, it is recommended that NCV .ge. 2*NEV+1. If many problems of
-c the same type are to be solved, one should experiment with increasing
-c NCV while keeping NEV fixed for a given test problem. This will
-c usually decrease the required number of OP*x operations but it
-c also increases the work and storage required to maintain the orthogonal
-c basis vectors. The optimal "cross-over" with respect to CPU time
-c is problem dependent and must be determined empirically.
-c See Chapter 8 of Reference 2 for further information.
-c
-c 5. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the
-c NP = IPARAM(8) real and imaginary parts of the shifts in locations
-c real part imaginary part
-c ----------------------- --------------
-c 1 WORKL(IPNTR(14)) WORKL(IPNTR(14)+NP)
-c 2 WORKL(IPNTR(14)+1) WORKL(IPNTR(14)+NP+1)
-c . .
-c . .
-c . .
-c NP WORKL(IPNTR(14)+NP-1) WORKL(IPNTR(14)+2*NP-1).
-c
-c Only complex conjugate pairs of shifts may be applied and the pairs
-c must be placed in consecutive locations. The real part of the
-c eigenvalues of the current upper Hessenberg matrix are located in
-c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1) and the imaginary part
-c in WORKL(IPNTR(7)) through WORKL(IPNTR(7)+NCV-1). They are ordered
-c according to the order defined by WHICH. The complex conjugate
-c pairs are kept together and the associated Ritz estimates are located in
-c WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , WORKL(IPNTR(8)+NCV-1).
-c
-c-----------------------------------------------------------------------
-c
-c\Data Distribution Note:
-c
-c Fortran-D syntax:
-c ================
-c Double precision resid(n), v(ldv,ncv), workd(3*n), workl(lworkl)
-c decompose d1(n), d2(n,ncv)
-c align resid(i) with d1(i)
-c align v(i,j) with d2(i,j)
-c align workd(i) with d1(i) range (1:n)
-c align workd(i) with d1(i-n) range (n+1:2*n)
-c align workd(i) with d1(i-2*n) range (2*n+1:3*n)
-c distribute d1(block), d2(block,:)
-c replicated workl(lworkl)
-c
-c Cray MPP syntax:
-c ===============
-c Double precision resid(n), v(ldv,ncv), workd(n,3), workl(lworkl)
-c shared resid(block), v(block,:), workd(block,:)
-c replicated workl(lworkl)
-c
-c CM2/CM5 syntax:
-c ==============
-c
-c-----------------------------------------------------------------------
-c
-c include 'ex-nonsym.doc'
-c
-c-----------------------------------------------------------------------
-c
-c\BeginLib
-c
-c\Local variables:
-c xxxxxx real
-c
-c\References:
-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
-c pp 357-385.
-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
-c Restarted Arnoldi Iteration", Rice University Technical Report
-c TR95-13, Department of Computational and Applied Mathematics.
-c 3. B.N. Parlett & Y. Saad, "Complex Shift and Invert Strategies for
-c Real Matrices", Linear Algebra and its Applications, vol 88/89,
-c pp 575-595, (1987).
-c
-c\Routines called:
-c igraphdnaup2 ARPACK routine that implements the Implicitly Restarted
-c Arnoldi Iteration.
-c igraphivout ARPACK utility routine that prints integers.
-c igraphsecond ARPACK utility routine for timing.
-c igraphdvout ARPACK utility routine that prints vectors.
-c dlamch LAPACK routine that determines machine constants.
-c
-c\Author
-c Danny Sorensen Phuong Vu
-c Richard Lehoucq CRPC / Rice University
-c Dept. of Computational & Houston, Texas
-c Applied Mathematics
-c Rice University
-c Houston, Texas
-c
-c\Revision history:
-c 12/16/93: Version '1.1'
-c
-c\SCCS Information: @(#)
-c FILE: naupd.F SID: 2.5 DATE OF SID: 8/27/96 RELEASE: 2
-c
-c\Remarks
-c
-c\EndLib
-c
-c-----------------------------------------------------------------------
-c
- subroutine igraphdnaupd
- & ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam,
- & ipntr, workd, workl, lworkl, info )
-c
-c %----------------------------------------------------%
-c | Include files for debugging and timing information |
-c %----------------------------------------------------%
-c
- include 'debug.h'
- include 'stat.h'
-c
-c %------------------%
-c | Scalar Arguments |
-c %------------------%
-c
- character bmat*1, which*2
- integer ido, info, ldv, lworkl, n, ncv, nev
- Double precision
- & tol
-c
-c %-----------------%
-c | Array Arguments |
-c %-----------------%
-c
- integer iparam(11), ipntr(14)
- Double precision
- & resid(n), v(ldv,ncv), workd(3*n), workl(lworkl)
-c
-c %------------%
-c | Parameters |
-c %------------%
-c
- Double precision
- & one, zero
- parameter (one = 1.0D+0, zero = 0.0D+0)
-c
-c %---------------%
-c | Local Scalars |
-c %---------------%
-c
- integer bounds, ierr, ih, iq, ishift, iupd, iw,
- & ldh, ldq, levec, mode, msglvl, mxiter, nb,
- & nev0, next, np, ritzi, ritzr, j
- save bounds, ih, iq, ishift, iupd, iw, ldh, ldq,
- & levec, mode, msglvl, mxiter, nb, nev0, next,
- & np, ritzi, ritzr
-c
-c %----------------------%
-c | External Subroutines |
-c %----------------------%
-c
- external igraphdnaup2, igraphdvout, igraphivout,
- & igraphsecond, igraphdstatn
-c
-c %--------------------%
-c | External Functions |
-c %--------------------%
-c
- Double precision
- & dlamch
- external dlamch
-c
-c %-----------------------%
-c | Executable Statements |
-c %-----------------------%
-c
- if (ido .eq. 0) then
-c
-c %-------------------------------%
-c | Initialize timing statistics |
-c | & message level for debugging |
-c %-------------------------------%
-c
- call igraphdstatn
- call igraphsecond (t0)
- msglvl = mnaupd
-c
-c %----------------%
-c | Error checking |
-c %----------------%
-c
- ierr = 0
- ishift = iparam(1)
- levec = iparam(2)
- mxiter = iparam(3)
- nb = iparam(4)
-c
-c %--------------------------------------------%
-c | Revision 2 performs only implicit restart. |
-c %--------------------------------------------%
-c
- iupd = 1
- mode = iparam(7)
-c
- if (n .le. 0) then
- ierr = -1
- else if (nev .le. 0) then
- ierr = -2
- else if (ncv .le. nev+1 .or. ncv .gt. n) then
- ierr = -3
- else if (mxiter .le. 0) then
- ierr = -4
- else if (which .ne. 'LM' .and.
- & which .ne. 'SM' .and.
- & which .ne. 'LR' .and.
- & which .ne. 'SR' .and.
- & which .ne. 'LI' .and.
- & which .ne. 'SI') then
- ierr = -5
- else if (bmat .ne. 'I' .and. bmat .ne. 'G') then
- ierr = -6
- else if (lworkl .lt. 3*ncv**2 + 6*ncv) then
- ierr = -7
- else if (mode .lt. 1 .or. mode .gt. 5) then
- ierr = -10
- else if (mode .eq. 1 .and. bmat .eq. 'G') then
- ierr = -11
- else if (ishift .lt. 0 .or. ishift .gt. 1) then
- ierr = -12
- end if
-c
-c %------------%
-c | Error Exit |
-c %------------%
-c
- if (ierr .ne. 0) then
- info = ierr
- ido = 99
- go to 9000
- end if
-c
-c %------------------------%
-c | Set default parameters |
-c %------------------------%
-c
- if (nb .le. 0) nb = 1
- if (tol .le. zero) tol = dlamch('EpsMach')
-c
-c %----------------------------------------------%
-c | NP is the number of additional steps to |
-c | extend the length NEV Lanczos factorization. |
-c | NEV0 is the local variable designating the |
-c | size of the invariant subspace desired. |
-c %----------------------------------------------%
-c
- np = ncv - nev
- nev0 = nev
-c
-c %-----------------------------%
-c | Zero out internal workspace |
-c %-----------------------------%
-c
- do 10 j = 1, 3*ncv**2 + 6*ncv
- workl(j) = zero
- 10 continue
-c
-c %-------------------------------------------------------------%
-c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q |
-c | etc... and the remaining workspace. |
-c | Also update pointer to be used on output. |
-c | Memory is laid out as follows: |
-c | workl(1:ncv*ncv) := generated Hessenberg matrix |
-c | workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary |
-c | parts of ritz values |
-c | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds |
-c | workl(ncv*ncv+3*ncv+1:2*ncv*ncv+3*ncv) := rotation matrix Q |
-c | workl(2*ncv*ncv+3*ncv+1:3*ncv*ncv+6*ncv) := workspace |
-c | The final workspace is needed by subroutine igraphdneigh called |
-c | by igraphdnaup2. Subroutine igraphdneigh calls LAPACK routines for |
-c | calculating eigenvalues and the last row of the eigenvector |
-c | matrix. |
-c %-------------------------------------------------------------%
-c
- ldh = ncv
- ldq = ncv
- ih = 1
- ritzr = ih + ldh*ncv
- ritzi = ritzr + ncv
- bounds = ritzi + ncv
- iq = bounds + ncv
- iw = iq + ldq*ncv
- next = iw + ncv**2 + 3*ncv
-c
- ipntr(4) = next
- ipntr(5) = ih
- ipntr(6) = ritzr
- ipntr(7) = ritzi
- ipntr(8) = bounds
- ipntr(14) = iw
-c
- end if
-c
-c %-------------------------------------------------------%
-c | Carry out the Implicitly restarted Arnoldi Iteration. |
-c %-------------------------------------------------------%
-c
- call igraphdnaup2
- & ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd,
- & ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritzr),
- & workl(ritzi), workl(bounds), workl(iq), ldq, workl(iw),
- & ipntr, workd, info )
-c
-c %--------------------------------------------------%
-c | ido .ne. 99 implies use of reverse communication |
-c | to compute operations involving OP or shifts. |
-c %--------------------------------------------------%
-c
- if (ido .eq. 3) iparam(8) = np
- if (ido .ne. 99) go to 9000
-c
- iparam(3) = mxiter
- iparam(5) = np
- iparam(9) = nopx
- iparam(10) = nbx
- iparam(11) = nrorth
-c
-c %------------------------------------%
-c | Exit if there was an informational |
-c | error within igraphdnaup2. |
-c %------------------------------------%
-c
- if (info .lt. 0) go to 9000
- if (info .eq. 2) info = 3
-c
- if (msglvl .gt. 0) then
- call igraphivout (logfil, 1, [mxiter], ndigit,
- & '_naupd: Number of update iterations taken')
- call igraphivout (logfil, 1, [np], ndigit,
- & '_naupd: Number of wanted "converged" Ritz values')
- call igraphdvout (logfil, np, workl(ritzr), ndigit,
- & '_naupd: Real part of the final Ritz values')
- call igraphdvout (logfil, np, workl(ritzi), ndigit,
- & '_naupd: Imaginary part of the final Ritz values')
- call igraphdvout (logfil, np, workl(bounds), ndigit,
- & '_naupd: Associated Ritz estimates')
- end if
-c
- call igraphsecond (t1)
- tnaupd = t1 - t0
-c
-c
- 9000 continue
-c
- return
-c
-c %---------------%
-c | End of igraphdnaupd |
-c %---------------%
-c
- end
diff --git a/src/dnconv.f b/src/dnconv.f
deleted file mode 100644
index 4735159..0000000
--- a/src/dnconv.f
+++ /dev/null
@@ -1,146 +0,0 @@
-c-----------------------------------------------------------------------
-c\BeginDoc
-c
-c\Name: igraphdnconv
-c
-c\Description:
-c Convergence testing for the nonsymmetric Arnoldi eigenvalue routine.
-c
-c\Usage:
-c call igraphdnconv
-c ( N, RITZR, RITZI, BOUNDS, TOL, NCONV )
-c
-c\Arguments
-c N Integer. (INPUT)
-c Number of Ritz values to check for convergence.
-c
-c RITZR, Double precision arrays of length N. (INPUT)
-c RITZI Real and imaginary parts of the Ritz values to be checked
-c for convergence.
-
-c BOUNDS Double precision array of length N. (INPUT)
-c Ritz estimates for the Ritz values in RITZR and RITZI.
-c
-c TOL Double precision scalar. (INPUT)
-c Desired backward error for a Ritz value to be considered
-c "converged".
-c
-c NCONV Integer scalar. (OUTPUT)
-c Number of "converged" Ritz values.
-c
-c\EndDoc
-c
-c-----------------------------------------------------------------------
-c
-c\BeginLib
-c
-c\Local variables:
-c xxxxxx real
-c
-c\Routines called:
-c igraphsecond ARPACK utility routine for timing.
-c dlamch LAPACK routine that determines machine constants.
-c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully.
-c
-c\Author
-c Danny Sorensen Phuong Vu
-c Richard Lehoucq CRPC / Rice University
-c Dept. of Computational & Houston, Texas
-c Applied Mathematics
-c Rice University
-c Houston, Texas
-c
-c\Revision history:
-c xx/xx/92: Version ' 2.1'
-c
-c\SCCS Information: @(#)
-c FILE: nconv.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2
-c
-c\Remarks
-c 1. xxxx
-c
-c\EndLib
-c
-c-----------------------------------------------------------------------
-c
- subroutine igraphdnconv (n, ritzr, ritzi, bounds, tol, nconv)
-c
-c %----------------------------------------------------%
-c | Include files for debugging and timing information |
-c %----------------------------------------------------%
-c
- include 'debug.h'
- include 'stat.h'
-c
-c %------------------%
-c | Scalar Arguments |
-c %------------------%
-c
- integer n, nconv
- Double precision
- & tol
-c
-c %-----------------%
-c | Array Arguments |
-c %-----------------%
-
- Double precision
- & ritzr(n), ritzi(n), bounds(n)
-c
-c %---------------%
-c | Local Scalars |
-c %---------------%
-c
- integer i
- Double precision
- & temp, eps23
-c
-c %--------------------%
-c | External Functions |
-c %--------------------%
-c
- Double precision
- & dlapy2, dlamch
- external dlapy2, dlamch
-
-c %-----------------------%
-c | Executable Statements |
-c %-----------------------%
-c
-c %-------------------------------------------------------------%
-c | Convergence test: unlike in the symmetric code, I am not |
-c | using things like refined error bounds and gap condition |
-c | because I don't know the exact equivalent concept. |
-c | |
-c | Instead the i-th Ritz value is considered "converged" when: |
-c | |
-c | bounds(i) .le. ( TOL * | ritz | ) |
-c | |
-c | for some appropriate choice of norm. |
-c %-------------------------------------------------------------%
-c
- call igraphsecond (t0)
-c
-c %---------------------------------%
-c | Get machine dependent constant. |
-c %---------------------------------%
-c
- eps23 = dlamch('Epsilon-Machine')
- eps23 = eps23**(2.0D+0 / 3.0D+0)
-c
- nconv = 0
- do 20 i = 1, n
- temp = max( eps23, dlapy2( ritzr(i), ritzi(i) ) )
- if (bounds(i) .le. tol*temp) nconv = nconv + 1
- 20 continue
-c
- call igraphsecond (t1)
- tnconv = tnconv + (t1 - t0)
-c
- return
-c
-c %---------------%
-c | End of igraphdnconv |
-c %---------------%
-c
- end
diff --git a/src/dneigh.f b/src/dneigh.f
deleted file mode 100644
index 53c7c89..0000000
--- a/src/dneigh.f
+++ /dev/null
@@ -1,315 +0,0 @@
-c-----------------------------------------------------------------------
-c\BeginDoc
-c
-c\Name: igraphdneigh
-c
-c\Description:
-c Compute the eigenvalues of the current upper Hessenberg matrix
-c and the corresponding Ritz estimates given the current residual norm.
-c
-c\Usage:
-c call igraphdneigh
-c ( RNORM, N, H, LDH, RITZR, RITZI, BOUNDS, Q, LDQ, WORKL, IERR )
-c
-c\Arguments
-c RNORM Double precision scalar. (INPUT)
-c Residual norm corresponding to the current upper Hessenberg
-c matrix H.
-c
-c N Integer. (INPUT)
-c Size of the matrix H.
-c
-c H Double precision N by N array. (INPUT)
-c H contains the current upper Hessenberg matrix.
-c
-c LDH Integer. (INPUT)
-c Leading dimension of H exactly as declared in the calling
-c program.
-c
-c RITZR, Double precision arrays of length N. (OUTPUT)
-c RITZI On output, RITZR(1:N) (resp. RITZI(1:N)) contains the real
-c (respectively imaginary) parts of the eigenvalues of H.
-c
-c BOUNDS Double precision array of length N. (OUTPUT)
-c On output, BOUNDS contains the Ritz estimates associated with
-c the eigenvalues RITZR and RITZI. This is equal to RNORM
-c times the last components of the eigenvectors corresponding
-c to the eigenvalues in RITZR and RITZI.
-c
-c Q Double precision N by N array. (WORKSPACE)
-c Workspace needed to store the eigenvectors of H.
-c
-c LDQ Integer. (INPUT)
-c Leading dimension of Q exactly as declared in the calling
-c program.
-c
-c WORKL Double precision work array of length N**2 + 3*N. (WORKSPACE)
-c Private (replicated) array on each PE or array allocated on
-c the front end. This is needed to keep the full Schur form
-c of H and also in the calculation of the eigenvectors of H.
-c
-c IERR Integer. (OUTPUT)
-c Error exit flag from igraphdlaqrb or dtrevc.
-c
-c\EndDoc
-c
-c-----------------------------------------------------------------------
-c
-c\BeginLib
-c
-c\Local variables:
-c xxxxxx real
-c
-c\Routines called:
-c igraphdlaqrb ARPACK routine to compute the real Schur form of an
-c upper Hessenberg matrix and last row of the Schur vectors.
-c igraphsecond ARPACK utility routine for timing.
-c igraphdmout ARPACK utility routine that prints matrices
-c igraphdvout ARPACK utility routine that prints vectors.
-c dlacpy LAPACK matrix copy routine.
-c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully.
-c dtrevc LAPACK routine to compute the eigenvectors of a matrix
-c in upper quasi-triangular form
-c dgemv Level 2 BLAS routine for matrix vector multiplication.
-c dcopy Level 1 BLAS that copies one vector to another .
-c dnrm2 Level 1 BLAS that computes the norm of a vector.
-c dscal Level 1 BLAS that scales a vector.
-c
-c
-c\Author
-c Danny Sorensen Phuong Vu
-c Richard Lehoucq CRPC / Rice University
-c Dept. of Computational & Houston, Texas
-c Applied Mathematics
-c Rice University
-c Houston, Texas
-c
-c\Revision history:
-c xx/xx/92: Version ' 2.1'
-c
-c\SCCS Information: @(#)
-c FILE: neigh.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2
-c
-c\Remarks
-c None
-c
-c\EndLib
-c
-c-----------------------------------------------------------------------
-c
- subroutine igraphdneigh (rnorm, n, h, ldh, ritzr, ritzi, bounds,
- & q, ldq, workl, ierr)
-c
-c %----------------------------------------------------%
-c | Include files for debugging and timing information |
-c %----------------------------------------------------%
-c
- include 'debug.h'
- include 'stat.h'
-c
-c %------------------%
-c | Scalar Arguments |
-c %------------------%
-c
- integer ierr, n, ldh, ldq
- Double precision
- & rnorm
-c
-c %-----------------%
-c | Array Arguments |
-c %-----------------%
-c
- Double precision
- & bounds(n), h(ldh,n), q(ldq,n), ritzi(n), ritzr(n),
- & workl(n*(n+3))
-c
-c %------------%
-c | Parameters |
-c %------------%
-c
- Double precision
- & one, zero
- parameter (one = 1.0D+0, zero = 0.0D+0)
-c
-c %------------------------%
-c | Local Scalars & Arrays |
-c %------------------------%
-c
- logical select(1)
- integer i, iconj, msglvl
- Double precision
- & temp, vl(1)
-c
-c %----------------------%
-c | External Subroutines |
-c %----------------------%
-c
- external dcopy, dlacpy, igraphdlaqrb, dtrevc, igraphdvout,
- & igraphsecond
-c
-c %--------------------%
-c | External Functions |
-c %--------------------%
-c
- Double precision
- & dlapy2, dnrm2
- external dlapy2, dnrm2
-c
-c %---------------------%
-c | Intrinsic Functions |
-c %---------------------%
-c
- intrinsic abs
-c
-c %-----------------------%
-c | Executable Statements |
-c %-----------------------%
-c
-c
-c %-------------------------------%
-c | Initialize timing statistics |
-c | & message level for debugging |
-c %-------------------------------%
-c
- call igraphsecond (t0)
- msglvl = mneigh
-c
- if (msglvl .gt. 2) then
- call igraphdmout (logfil, n, n, h, ldh, ndigit,
- & '_neigh: Entering upper Hessenberg matrix H ')
- end if
-c
-c %-----------------------------------------------------------%
-c | 1. Compute the eigenvalues, the last components of the |
-c | corresponding Schur vectors and the full Schur form T |
-c | of the current upper Hessenberg matrix H. |
-c | igraphdlaqrb returns the full Schur form of H in WORKL(1:N**2) |
-c | and the last components of the Schur vectors in BOUNDS. |
-c %-----------------------------------------------------------%
-c
- call dlacpy ('All', n, n, h, ldh, workl, n)
- call igraphdlaqrb (.true., n, 1, n, workl, n, ritzr, ritzi,
- & bounds, ierr)
- if (ierr .ne. 0) go to 9000
-c
- if (msglvl .gt. 1) then
- call igraphdvout (logfil, n, bounds, ndigit,
- & '_neigh: last row of the Schur matrix for H')
- end if
-c
-c %-----------------------------------------------------------%
-c | 2. Compute the eigenvectors of the full Schur form T and |
-c | apply the last components of the Schur vectors to get |
-c | the last components of the corresponding eigenvectors. |
-c | Remember that if the i-th and (i+1)-st eigenvalues are |
-c | complex conjugate pairs, then the real & imaginary part |
-c | of the eigenvector components are split across adjacent |
-c | columns of Q. |
-c %-----------------------------------------------------------%
-c
- call dtrevc ('R', 'A', select, n, workl, n, vl, n, q, ldq,
- & n, n, workl(n*n+1), ierr)
-c
- if (ierr .ne. 0) go to 9000
-c
-c %------------------------------------------------%
-c | Scale the returning eigenvectors so that their |
-c | euclidean norms are all one. LAPACK subroutine |
-c | dtrevc returns each eigenvector normalized so |
-c | that the element of largest magnitude has |
-c | magnitude 1; here the magnitude of a complex |
-c | number (x,y) is taken to be |x| + |y|. |
-c %------------------------------------------------%
-c
- iconj = 0
- do 10 i=1, n
- if ( abs( ritzi(i) ) .le. zero ) then
-c
-c %----------------------%
-c | Real eigenvalue case |
-c %----------------------%
-c
- temp = dnrm2( n, q(1,i), 1 )
- call dscal ( n, one / temp, q(1,i), 1 )
- else
-c
-c %-------------------------------------------%
-c | Complex conjugate pair case. Note that |
-c | since the real and imaginary part of |
-c | the eigenvector are stored in consecutive |
-c | columns, we further normalize by the |
-c | square root of two. |
-c %-------------------------------------------%
-c
- if (iconj .eq. 0) then
- temp = dlapy2( dnrm2( n, q(1,i), 1 ),
- & dnrm2( n, q(1,i+1), 1 ) )
- call dscal ( n, one / temp, q(1,i), 1 )
- call dscal ( n, one / temp, q(1,i+1), 1 )
- iconj = 1
- else
- iconj = 0
- end if
- end if
- 10 continue
-c
- call dgemv ('T', n, n, one, q, ldq, bounds, 1, zero, workl, 1)
-c
- if (msglvl .gt. 1) then
- call igraphdvout (logfil, n, workl, ndigit,
- & '_neigh: Last row of the eigenvector matrix for H')
- end if
-c
-c %----------------------------%
-c | Compute the Ritz estimates |
-c %----------------------------%
-c
- iconj = 0
- do 20 i = 1, n
- if ( abs( ritzi(i) ) .le. zero ) then
-c
-c %----------------------%
-c | Real eigenvalue case |
-c %----------------------%
-c
- bounds(i) = rnorm * abs( workl(i) )
- else
-c
-c %-------------------------------------------%
-c | Complex conjugate pair case. Note that |
-c | since the real and imaginary part of |
-c | the eigenvector are stored in consecutive |
-c | columns, we need to take the magnitude |
-c | of the last components of the two vectors |
-c %-------------------------------------------%
-c
- if (iconj .eq. 0) then
- bounds(i) = rnorm * dlapy2( workl(i), workl(i+1) )
- bounds(i+1) = bounds(i)
- iconj = 1
- else
- iconj = 0
- end if
- end if
- 20 continue
-c
- if (msglvl .gt. 2) then
- call igraphdvout (logfil, n, ritzr, ndigit,
- & '_neigh: Real part of the eigenvalues of H')
- call igraphdvout (logfil, n, ritzi, ndigit,
- & '_neigh: Imaginary part of the eigenvalues of H')
- call igraphdvout (logfil, n, bounds, ndigit,
- & '_neigh: Ritz estimates for the eigenvalues of H')
- end if
-c
- call igraphsecond (t1)
- tneigh = tneigh + (t1 - t0)
-c
- 9000 continue
- return
-c
-c %---------------%
-c | End of igraphdneigh |
-c %---------------%
-c
- end
diff --git a/src/dneupd.f b/src/dneupd.f
deleted file mode 100644
index 92b4bc3..0000000
--- a/src/dneupd.f
+++ /dev/null
@@ -1,1044 +0,0 @@
-c\BeginDoc
-c
-c\Name: igraphdneupd
-c
-c\Description:
-c
-c This subroutine returns the converged approximations to eigenvalues
-c of A*z = lambda*B*z and (optionally):
-c
-c (1) The corresponding approximate eigenvectors;
-c
-c (2) An orthonormal basis for the associated approximate
-c invariant subspace;
-c
-c (3) Both.
-c
-c There is negligible additional cost to obtain eigenvectors. An orthonormal
-c basis is always computed. There is an additional storage cost of n*nev
-c if both are requested (in this case a separate array Z must be supplied).
-c
-c The approximate eigenvalues and eigenvectors of A*z = lambda*B*z
-c are derived from approximate eigenvalues and eigenvectors of
-c of the linear operator OP prescribed by the MODE selection in the
-c call to DNAUPD. DNAUPD must be called before this routine is called.
-c These approximate eigenvalues and vectors are commonly called Ritz
-c values and Ritz vectors respectively. They are referred to as such
-c in the comments that follow. The computed orthonormal basis for the
-c invariant subspace corresponding to these Ritz values is referred to as a
-c Schur basis.
-c
-c See documentation in the header of the subroutine DNAUPD for
-c definition of OP as well as other terms and the relation of computed
-c Ritz values and Ritz vectors of OP with respect to the given problem
-c A*z = lambda*B*z. For a brief description, see definitions of
-c IPARAM(7), MODE and WHICH in the documentation of DNAUPD.
-c
-c\Usage:
-c call igraphdneupd
-c ( RVEC, HOWMNY, SELECT, DR, DI, Z, LDZ, SIGMAR, SIGMAI, WORKEV, BMAT,
-c N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD, WORKL,
-c LWORKL, INFO )
-c
-c\Arguments:
-c RVEC LOGICAL (INPUT)
-c Specifies whether a basis for the invariant subspace corresponding
-c to the converged Ritz value approximations for the eigenproblem
-c A*z = lambda*B*z is computed.
-c
-c RVEC = .FALSE. Compute Ritz values only.
-c
-c RVEC = .TRUE. Compute the Ritz vectors or Schur vectors.
-c See Remarks below.
-c
-c HOWMNY Character*1 (INPUT)
-c Specifies the form of the basis for the invariant subspace
-c corresponding to the converged Ritz values that is to be computed.
-c
-c = 'A': Compute NEV Ritz vectors;
-c = 'P': Compute NEV Schur vectors;
-c = 'S': compute some of the Ritz vectors, specified
-c by the logical array SELECT.
-c
-c SELECT Logical array of dimension NCV. (INPUT)
-c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be
-c computed. To select the Ritz vector corresponding to a
-c Ritz value (DR(j), DI(j)), SELECT(j) must be set to .TRUE..
-c If HOWMNY = 'A' or 'P', SELECT is used as internal workspace.
-c
-c DR Double precision array of dimension NEV+1. (OUTPUT)
-c If IPARAM(7) = 1,2 or 3 and SIGMAI=0.0 then on exit: DR contains
-c the real part of the Ritz approximations to the eigenvalues of
-c A*z = lambda*B*z.
-c If IPARAM(7) = 3, 4 and SIGMAI is not equal to zero, then on exit:
-c DR contains the real part of the Ritz values of OP computed by
-c DNAUPD. A further computation must be performed by the user
-c to transform the Ritz values computed for OP by DNAUPD to those
-c of the original system A*z = lambda*B*z. See remark 3 below.
-c
-c DI Double precision array of dimension NEV+1. (OUTPUT)
-c On exit, DI contains the imaginary part of the Ritz value
-c approximations to the eigenvalues of A*z = lambda*B*z associated
-c with DR.
-c
-c NOTE: When Ritz values are complex, they will come in complex
-c conjugate pairs. If eigenvectors are requested, the
-c corresponding Ritz vectors will also come in conjugate
-c pairs and the real and imaginary parts of these are
-c represented in two consecutive columns of the array Z
-c (see below).
-c
-c Z Double precision N by NEV+1 array if RVEC = .TRUE. and HOWMNY = 'A'. (OUTPUT)
-c On exit, if RVEC = .TRUE. and HOWMNY = 'A', then the columns of
-c Z represent approximate eigenvectors (Ritz vectors) corresponding
-c to the NCONV=IPARAM(5) Ritz values for eigensystem
-c A*z = lambda*B*z.
-c
-c The complex Ritz vector associated with the Ritz value
-c with positive imaginary part is stored in two consecutive
-c columns. The first column holds the real part of the Ritz
-c vector and the igraphsecond column holds the imaginary part. The
-c Ritz vector associated with the Ritz value with negative
-c imaginary part is simply the complex conjugate of the Ritz vector
-c associated with the positive imaginary part.
-c
-c If RVEC = .FALSE. or HOWMNY = 'P', then Z is not referenced.
-c
-c NOTE: If if RVEC = .TRUE. and a Schur basis is not required,
-c the array Z may be set equal to first NEV+1 columns of the Arnoldi
-c basis array V computed by DNAUPD. In this case the Arnoldi basis
-c will be destroyed and overwritten with the eigenvector basis.
-c
-c LDZ Integer. (INPUT)
-c The leading dimension of the array Z. If Ritz vectors are
-c desired, then LDZ >= max( 1, N ). In any case, LDZ >= 1.
-c
-c SIGMAR Double precision (INPUT)
-c If IPARAM(7) = 3 or 4, represents the real part of the shift.
-c Not referenced if IPARAM(7) = 1 or 2.
-c
-c SIGMAI Double precision (INPUT)
-c If IPARAM(7) = 3 or 4, represents the imaginary part of the shift.
-c Not referenced if IPARAM(7) = 1 or 2. See remark 3 below.
-c
-c WORKEV Double precision work array of dimension 3*NCV. (WORKSPACE)
-c
-c **** The remaining arguments MUST be the same as for the ****
-c **** call to DNAUPD that was just completed. ****
-c
-c NOTE: The remaining arguments
-c
-c BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR,
-c WORKD, WORKL, LWORKL, INFO
-c
-c must be passed directly to DNEUPD following the last call
-c to DNAUPD. These arguments MUST NOT BE MODIFIED between
-c the the last call to DNAUPD and the call to DNEUPD.
-c
-c Three of these parameters (V, WORKL, INFO) are also output parameters:
-c
-c V Double precision N by NCV array. (INPUT/OUTPUT)
-c
-c Upon INPUT: the NCV columns of V contain the Arnoldi basis
-c vectors for OP as constructed by DNAUPD .
-c
-c Upon OUTPUT: If RVEC = .TRUE. the first NCONV=IPARAM(5) columns
-c contain approximate Schur vectors that span the
-c desired invariant subspace. See Remark 2 below.
-c
-c NOTE: If the array Z has been set equal to first NEV+1 columns
-c of the array V and RVEC=.TRUE. and HOWMNY= 'A', then the
-c Arnoldi basis held by V has been overwritten by the desired
-c Ritz vectors. If a separate array Z has been passed then
-c the first NCONV=IPARAM(5) columns of V will contain approximate
-c Schur vectors that span the desired invariant subspace.
-c
-c WORKL Double precision work array of length LWORKL. (OUTPUT/WORKSPACE)
-c WORKL(1:ncv*ncv+3*ncv) contains information obtained in
-c igraphdnaupd. They are not changed by igraphdneupd.
-c WORKL(ncv*ncv+3*ncv+1:3*ncv*ncv+6*ncv) holds the
-c real and imaginary part of the untransformed Ritz values,
-c the upper quasi-triangular matrix for H, and the
-c associated matrix representation of the invariant subspace for H.
-c
-c Note: IPNTR(9:13) contains the pointer into WORKL for addresses
-c of the above information computed by igraphdneupd.
-c -------------------------------------------------------------
-c IPNTR(9): pointer to the real part of the NCV RITZ values of the
-c original system.
-c IPNTR(10): pointer to the imaginary part of the NCV RITZ values of
-c the original system.
-c IPNTR(11): pointer to the NCV corresponding error bounds.
-c IPNTR(12): pointer to the NCV by NCV upper quasi-triangular
-c Schur matrix for H.
-c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors
-c of the upper Hessenberg matrix H. Only referenced by
-c igraphdneupd if RVEC = .TRUE. See Remark 2 below.
-c -------------------------------------------------------------
-c
-c INFO Integer. (OUTPUT)
-c Error flag on output.
-c
-c = 0: Normal exit.
-c
-c = 1: The Schur form computed by LAPACK routine dlahqr
-c could not be reordered by LAPACK routine dtrsen.
-c Re-enter subroutine igraphdneupd with IPARAM(5)=NCV and
-c increase the size of the arrays DR and DI to have
-c dimension at least dimension NCV and allocate at least NCV
-c columns for Z. NOTE: Not necessary if Z and V share
-c the same space. Please notify the authors if this error
-c occurs.
-c
-c = -1: N must be positive.
-c = -2: NEV must be positive.
-c = -3: NCV-NEV >= 2 and less than or equal to N.
-c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI'
-c = -6: BMAT must be one of 'I' or 'G'.
-c = -7: Length of private work WORKL array is not sufficient.
-c = -8: Error return from calculation of a real Schur form.
-c Informational error from LAPACK routine dlahqr.
-c = -9: Error return from calculation of eigenvectors.
-c Informational error from LAPACK routine dtrevc.
-c = -10: IPARAM(7) must be 1,2,3,4.
-c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible.
-c = -12: HOWMNY = 'S' not yet implemented
-c = -13: HOWMNY must be one of 'A' or 'P' if RVEC = .true.
-c = -14: DNAUPD did not find any eigenvalues to sufficient
-c accuracy.
-c
-c\BeginLib
-c
-c\References:
-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
-c pp 357-385.
-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
-c Restarted Arnoldi Iteration", Rice University Technical Report
-c TR95-13, Department of Computational and Applied Mathematics.
-c 3. B.N. Parlett & Y. Saad, "Complex Shift and Invert Strategies for
-c Real Matrices", Linear Algebra and its Applications, vol 88/89,
-c pp 575-595, (1987).
-c
-c\Routines called:
-c igraphivout ARPACK utility routine that prints integers.
-c igraphdmout ARPACK utility routine that prints matrices
-c igraphdvout ARPACK utility routine that prints vectors.
-c dgeqr2 LAPACK routine that computes the QR factorization of
-c a matrix.
-c dlacpy LAPACK matrix copy routine.
-c dlahqr LAPACK routine to compute the real Schur form of an
-c upper Hessenberg matrix.
-c dlamch LAPACK routine that determines machine constants.
-c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully.
-c dlaset LAPACK matrix initialization routine.
-c dorm2r LAPACK routine that applies an orthogonal matrix in
-c factored form.
-c dtrevc LAPACK routine to compute the eigenvectors of a matrix
-c in upper quasi-triangular form.
-c dtrsen LAPACK routine that re-orders the Schur form.
-c dtrmm Level 3 BLAS matrix times an upper triangular matrix.
-c dger Level 2 BLAS rank one update to a matrix.
-c dcopy Level 1 BLAS that copies one vector to another .
-c ddot Level 1 BLAS that computes the scalar product of two vectors.
-c dnrm2 Level 1 BLAS that computes the norm of a vector.
-c dscal Level 1 BLAS that scales a vector.
-c
-c\Remarks
-c
-c 1. Currently only HOWMNY = 'A' and 'P' are implemented.
-c
-c Let X' denote the transpose of X.
-c
-c 2. Schur vectors are an orthogonal representation for the basis of
-c Ritz vectors. Thus, their numerical properties are often superior.
-c If RVEC = .TRUE. then the relationship
-c A * V(:,1:IPARAM(5)) = V(:,1:IPARAM(5)) * T, and
-c V(:,1:IPARAM(5))' * V(:,1:IPARAM(5)) = I are approximately satisfied.
-c Here T is the leading submatrix of order IPARAM(5) of the real
-c upper quasi-triangular matrix stored workl(ipntr(12)). That is,
-c T is block upper triangular with 1-by-1 and 2-by-2 diagonal blocks;
-c each 2-by-2 diagonal block has its diagonal elements equal and its
-c off-diagonal elements of opposite sign. Corresponding to each 2-by-2
-c diagonal block is a complex conjugate pair of Ritz values. The real
-c Ritz values are stored on the diagonal of T.
-c
-c 3. If IPARAM(7) = 3 or 4 and SIGMAI is not equal zero, then the user must
-c form the IPARAM(5) Rayleigh quotients in order to transform the Ritz
-c values computed by DNAUPD for OP to those of A*z = lambda*B*z.
-c Set RVEC = .true. and HOWMNY = 'A', and
-c compute
-c Z(:,I)' * A * Z(:,I) if DI(I) = 0.
-c If DI(I) is not equal to zero and DI(I+1) = - D(I),
-c then the desired real and imaginary parts of the Ritz value are
-c Z(:,I)' * A * Z(:,I) + Z(:,I+1)' * A * Z(:,I+1),
-c Z(:,I)' * A * Z(:,I+1) - Z(:,I+1)' * A * Z(:,I), respectively.
-c Another possibility is to set RVEC = .true. and HOWMNY = 'P' and
-c compute V(:,1:IPARAM(5))' * A * V(:,1:IPARAM(5)) and then an upper
-c quasi-triangular matrix of order IPARAM(5) is computed. See remark
-c 2 above.
-c
-c\Authors
-c Danny Sorensen Phuong Vu
-c Richard Lehoucq CRPC / Rice University
-c Chao Yang Houston, Texas
-c Dept. of Computational &
-c Applied Mathematics
-c Rice University
-c Houston, Texas
-c
-c\SCCS Information: @(#)
-c FILE: neupd.F SID: 2.5 DATE OF SID: 7/31/96 RELEASE: 2
-c
-c\EndLib
-c
-c-----------------------------------------------------------------------
- subroutine igraphdneupd (rvec, howmny, select, dr, di, z, ldz,
- & sigmar, sigmai, workev, bmat, n, which, nev, tol,
- & resid, ncv, v, ldv, iparam, ipntr, workd,
- & workl, lworkl, info)
-c
-c %----------------------------------------------------%
-c | Include files for debugging and timing information |
-c %----------------------------------------------------%
-c
- include 'debug.h'
- include 'stat.h'
-c
-c %------------------%
-c | Scalar Arguments |
-c %------------------%
-c
- character bmat, howmny, which*2
- logical rvec
- integer info, ldz, ldv, lworkl, n, ncv, nev
- Double precision
- & sigmar, sigmai, tol
-c
-c %-----------------%
-c | Array Arguments |
-c %-----------------%
-c
- integer iparam(11), ipntr(14)
- logical select(ncv)
- Double precision
- & dr(nev+1), di(nev+1), resid(n), v(ldv,ncv), z(ldz,*),
- & workd(3*n), workl(lworkl), workev(3*ncv)
-c
-c %------------%
-c | Parameters |
-c %------------%
-c
- Double precision
- & one, zero
- parameter (one = 1.0D+0, zero = 0.0D+0)
-c
-c %---------------%
-c | Local Scalars |
-c %---------------%
-c
- character type*6
- integer bounds, ierr, ih, ihbds, iheigr, iheigi, iconj, nconv,
- & invsub, iuptri, iwev, iwork(1), j, k, ktrord,
- & ldh, ldq, mode, msglvl, outncv, ritzr, ritzi, wri, wrr,
- & irr, iri, ibd
- logical reord
- Double precision
- & conds, rnorm, sep, temp, thres, vl(1,1), temp1, eps23
-c
-c %----------------------%
-c | External Subroutines |
-c %----------------------%
-c
- external dcopy, dger, dgeqr2, dlacpy, dlahqr, dlaset,
- & igraphdmout, dorm2r, dtrevc, dtrmm, dtrsen, dscal,
- & igraphdvout, igraphivout
-c
-c %--------------------%
-c | External Functions |
-c %--------------------%
-c
- Double precision
- & dlapy2, dnrm2, dlamch, ddot
- external dlapy2, dnrm2, dlamch, ddot
-c
-c %---------------------%
-c | Intrinsic Functions |
-c %---------------------%
-c
- intrinsic abs, min, sqrt
-c
-c %-----------------------%
-c | Executable Statements |
-c %-----------------------%
-c
-c %------------------------%
-c | Set default parameters |
-c %------------------------%
-c
- msglvl = mneupd
- mode = iparam(7)
- nconv = iparam(5)
- info = 0
-c
-c %---------------------------------%
-c | Get machine dependent constant. |
-c %---------------------------------%
-c
- eps23 = dlamch('Epsilon-Machine')
- eps23 = eps23**(2.0D+0 / 3.0D+0)
-c
-c %--------------%
-c | Quick return |
-c %--------------%
-c
- ierr = 0
-c
- if (nconv .le. 0) then
- ierr = -14
- else if (n .le. 0) then
- ierr = -1
- else if (nev .le. 0) then
- ierr = -2
- else if (ncv .le. nev+1 .or. ncv .gt. n) then
- ierr = -3
- else if (which .ne. 'LM' .and.
- & which .ne. 'SM' .and.
- & which .ne. 'LR' .and.
- & which .ne. 'SR' .and.
- & which .ne. 'LI' .and.
- & which .ne. 'SI') then
- ierr = -5
- else if (bmat .ne. 'I' .and. bmat .ne. 'G') then
- ierr = -6
- else if (lworkl .lt. 3*ncv**2 + 6*ncv) then
- ierr = -7
- else if ( (howmny .ne. 'A' .and.
- & howmny .ne. 'P' .and.
- & howmny .ne. 'S') .and. rvec ) then
- ierr = -13
- else if (howmny .eq. 'S' ) then
- ierr = -12
- end if
-c
- if (mode .eq. 1 .or. mode .eq. 2) then
- type = 'REGULR'
- else if (mode .eq. 3 .and. sigmai .eq. zero) then
- type = 'SHIFTI'
- else if (mode .eq. 3 ) then
- type = 'REALPT'
- else if (mode .eq. 4 ) then
- type = 'IMAGPT'
- else
- ierr = -10
- end if
- if (mode .eq. 1 .and. bmat .eq. 'G') ierr = -11
-c
-c %------------%
-c | Error Exit |
-c %------------%
-c
- if (ierr .ne. 0) then
- info = ierr
- go to 9000
- end if
-c
-c %--------------------------------------------------------%
-c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q |
-c | etc... and the remaining workspace. |
-c | Also update pointer to be used on output. |
-c | Memory is laid out as follows: |
-c | workl(1:ncv*ncv) := generated Hessenberg matrix |
-c | workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary |
-c | parts of ritz values |
-c | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds |
-c %--------------------------------------------------------%
-c
-c %-----------------------------------------------------------%
-c | The following is used and set by DNEUPD. |
-c | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed |
-c | real part of the Ritz values. |
-c | workl(ncv*ncv+4*ncv+1:ncv*ncv+5*ncv) := The untransformed |
-c | imaginary part of the Ritz values. |
-c | workl(ncv*ncv+5*ncv+1:ncv*ncv+6*ncv) := The untransformed |
-c | error bounds of the Ritz values |
-c | workl(ncv*ncv+6*ncv+1:2*ncv*ncv+6*ncv) := Holds the upper |
-c | quasi-triangular matrix for H |
-c | workl(2*ncv*ncv+6*ncv+1: 3*ncv*ncv+6*ncv) := Holds the |
-c | associated matrix representation of the invariant |
-c | subspace for H. |
-c | GRAND total of NCV * ( 3 * NCV + 6 ) locations. |
-c %-----------------------------------------------------------%
-c
- ih = ipntr(5)
- ritzr = ipntr(6)
- ritzi = ipntr(7)
- bounds = ipntr(8)
- ldh = ncv
- ldq = ncv
- iheigr = bounds + ldh
- iheigi = iheigr + ldh
- ihbds = iheigi + ldh
- iuptri = ihbds + ldh
- invsub = iuptri + ldh*ncv
- ipntr(9) = iheigr
- ipntr(10) = iheigi
- ipntr(11) = ihbds
- ipntr(12) = iuptri
- ipntr(13) = invsub
- wrr = 1
- wri = ncv + 1
- iwev = wri + ncv
-c
-c %-----------------------------------------%
-c | irr points to the REAL part of the Ritz |
-c | values computed by _neigh before |
-c | exiting _naup2. |
-c | iri points to the IMAGINARY part of the |
-c | Ritz values computed by _neigh |
-c | before exiting _naup2. |
-c | ibd points to the Ritz estimates |
-c | computed by _neigh before exiting |
-c | _naup2. |
-c %-----------------------------------------%
-c
- irr = ipntr(14)+ncv*ncv
- iri = irr+ncv
- ibd = iri+ncv
-c
-c %------------------------------------%
-c | RNORM is B-norm of the RESID(1:N). |
-c %------------------------------------%
-c
- rnorm = workl(ih+2)
- workl(ih+2) = zero
-c
- if (rvec) then
-c
-c %-------------------------------------------%
-c | Get converged Ritz value on the boundary. |
-c | Note: converged Ritz values have been |
-c | placed in the first NCONV locations in |
-c | workl(ritzr) and workl(ritzi). They have |
-c | been sorted (in _naup2) according to the |
-c | WHICH selection criterion. |
-c %-------------------------------------------%
-c
- if (which .eq. 'LM' .or. which .eq. 'SM') then
- thres = dlapy2( workl(ritzr), workl(ritzi) )
- else if (which .eq. 'LR' .or. which .eq. 'SR') then
- thres = workl(ritzr)
- else if (which .eq. 'LI' .or. which .eq. 'SI') then
- thres = abs( workl(ritzi) )
- end if
-c
- if (msglvl .gt. 2) then
- call igraphdvout(logfil, 1, [thres], ndigit,
- & '_neupd: Threshold eigenvalue used for re-ordering')
- end if
-c
-c %----------------------------------------------------------%
-c | Check to see if all converged Ritz values appear at the |
-c | top of the upper quasi-triangular matrix computed by |
-c | _neigh in _naup2. This is done in the following way: |
-c | |
-c | 1) For each Ritz value obtained from _neigh, compare it |
-c | with the threshold Ritz value computed above to |
-c | determine whether it is a wanted one. |
-c | |
-c | 2) If it is wanted, then check the corresponding Ritz |
-c | estimate to see if it has converged. If it has, set |
-c | correponding entry in the logical array SELECT to |
-c | .TRUE.. |
-c | |
-c | If SELECT(j) = .TRUE. and j > NCONV, then there is a |
-c | converged Ritz value that does not appear at the top of |
-c | the upper quasi-triangular matrix computed by _neigh in |
-c | _naup2. Reordering is needed. |
-c %----------------------------------------------------------%
-c
- reord = .false.
- ktrord = 0
- do 10 j = 0, ncv-1
- select(j+1) = .false.
- if (which .eq. 'LM') then
- if (dlapy2(workl(irr+j), workl(iri+j))
- & .ge. thres) then
- temp1 = max( eps23,
- & dlapy2( workl(irr+j), workl(iri+j) ) )
- if (workl(ibd+j) .le. tol*temp1)
- & select(j+1) = .true.
- end if
- else if (which .eq. 'SM') then
- if (dlapy2(workl(irr+j), workl(iri+j))
- & .le. thres) then
- temp1 = max( eps23,
- & dlapy2( workl(irr+j), workl(iri+j) ) )
- if (workl(ibd+j) .le. tol*temp1)
- & select(j+1) = .true.
- end if
- else if (which .eq. 'LR') then
- if (workl(irr+j) .ge. thres) then
- temp1 = max( eps23,
- & dlapy2( workl(irr+j), workl(iri+j) ) )
- if (workl(ibd+j) .le. tol*temp1)
- & select(j+1) = .true.
- end if
- else if (which .eq. 'SR') then
- if (workl(irr+j) .le. thres) then
- temp1 = max( eps23,
- & dlapy2( workl(irr+j), workl(iri+j) ) )
- if (workl(ibd+j) .le. tol*temp1)
- & select(j+1) = .true.
- end if
- else if (which .eq. 'LI') then
- if (abs(workl(iri+j)) .ge. thres) then
- temp1 = max( eps23,
- & dlapy2( workl(irr+j), workl(iri+j) ) )
- if (workl(ibd+j) .le. tol*temp1)
- & select(j+1) = .true.
- end if
- else if (which .eq. 'SI') then
- if (abs(workl(iri+j)) .le. thres) then
- temp1 = max( eps23,
- & dlapy2( workl(irr+j), workl(iri+j) ) )
- if (workl(ibd+j) .le. tol*temp1)
- & select(j+1) = .true.
- end if
- end if
- if (j+1 .gt. nconv ) reord = ( select(j+1) .or. reord )
- if (select(j+1)) ktrord = ktrord + 1
- 10 continue
-c
- if (msglvl .gt. 2) then
- call igraphivout(logfil, 1, [ktrord], ndigit,
- & '_neupd: Number of specified eigenvalues')
- call igraphivout(logfil, 1, [nconv], ndigit,
- & '_neupd: Number of "converged" eigenvalues')
- end if
-c
-c %-----------------------------------------------------------%
-c | Call LAPACK routine dlahqr to compute the real Schur form |
-c | of the upper Hessenberg matrix returned by DNAUPD. |
-c | Make a copy of the upper Hessenberg matrix. |
-c | Initialize the Schur vector matrix Q to the identity. |
-c %-----------------------------------------------------------%
-c
- call dcopy (ldh*ncv, workl(ih), 1, workl(iuptri), 1)
- call dlaset ('All', ncv, ncv, zero, one, workl(invsub), ldq)
- call dlahqr (.true., .true., ncv, 1, ncv, workl(iuptri), ldh,
- & workl(iheigr), workl(iheigi), 1, ncv,
- & workl(invsub), ldq, ierr)
- call dcopy (ncv, workl(invsub+ncv-1), ldq, workl(ihbds), 1)
-c
- if (ierr .ne. 0) then
- info = -8
- go to 9000
- end if
-c
- if (msglvl .gt. 1) then
- call igraphdvout (logfil, ncv, workl(iheigr), ndigit,
- & '_neupd: Real part of the eigenvalues of H')
- call igraphdvout (logfil, ncv, workl(iheigi), ndigit,
- & '_neupd: Imaginary part of the Eigenvalues of H')
- call igraphdvout (logfil, ncv, workl(ihbds), ndigit,
- & '_neupd: Last row of the Schur vector matrix')
- if (msglvl .gt. 3) then
- call igraphdmout (logfil, ncv, ncv, workl(iuptri), ldh,
- & ndigit,
- & '_neupd: The upper quasi-triangular matrix ')
- end if
- end if
-c
- if (reord) then
-c
-c %-----------------------------------------------------%
-c | Reorder the computed upper quasi-triangular matrix. |
-c %-----------------------------------------------------%
-c
- call dtrsen ('None', 'V', select, ncv, workl(iuptri), ldh,
- & workl(invsub), ldq, workl(iheigr), workl(iheigi),
- & nconv, conds, sep, workl(ihbds), ncv, iwork, 1, ierr)
-c
- if (ierr .eq. 1) then
- info = 1
- go to 9000
- end if
-c
- if (msglvl .gt. 2) then
- call igraphdvout (logfil, ncv, workl(iheigr), ndigit,
- & '_neupd: Real part of the eigenvalues of H--reordered')
- call igraphdvout (logfil, ncv, workl(iheigi), ndigit,
- & '_neupd: Imag part of the eigenvalues of H--reordered')
- if (msglvl .gt. 3) then
- call igraphdmout (logfil, ncv, ncv, workl(iuptri),
- & ldq, ndigit,
- & '_neupd: Quasi-triangular matrix after re-ordering')
- end if
- end if
-c
- end if
-c
-c %---------------------------------------%
-c | Copy the last row of the Schur vector |
-c | into workl(ihbds). This will be used |
-c | to compute the Ritz estimates of |
-c | converged Ritz values. |
-c %---------------------------------------%
-c
- call dcopy(ncv, workl(invsub+ncv-1), ldq, workl(ihbds), 1)
-c
-c %----------------------------------------------------%
-c | Place the computed eigenvalues of H into DR and DI |
-c | if a spectral transformation was not used. |
-c %----------------------------------------------------%
-c
- if (type .eq. 'REGULR') then
- call dcopy (nconv, workl(iheigr), 1, dr, 1)
- call dcopy (nconv, workl(iheigi), 1, di, 1)
- end if
-c
-c %----------------------------------------------------------%
-c | Compute the QR factorization of the matrix representing |
-c | the wanted invariant subspace located in the first NCONV |
-c | columns of workl(invsub,ldq). |
-c %----------------------------------------------------------%
-c
- call dgeqr2 (ncv, nconv, workl(invsub), ldq, workev,
- & workev(ncv+1), ierr)
-c
-c %---------------------------------------------------------%
-c | * Postmultiply V by Q using dorm2r. |
-c | * Copy the first NCONV columns of VQ into Z. |
-c | * Postmultiply Z by R. |
-c | The N by NCONV matrix Z is now a matrix representation |
-c | of the approximate invariant subspace associated with |
-c | the Ritz values in workl(iheigr) and workl(iheigi) |
-c | The first NCONV columns of V are now approximate Schur |
-c | vectors associated with the real upper quasi-triangular |
-c | matrix of order NCONV in workl(iuptri) |
-c %---------------------------------------------------------%
-c
- call dorm2r ('Right', 'Notranspose', n, ncv, nconv,
- & workl(invsub), ldq, workev, v, ldv, workd(n+1), ierr)
- call dlacpy ('All', n, nconv, v, ldv, z, ldz)
-c
- do 20 j=1, nconv
-c
-c %---------------------------------------------------%
-c | Perform both a column and row scaling if the |
-c | diagonal element of workl(invsub,ldq) is negative |
-c | I'm lazy and don't take advantage of the upper |
-c | quasi-triangular form of workl(iuptri,ldq) |
-c | Note that since Q is orthogonal, R is a diagonal |
-c | matrix consisting of plus or minus ones |
-c %---------------------------------------------------%
-c
- if (workl(invsub+(j-1)*ldq+j-1) .lt. zero) then
- call dscal (nconv, -one, workl(iuptri+j-1), ldq)
- call dscal (nconv, -one, workl(iuptri+(j-1)*ldq), 1)
- end if
-c
- 20 continue
-c
- if (howmny .eq. 'A') then
-c
-c %--------------------------------------------%
-c | Compute the NCONV wanted eigenvectors of T |
-c | located in workl(iuptri,ldq). |
-c %--------------------------------------------%
-c
- do 30 j=1, ncv
- if (j .le. nconv) then
- select(j) = .true.
- else
- select(j) = .false.
- end if
- 30 continue
-c
- call dtrevc ('Right', 'Select', select, ncv, workl(iuptri),
- & ldq, vl, 1, workl(invsub), ldq, ncv, outncv, workev,
- & ierr)
-c
- if (ierr .ne. 0) then
- info = -9
- go to 9000
- end if
-c
-c %------------------------------------------------%
-c | Scale the returning eigenvectors so that their |
-c | Euclidean norms are all one. LAPACK subroutine |
-c | dtrevc returns each eigenvector normalized so |
-c | that the element of largest magnitude has |
-c | magnitude 1; |
-c %------------------------------------------------%
-c
- iconj = 0
- do 40 j=1, nconv
-c
- if ( workl(iheigi+j-1) .eq. zero ) then
-c
-c %----------------------%
-c | real eigenvalue case |
-c %----------------------%
-c
- temp = dnrm2( ncv, workl(invsub+(j-1)*ldq), 1 )
- call dscal ( ncv, one / temp,
- & workl(invsub+(j-1)*ldq), 1 )
-c
- else
-c
-c %-------------------------------------------%
-c | Complex conjugate pair case. Note that |
-c | since the real and imaginary part of |
-c | the eigenvector are stored in consecutive |
-c | columns, we further normalize by the |
-c | square root of two. |
-c %-------------------------------------------%
-c
- if (iconj .eq. 0) then
- temp = dlapy2( dnrm2( ncv, workl(invsub+(j-1)*ldq),
- & 1 ), dnrm2( ncv, workl(invsub+j*ldq), 1) )
- call dscal ( ncv, one / temp,
- & workl(invsub+(j-1)*ldq), 1 )
- call dscal ( ncv, one / temp,
- & workl(invsub+j*ldq), 1 )
- iconj = 1
- else
- iconj = 0
- end if
-c
- end if
-c
- 40 continue
-c
- call dgemv('T', ncv, nconv, one, workl(invsub),
- & ldq, workl(ihbds), 1, zero, workev, 1)
-c
- iconj = 0
- do 45 j=1, nconv
- if (workl(iheigi+j-1) .ne. zero) then
-c
-c %-------------------------------------------%
-c | Complex conjugate pair case. Note that |
-c | since the real and imaginary part of |
-c | the eigenvector are stored in consecutive |
-c %-------------------------------------------%
-c
- if (iconj .eq. 0) then
- workev(j) = dlapy2(workev(j), workev(j+1))
- workev(j+1) = workev(j)
- iconj = 1
- else
- iconj = 0
- end if
- end if
- 45 continue
-c
- if (msglvl .gt. 2) then
- call dcopy(ncv, workl(invsub+ncv-1), ldq,
- & workl(ihbds), 1)
- call igraphdvout (logfil, ncv, workl(ihbds), ndigit,
- & '_neupd: Last row of the eigenvector matrix for T')
- if (msglvl .gt. 3) then
- call igraphdmout (logfil, ncv, ncv, workl(invsub),
- & ldq, ndigit,
- & '_neupd: The eigenvector matrix for T')
- end if
- end if
-c
-c %---------------------------------------%
-c | Copy Ritz estimates into workl(ihbds) |
-c %---------------------------------------%
-c
- call dcopy(nconv, workev, 1, workl(ihbds), 1)
-c
-c %---------------------------------------------------------%
-c | Compute the QR factorization of the eigenvector matrix |
-c | associated with leading portion of T in the first NCONV |
-c | columns of workl(invsub,ldq). |
-c %---------------------------------------------------------%
-c
- call dgeqr2 (ncv, nconv, workl(invsub), ldq, workev,
- & workev(ncv+1), ierr)
-c
-c %----------------------------------------------%
-c | * Postmultiply Z by Q. |
-c | * Postmultiply Z by R. |
-c | The N by NCONV matrix Z is now contains the |
-c | Ritz vectors associated with the Ritz values |
-c | in workl(iheigr) and workl(iheigi). |
-c %----------------------------------------------%
-c
- call dorm2r ('Right', 'Notranspose', n, ncv, nconv,
- & workl(invsub), ldq, workev, z, ldz, workd(n+1), ierr)
-c
- call dtrmm ('Right', 'Upper', 'No transpose', 'Non-unit',
- & n, nconv, one, workl(invsub), ldq, z, ldz)
-c
- end if
-c
- else
-c
-c %------------------------------------------------------%
-c | An approximate invariant subspace is not needed. |
-c | Place the Ritz values computed DNAUPD into DR and DI |
-c %------------------------------------------------------%
-c
- call dcopy (nconv, workl(ritzr), 1, dr, 1)
- call dcopy (nconv, workl(ritzi), 1, di, 1)
- call dcopy (nconv, workl(ritzr), 1, workl(iheigr), 1)
- call dcopy (nconv, workl(ritzi), 1, workl(iheigi), 1)
- call dcopy (nconv, workl(bounds), 1, workl(ihbds), 1)
- end if
-c
-c %------------------------------------------------%
-c | Transform the Ritz values and possibly vectors |
-c | and corresponding error bounds of OP to those |
-c | of A*x = lambda*B*x. |
-c %------------------------------------------------%
-c
- if (type .eq. 'REGULR') then
-c
- if (rvec)
- & call dscal (ncv, rnorm, workl(ihbds), 1)
-c
- else
-c
-c %---------------------------------------%
-c | A spectral transformation was used. |
-c | * Determine the Ritz estimates of the |
-c | Ritz values in the original system. |
-c %---------------------------------------%
-c
- if (type .eq. 'SHIFTI') then
-c
- if (rvec)
- & call dscal (ncv, rnorm, workl(ihbds), 1)
-c
- do 50 k=1, ncv
- temp = dlapy2( workl(iheigr+k-1),
- & workl(iheigi+k-1) )
- workl(ihbds+k-1) = abs( workl(ihbds+k-1) )
- & / temp / temp
- 50 continue
-c
- else if (type .eq. 'REALPT') then
-c
- do 60 k=1, ncv
- 60 continue
-c
- else if (type .eq. 'IMAGPT') then
-c
- do 70 k=1, ncv
- 70 continue
-c
- end if
-c
-c %-----------------------------------------------------------%
-c | * Transform the Ritz values back to the original system. |
-c | For TYPE = 'SHIFTI' the transformation is |
-c | lambda = 1/theta + sigma |
-c | For TYPE = 'REALPT' or 'IMAGPT' the user must from |
-c | Rayleigh quotients or a projection. See remark 3 above.|
-c | NOTES: |
-c | *The Ritz vectors are not affected by the transformation. |
-c %-----------------------------------------------------------%
-c
- if (type .eq. 'SHIFTI') then
-c
- do 80 k=1, ncv
- temp = dlapy2( workl(iheigr+k-1),
- & workl(iheigi+k-1) )
- workl(iheigr+k-1) = workl(iheigr+k-1) / temp / temp
- & + sigmar
- workl(iheigi+k-1) = -workl(iheigi+k-1) / temp / temp
- & + sigmai
- 80 continue
-c
- call dcopy (nconv, workl(iheigr), 1, dr, 1)
- call dcopy (nconv, workl(iheigi), 1, di, 1)
-c
- else if (type .eq. 'REALPT' .or. type .eq. 'IMAGPT') then
-c
- call dcopy (nconv, workl(iheigr), 1, dr, 1)
- call dcopy (nconv, workl(iheigi), 1, di, 1)
-c
- end if
-c
- end if
-c
- if (type .eq. 'SHIFTI' .and. msglvl .gt. 1) then
- call igraphdvout (logfil, nconv, dr, ndigit,
- & '_neupd: Untransformed real part of the Ritz valuess.')
- call igraphdvout (logfil, nconv, di, ndigit,
- & '_neupd: Untransformed imag part of the Ritz valuess.')
- call igraphdvout (logfil, nconv, workl(ihbds), ndigit,
- & '_neupd: Ritz estimates of untransformed Ritz values.')
- else if (type .eq. 'REGULR' .and. msglvl .gt. 1) then
- call igraphdvout (logfil, nconv, dr, ndigit,
- & '_neupd: Real parts of converged Ritz values.')
- call igraphdvout (logfil, nconv, di, ndigit,
- & '_neupd: Imag parts of converged Ritz values.')
- call igraphdvout (logfil, nconv, workl(ihbds), ndigit,
- & '_neupd: Associated Ritz estimates.')
- end if
-c
-c %-------------------------------------------------%
-c | Eigenvector Purification step. Formally perform |
-c | one of inverse subspace iteration. Only used |
-c | for MODE = 2. |
-c %-------------------------------------------------%
-c
- if (rvec .and. howmny .eq. 'A' .and. type .eq. 'SHIFTI') then
-c
-c %------------------------------------------------%
-c | Purify the computed Ritz vectors by adding a |
-c | little bit of the residual vector: |
-c | T |
-c | resid(:)*( e s ) / theta |
-c | NCV |
-c | where H s = s theta. Remember that when theta |
-c | has nonzero imaginary part, the corresponding |
-c | Ritz vector is stored across two columns of Z. |
-c %------------------------------------------------%
-c
- iconj = 0
- do 110 j=1, nconv
- if (workl(iheigi+j-1) .eq. zero) then
- workev(j) = workl(invsub+(j-1)*ldq+ncv-1) /
- & workl(iheigr+j-1)
- else if (iconj .eq. 0) then
- temp = dlapy2( workl(iheigr+j-1), workl(iheigi+j-1) )
- workev(j) = ( workl(invsub+(j-1)*ldq+ncv-1) *
- & workl(iheigr+j-1) +
- & workl(invsub+j*ldq+ncv-1) *
- & workl(iheigi+j-1) ) / temp / temp
- workev(j+1) = ( workl(invsub+j*ldq+ncv-1) *
- & workl(iheigr+j-1) -
- & workl(invsub+(j-1)*ldq+ncv-1) *
- & workl(iheigi+j-1) ) / temp / temp
- iconj = 1
- else
- iconj = 0
- end if
- 110 continue
-c
-c %---------------------------------------%
-c | Perform a rank one update to Z and |
-c | purify all the Ritz vectors together. |
-c %---------------------------------------%
-c
- call dger (n, nconv, one, resid, 1, workev, 1, z, ldz)
-c
- end if
-c
- 9000 continue
-c
- return
-c
-c %---------------%
-c | End of DNEUPD |
-c %---------------%
-c
- end
diff --git a/src/dngets.f b/src/dngets.f
deleted file mode 100644
index 0202090..0000000
--- a/src/dngets.f
+++ /dev/null
@@ -1,231 +0,0 @@
-c-----------------------------------------------------------------------
-c\BeginDoc
-c
-c\Name: igraphdngets
-c
-c\Description:
-c Given the eigenvalues of the upper Hessenberg matrix H,
-c computes the NP shifts AMU that are zeros of the polynomial of
-c degree NP which filters out components of the unwanted eigenvectors
-c corresponding to the AMU's based on some given criteria.
-c
-c NOTE: call this even in the case of user specified shifts in order
-c to sort the eigenvalues, and error bounds of H for later use.
-c
-c\Usage:
-c call igraphdngets
-c ( ISHIFT, WHICH, KEV, NP, RITZR, RITZI, BOUNDS, SHIFTR, SHIFTI )
-c
-c\Arguments
-c ISHIFT Integer. (INPUT)
-c Method for selecting the implicit shifts at each iteration.
-c ISHIFT = 0: user specified shifts
-c ISHIFT = 1: exact shift with respect to the matrix H.
-c
-c WHICH Character*2. (INPUT)
-c Shift selection criteria.
-c 'LM' -> want the KEV eigenvalues of largest magnitude.
-c 'SM' -> want the KEV eigenvalues of smallest magnitude.
-c 'LR' -> want the KEV eigenvalues of largest real part.
-c 'SR' -> want the KEV eigenvalues of smallest real part.
-c 'LI' -> want the KEV eigenvalues of largest imaginary part.
-c 'SI' -> want the KEV eigenvalues of smallest imaginary part.
-c
-c KEV Integer. (INPUT/OUTPUT)
-c INPUT: KEV+NP is the size of the matrix H.
-c OUTPUT: Possibly increases KEV by one to keep complex conjugate
-c pairs together.
-c
-c NP Integer. (INPUT/OUTPUT)
-c Number of implicit shifts to be computed.
-c OUTPUT: Possibly decreases NP by one to keep complex conjugate
-c pairs together.
-c
-c RITZR, Double precision array of length KEV+NP. (INPUT/OUTPUT)
-c RITZI On INPUT, RITZR and RITZI contain the real and imaginary
-c parts of the eigenvalues of H.
-c On OUTPUT, RITZR and RITZI are sorted so that the unwanted
-c eigenvalues are in the first NP locations and the wanted
-c portion is in the last KEV locations. When exact shifts are
-c selected, the unwanted part corresponds to the shifts to
-c be applied. Also, if ISHIFT .eq. 1, the unwanted eigenvalues
-c are further sorted so that the ones with largest Ritz values
-c are first.
-c
-c BOUNDS Double precision array of length KEV+NP. (INPUT/OUTPUT)
-c Error bounds corresponding to the ordering in RITZ.
-c
-c SHIFTR, SHIFTI *** USE deprecated as of version 2.1. ***
-c
-c
-c\EndDoc
-c
-c-----------------------------------------------------------------------
-c
-c\BeginLib
-c
-c\Local variables:
-c xxxxxx real
-c
-c\Routines called:
-c igraphdsortc ARPACK sorting routine.
-c dcopy Level 1 BLAS that copies one vector to another .
-c
-c\Author
-c Danny Sorensen Phuong Vu
-c Richard Lehoucq CRPC / Rice University
-c Dept. of Computational & Houston, Texas
-c Applied Mathematics
-c Rice University
-c Houston, Texas
-c
-c\Revision history:
-c xx/xx/92: Version ' 2.1'
-c
-c\SCCS Information: @(#)
-c FILE: ngets.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2
-c
-c\Remarks
-c 1. xxxx
-c
-c\EndLib
-c
-c-----------------------------------------------------------------------
-c
- subroutine igraphdngets ( ishift, which, kev, np, ritzr, ritzi,
- & bounds, shiftr, shifti )
-c
-c %----------------------------------------------------%
-c | Include files for debugging and timing information |
-c %----------------------------------------------------%
-c
- include 'debug.h'
- include 'stat.h'
-c
-c %------------------%
-c | Scalar Arguments |
-c %------------------%
-c
- character*2 which
- integer ishift, kev, np
-c
-c %-----------------%
-c | Array Arguments |
-c %-----------------%
-c
- Double precision
- & bounds(kev+np), ritzr(kev+np), ritzi(kev+np),
- & shiftr(1), shifti(1)
-c
-c %------------%
-c | Parameters |
-c %------------%
-c
- Double precision
- & one, zero
- parameter (one = 1.0, zero = 0.0)
-c
-c %---------------%
-c | Local Scalars |
-c %---------------%
-c
- integer msglvl
-c
-c %----------------------%
-c | External Subroutines |
-c %----------------------%
-c
- external dcopy, igraphdsortc, igraphsecond
-c
-c %----------------------%
-c | Intrinsics Functions |
-c %----------------------%
-c
- intrinsic abs
-c
-c %-----------------------%
-c | Executable Statements |
-c %-----------------------%
-c
-c %-------------------------------%
-c | Initialize timing statistics |
-c | & message level for debugging |
-c %-------------------------------%
-c
- call igraphsecond (t0)
- msglvl = mngets
-c
-c %----------------------------------------------------%
-c | LM, SM, LR, SR, LI, SI case. |
-c | Sort the eigenvalues of H into the desired order |
-c | and apply the resulting order to BOUNDS. |
-c | The eigenvalues are sorted so that the wanted part |
-c | are always in the last KEV locations. |
-c | We first do a pre-processing sort in order to keep |
-c | complex conjugate pairs together |
-c %----------------------------------------------------%
-c
- if (which .eq. 'LM') then
- call igraphdsortc ('LR', .true., kev+np, ritzr, ritzi, bounds)
- else if (which .eq. 'SM') then
- call igraphdsortc ('SR', .true., kev+np, ritzr, ritzi, bounds)
- else if (which .eq. 'LR') then
- call igraphdsortc ('LM', .true., kev+np, ritzr, ritzi, bounds)
- else if (which .eq. 'SR') then
- call igraphdsortc ('SM', .true., kev+np, ritzr, ritzi, bounds)
- else if (which .eq. 'LI') then
- call igraphdsortc ('LM', .true., kev+np, ritzr, ritzi, bounds)
- else if (which .eq. 'SI') then
- call igraphdsortc ('SM', .true., kev+np, ritzr, ritzi, bounds)
- end if
-c
- call igraphdsortc (which, .true., kev+np, ritzr, ritzi, bounds)
-c
-c %-------------------------------------------------------%
-c | Increase KEV by one if the ( ritzr(np),ritzi(np) ) |
-c | = ( ritzr(np+1),-ritzi(np+1) ) and ritz(np) .ne. zero |
-c | Accordingly decrease NP by one. In other words keep |
-c | complex conjugate pairs together. |
-c %-------------------------------------------------------%
-c
- if ( ( ritzr(np+1) - ritzr(np) ) .eq. zero
- & .and. ( ritzi(np+1) + ritzi(np) ) .eq. zero ) then
- np = np - 1
- kev = kev + 1
- end if
-c
- if ( ishift .eq. 1 ) then
-c
-c %-------------------------------------------------------%
-c | Sort the unwanted Ritz values used as shifts so that |
-c | the ones with largest Ritz estimates are first |
-c | This will tend to minimize the effects of the |
-c | forward instability of the iteration when they shifts |
-c | are applied in subroutine igraphdnapps. |
-c | Be careful and use 'SR' since we want to sort BOUNDS! |
-c %-------------------------------------------------------%
-c
- call igraphdsortc ( 'SR', .true., np, bounds, ritzr, ritzi )
- end if
-c
- call igraphsecond (t1)
- tngets = tngets + (t1 - t0)
-c
- if (msglvl .gt. 0) then
- call igraphivout (logfil, 1, [kev], ndigit, '_ngets: KEV is')
- call igraphivout (logfil, 1, [np], ndigit, '_ngets: NP is')
- call igraphdvout (logfil, kev+np, ritzr, ndigit,
- & '_ngets: Eigenvalues of current H matrix -- real part')
- call igraphdvout (logfil, kev+np, ritzi, ndigit,
- & '_ngets: Eigenvalues of current H matrix -- imag part')
- call igraphdvout (logfil, kev+np, bounds, ndigit,
- & '_ngets: Ritz estimates of the current KEV+NP Ritz values')
- end if
-c
- return
-c
-c %---------------%
-c | End of igraphdngets |
-c %---------------%
-c
- end
diff --git a/src/dsaitr.f b/src/dsaitr.f
deleted file mode 100644
index 4a4698c..0000000
--- a/src/dsaitr.f
+++ /dev/null
@@ -1,854 +0,0 @@
-c-----------------------------------------------------------------------
-c\BeginDoc
-c
-c\Name: igraphdsaitr
-c
-c\Description:
-c Reverse communication interface for applying NP additional steps to
-c a K step symmetric Arnoldi factorization.
-c
-c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T
-c
-c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0.
-c
-c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T
-c
-c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0.
-c
-c where OP and B are as in igraphdsaupd. The B-norm of r_{k+p} is also
-c computed and returned.
-c
-c\Usage:
-c call igraphdsaitr
-c ( IDO, BMAT, N, K, NP, MODE, RESID, RNORM, V, LDV, H, LDH,
-c IPNTR, WORKD, INFO )
-c
-c\Arguments
-c IDO Integer. (INPUT/OUTPUT)
-c Reverse communication flag.
-c -------------------------------------------------------------
-c IDO = 0: first call to the reverse communication interface
-c IDO = -1: compute Y = OP * X where
-c IPNTR(1) is the pointer into WORK for X,
-c IPNTR(2) is the pointer into WORK for Y.
-c This is for the restart phase to force the new
-c starting vector into the range of OP.
-c IDO = 1: compute Y = OP * X where
-c IPNTR(1) is the pointer into WORK for X,
-c IPNTR(2) is the pointer into WORK for Y,
-c IPNTR(3) is the pointer into WORK for B * X.
-c IDO = 2: compute Y = B * X where
-c IPNTR(1) is the pointer into WORK for X,
-c IPNTR(2) is the pointer into WORK for Y.
-c IDO = 99: done
-c -------------------------------------------------------------
-c When the routine is used in the "shift-and-invert" mode, the
-c vector B * Q is already available and does not need to be
-c recomputed in forming OP * Q.
-c
-c BMAT Character*1. (INPUT)
-c BMAT specifies the type of matrix B that defines the
-c semi-inner product for the operator OP. See igraphdsaupd.
-c B = 'I' -> standard eigenvalue problem A*x = lambda*x
-c B = 'G' -> generalized eigenvalue problem A*x = lambda*M*x
-c
-c N Integer. (INPUT)
-c Dimension of the eigenproblem.
-c
-c K Integer. (INPUT)
-c Current order of H and the number of columns of V.
-c
-c NP Integer. (INPUT)
-c Number of additional Arnoldi steps to take.
-c
-c MODE Integer. (INPUT)
-c Signifies which form for "OP". If MODE=2 then
-c a reduction in the number of B matrix vector multiplies
-c is possible since the B-norm of OP*x is equivalent to
-c the inv(B)-norm of A*x.
-c
-c RESID Double precision array of length N. (INPUT/OUTPUT)
-c On INPUT: RESID contains the residual vector r_{k}.
-c On OUTPUT: RESID contains the residual vector r_{k+p}.
-c
-c RNORM Double precision scalar. (INPUT/OUTPUT)
-c On INPUT the B-norm of r_{k}.
-c On OUTPUT the B-norm of the updated residual r_{k+p}.
-c
-c V Double precision N by K+NP array. (INPUT/OUTPUT)
-c On INPUT: V contains the Arnoldi vectors in the first K
-c columns.
-c On OUTPUT: V contains the new NP Arnoldi vectors in the next
-c NP columns. The first K columns are unchanged.
-c
-c LDV Integer. (INPUT)
-c Leading dimension of V exactly as declared in the calling
-c program.
-c
-c H Double precision (K+NP) by 2 array. (INPUT/OUTPUT)
-c H is used to store the generated symmetric tridiagonal matrix
-c with the subdiagonal in the first column starting at H(2,1)
-c and the main diagonal in the igraphsecond column.
-c
-c LDH Integer. (INPUT)
-c Leading dimension of H exactly as declared in the calling
-c program.
-c
-c IPNTR Integer array of length 3. (OUTPUT)
-c Pointer to mark the starting locations in the WORK for
-c vectors used by the Arnoldi iteration.
-c -------------------------------------------------------------
-c IPNTR(1): pointer to the current operand vector X.
-c IPNTR(2): pointer to the current result vector Y.
-c IPNTR(3): pointer to the vector B * X when used in the
-c shift-and-invert mode. X is the current operand.
-c -------------------------------------------------------------
-c
-c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION)
-c Distributed array to be used in the basic Arnoldi iteration
-c for reverse communication. The calling program should not
-c use WORKD as temporary workspace during the iteration !!!!!!
-c On INPUT, WORKD(1:N) = B*RESID where RESID is associated
-c with the K step Arnoldi factorization. Used to save some
-c computation at the first step.
-c On OUTPUT, WORKD(1:N) = B*RESID where RESID is associated
-c with the K+NP step Arnoldi factorization.
-c
-c INFO Integer. (OUTPUT)
-c = 0: Normal exit.
-c > 0: Size of an invariant subspace of OP is found that is
-c less than K + NP.
-c
-c\EndDoc
-c
-c-----------------------------------------------------------------------
-c
-c\BeginLib
-c
-c\Local variables:
-c xxxxxx real
-c
-c\Routines called:
-c igraphdgetv0 ARPACK routine to generate the initial vector.
-c igraphivout ARPACK utility routine that prints integers.
-c igraphdmout ARPACK utility routine that prints matrices.
-c igraphdvout ARPACK utility routine that prints vectors.
-c dlamch LAPACK routine that determines machine constants.
-c dlascl LAPACK routine for careful scaling of a matrix.
-c dgemv Level 2 BLAS routine for matrix vector multiplication.
-c daxpy Level 1 BLAS that computes a vector triad.
-c dscal Level 1 BLAS that scales a vector.
-c dcopy Level 1 BLAS that copies one vector to another .
-c ddot Level 1 BLAS that computes the scalar product of two vectors.
-c dnrm2 Level 1 BLAS that computes the norm of a vector.
-c
-c\Author
-c Danny Sorensen Phuong Vu
-c Richard Lehoucq CRPC / Rice University
-c Dept. of Computational & Houston, Texas
-c Applied Mathematics
-c Rice University
-c Houston, Texas
-c
-c\Revision history:
-c xx/xx/93: Version ' 2.4'
-c
-c\SCCS Information: @(#)
-c FILE: saitr.F SID: 2.6 DATE OF SID: 8/28/96 RELEASE: 2
-c
-c\Remarks
-c The algorithm implemented is:
-c
-c restart = .false.
-c Given V_{k} = [v_{1}, ..., v_{k}], r_{k};
-c r_{k} contains the initial residual vector even for k = 0;
-c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already
-c computed by the calling program.
-c
-c betaj = rnorm ; p_{k+1} = B*r_{k} ;
-c For j = k+1, ..., k+np Do
-c 1) if ( betaj < tol ) stop or restart depending on j.
-c if ( restart ) generate a new starting vector.
-c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}];
-c p_{j} = p_{j}/betaj
-c 3) r_{j} = OP*v_{j} where OP is defined as in igraphdsaupd
-c For shift-invert mode p_{j} = B*v_{j} is already available.
-c wnorm = || OP*v_{j} ||
-c 4) Compute the j-th step residual vector.
-c w_{j} = V_{j}^T * B * OP * v_{j}
-c r_{j} = OP*v_{j} - V_{j} * w_{j}
-c alphaj <- j-th component of w_{j}
-c rnorm = || r_{j} ||
-c betaj+1 = rnorm
-c If (rnorm > 0.717*wnorm) accept step and go back to 1)
-c 5) Re-orthogonalization step:
-c s = V_{j}'*B*r_{j}
-c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} ||
-c alphaj = alphaj + s_{j};
-c 6) Iterative refinement step:
-c If (rnorm1 > 0.717*rnorm) then
-c rnorm = rnorm1
-c accept step and go back to 1)
-c Else
-c rnorm = rnorm1
-c If this is the first time in step 6), go to 5)
-c Else r_{j} lies in the span of V_{j} numerically.
-c Set r_{j} = 0 and rnorm = 0; go to 1)
-c EndIf
-c End Do
-c
-c\EndLib
-c
-c-----------------------------------------------------------------------
-c
- subroutine igraphdsaitr
- & (ido, bmat, n, k, np, mode, resid, rnorm, v, ldv, h, ldh,
- & ipntr, workd, info)
-c
-c %----------------------------------------------------%
-c | Include files for debugging and timing information |
-c %----------------------------------------------------%
-c
- include 'debug.h'
- include 'stat.h'
-c
-c %------------------%
-c | Scalar Arguments |
-c %------------------%
-c
- character bmat*1
- integer ido, info, k, ldh, ldv, n, mode, np
- Double precision
- & rnorm
-c
-c %-----------------%
-c | Array Arguments |
-c %-----------------%
-c
- integer ipntr(3)
- Double precision
- & h(ldh,2), resid(n), v(ldv,k+np), workd(3*n)
-c
-c %------------%
-c | Parameters |
-c %------------%
-c
- Double precision
- & one, zero
- parameter (one = 1.0D+0, zero = 0.0D+0)
-c
-c %---------------%
-c | Local Scalars |
-c %---------------%
-c
- logical first, orth1, orth2, rstart, step3, step4
- integer i, ierr, ipj, irj, ivj, iter, itry, j, msglvl,
- & infol, jj
- Double precision
- & rnorm1, wnorm, safmin, temp1
- save orth1, orth2, rstart, step3, step4,
- & ierr, ipj, irj, ivj, iter, itry, j, msglvl,
- & rnorm1, safmin, wnorm
-c
-c %-----------------------%
-c | Local Array Arguments |
-c %-----------------------%
-c
- Double precision
- & xtemp(2)
-c
-c %----------------------%
-c | External Subroutines |
-c %----------------------%
-c
- external daxpy, dcopy, dscal, dgemv, igraphdgetv0,
- & igraphdvout, igraphdmout,
- & dlascl, igraphivout, igraphsecond
-c
-c %--------------------%
-c | External Functions |
-c %--------------------%
-c
- Double precision
- & ddot, dnrm2, dlamch
- external ddot, dnrm2, dlamch
-c
-c %-----------------%
-c | Data statements |
-c %-----------------%
-c
- data first / .true. /
-c
-c %-----------------------%
-c | Executable Statements |
-c %-----------------------%
-c
- if (first) then
- first = .false.
-c
-c %--------------------------------%
-c | safmin = safe minimum is such |
-c | that 1/sfmin does not overflow |
-c %--------------------------------%
-c
- safmin = dlamch('safmin')
- end if
-c
- if (ido .eq. 0) then
-c
-c %-------------------------------%
-c | Initialize timing statistics |
-c | & message level for debugging |
-c %-------------------------------%
-c
- call igraphsecond (t0)
- msglvl = msaitr
-c
-c %------------------------------%
-c | Initial call to this routine |
-c %------------------------------%
-c
- info = 0
- step3 = .false.
- step4 = .false.
- rstart = .false.
- orth1 = .false.
- orth2 = .false.
-c
-c %--------------------------------%
-c | Pointer to the current step of |
-c | the factorization to build |
-c %--------------------------------%
-c
- j = k + 1
-c
-c %------------------------------------------%
-c | Pointers used for reverse communication |
-c | when using WORKD. |
-c %------------------------------------------%
-c
- ipj = 1
- irj = ipj + n
- ivj = irj + n
- end if
-c
-c %-------------------------------------------------%
-c | When in reverse communication mode one of: |
-c | STEP3, STEP4, ORTH1, ORTH2, RSTART |
-c | will be .true. |
-c | STEP3: return from computing OP*v_{j}. |
-c | STEP4: return from computing B-norm of OP*v_{j} |
-c | ORTH1: return from computing B-norm of r_{j+1} |
-c | ORTH2: return from computing B-norm of |
-c | correction to the residual vector. |
-c | RSTART: return from OP computations needed by |
-c | igraphdgetv0. |
-c %-------------------------------------------------%
-c
- if (step3) go to 50
- if (step4) go to 60
- if (orth1) go to 70
- if (orth2) go to 90
- if (rstart) go to 30
-c
-c %------------------------------%
-c | Else this is the first step. |
-c %------------------------------%
-c
-c %--------------------------------------------------------------%
-c | |
-c | A R N O L D I I T E R A T I O N L O O P |
-c | |
-c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) |
-c %--------------------------------------------------------------%
-c
- 1000 continue
-c
- if (msglvl .gt. 2) then
- call igraphivout (logfil, 1, [j], ndigit,
- & '_saitr: generating Arnoldi vector no.')
- call igraphdvout (logfil, 1, [rnorm], ndigit,
- & '_saitr: B-norm of the current residual =')
- end if
-c
-c %---------------------------------------------------------%
-c | Check for exact zero. Equivalent to determing whether a |
-c | j-step Arnoldi factorization is present. |
-c %---------------------------------------------------------%
-c
- if (rnorm .gt. zero) go to 40
-c
-c %---------------------------------------------------%
-c | Invariant subspace found, generate a new starting |
-c | vector which is orthogonal to the current Arnoldi |
-c | basis and continue the iteration. |
-c %---------------------------------------------------%
-c
- if (msglvl .gt. 0) then
- call igraphivout (logfil, 1, [j], ndigit,
- & '_saitr: ****** restart at step ******')
- end if
-c
-c %---------------------------------------------%
-c | ITRY is the loop variable that controls the |
-c | maximum amount of times that a restart is |
-c | attempted. NRSTRT is used by stat.h |
-c %---------------------------------------------%
-c
- nrstrt = nrstrt + 1
- itry = 1
- 20 continue
- rstart = .true.
- ido = 0
- 30 continue
-c
-c %--------------------------------------%
-c | If in reverse communication mode and |
-c | RSTART = .true. flow returns here. |
-c %--------------------------------------%
-c
- call igraphdgetv0 (ido, bmat, itry, .false., n, j, v, ldv,
- & resid, rnorm, ipntr, workd, ierr)
- if (ido .ne. 99) go to 9000
- if (ierr .lt. 0) then
- itry = itry + 1
- if (itry .le. 3) go to 20
-c
-c %------------------------------------------------%
-c | Give up after several restart attempts. |
-c | Set INFO to the size of the invariant subspace |
-c | which spans OP and exit. |
-c %------------------------------------------------%
-c
- info = j - 1
- call igraphsecond (t1)
- tsaitr = tsaitr + (t1 - t0)
- ido = 99
- go to 9000
- end if
-c
- 40 continue
-c
-c %---------------------------------------------------------%
-c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm |
-c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow |
-c | when reciprocating a small RNORM, test against lower |
-c | machine bound. |
-c %---------------------------------------------------------%
-c
- call dcopy (n, resid, 1, v(1,j), 1)
- if (rnorm .ge. safmin) then
- temp1 = one / rnorm
- call dscal (n, temp1, v(1,j), 1)
- call dscal (n, temp1, workd(ipj), 1)
- else
-c
-c %-----------------------------------------%
-c | To scale both v_{j} and p_{j} carefully |
-c | use LAPACK routine SLASCL |
-c %-----------------------------------------%
-c
- call dlascl ('General', i, i, rnorm, one, n, 1,
- & v(1,j), n, infol)
- call dlascl ('General', i, i, rnorm, one, n, 1,
- & workd(ipj), n, infol)
- end if
-c
-c %------------------------------------------------------%
-c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} |
-c | Note that this is not quite yet r_{j}. See STEP 4 |
-c %------------------------------------------------------%
-c
- step3 = .true.
- nopx = nopx + 1
- call igraphsecond (t2)
- call dcopy (n, v(1,j), 1, workd(ivj), 1)
- ipntr(1) = ivj
- ipntr(2) = irj
- ipntr(3) = ipj
- ido = 1
-c
-c %-----------------------------------%
-c | Exit in order to compute OP*v_{j} |
-c %-----------------------------------%
-c
- go to 9000
- 50 continue
-c
-c %-----------------------------------%
-c | Back from reverse communication; |
-c | WORKD(IRJ:IRJ+N-1) := OP*v_{j}. |
-c %-----------------------------------%
-c
- call igraphsecond (t3)
- tmvopx = tmvopx + (t3 - t2)
-c
- step3 = .false.
-c
-c %------------------------------------------%
-c | Put another copy of OP*v_{j} into RESID. |
-c %------------------------------------------%
-c
- call dcopy (n, workd(irj), 1, resid, 1)
-c
-c %-------------------------------------------%
-c | STEP 4: Finish extending the symmetric |
-c | Arnoldi to length j. If MODE = 2 |
-c | then B*OP = B*inv(B)*A = A and |
-c | we don't need to compute B*OP. |
-c | NOTE: If MODE = 2 WORKD(IVJ:IVJ+N-1) is |
-c | assumed to have A*v_{j}. |
-c %-------------------------------------------%
-c
- if (mode .eq. 2) go to 65
- call igraphsecond (t2)
- if (bmat .eq. 'G') then
- nbx = nbx + 1
- step4 = .true.
- ipntr(1) = irj
- ipntr(2) = ipj
- ido = 2
-c
-c %-------------------------------------%
-c | Exit in order to compute B*OP*v_{j} |
-c %-------------------------------------%
-c
- go to 9000
- else if (bmat .eq. 'I') then
- call dcopy(n, resid, 1 , workd(ipj), 1)
- end if
- 60 continue
-c
-c %-----------------------------------%
-c | Back from reverse communication; |
-c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j}. |
-c %-----------------------------------%
-c
- if (bmat .eq. 'G') then
- call igraphsecond (t3)
- tmvbx = tmvbx + (t3 - t2)
- end if
-c
- step4 = .false.
-c
-c %-------------------------------------%
-c | The following is needed for STEP 5. |
-c | Compute the B-norm of OP*v_{j}. |
-c %-------------------------------------%
-c
- 65 continue
- if (mode .eq. 2) then
-c
-c %----------------------------------%
-c | Note that the B-norm of OP*v_{j} |
-c | is the inv(B)-norm of A*v_{j}. |
-c %----------------------------------%
-c
- wnorm = ddot (n, resid, 1, workd(ivj), 1)
- wnorm = sqrt(abs(wnorm))
- else if (bmat .eq. 'G') then
- wnorm = ddot (n, resid, 1, workd(ipj), 1)
- wnorm = sqrt(abs(wnorm))
- else if (bmat .eq. 'I') then
- wnorm = dnrm2(n, resid, 1)
- end if
-c
-c %-----------------------------------------%
-c | Compute the j-th residual corresponding |
-c | to the j step factorization. |
-c | Use Classical Gram Schmidt and compute: |
-c | w_{j} <- V_{j}^T * B * OP * v_{j} |
-c | r_{j} <- OP*v_{j} - V_{j} * w_{j} |
-c %-----------------------------------------%
-c
-c
-c %------------------------------------------%
-c | Compute the j Fourier coefficients w_{j} |
-c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. |
-c %------------------------------------------%
-c
- if (mode .ne. 2 ) then
- call dgemv('T', n, j, one, v, ldv, workd(ipj), 1, zero,
- & workd(irj), 1)
- else if (mode .eq. 2) then
- call dgemv('T', n, j, one, v, ldv, workd(ivj), 1, zero,
- & workd(irj), 1)
- end if
-c
-c %--------------------------------------%
-c | Orthgonalize r_{j} against V_{j}. |
-c | RESID contains OP*v_{j}. See STEP 3. |
-c %--------------------------------------%
-c
- call dgemv('N', n, j, -one, v, ldv, workd(irj), 1, one,
- & resid, 1)
-c
-c %--------------------------------------%
-c | Extend H to have j rows and columns. |
-c %--------------------------------------%
-c
- h(j,2) = workd(irj + j - 1)
- if (j .eq. 1 .or. rstart) then
- h(j,1) = zero
- else
- h(j,1) = rnorm
- end if
- call igraphsecond (t4)
-c
- orth1 = .true.
- iter = 0
-c
- call igraphsecond (t2)
- if (bmat .eq. 'G') then
- nbx = nbx + 1
- call dcopy (n, resid, 1, workd(irj), 1)
- ipntr(1) = irj
- ipntr(2) = ipj
- ido = 2
-c
-c %----------------------------------%
-c | Exit in order to compute B*r_{j} |
-c %----------------------------------%
-c
- go to 9000
- else if (bmat .eq. 'I') then
- call dcopy (n, resid, 1, workd(ipj), 1)
- end if
- 70 continue
-c
-c %---------------------------------------------------%
-c | Back from reverse communication if ORTH1 = .true. |
-c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. |
-c %---------------------------------------------------%
-c
- if (bmat .eq. 'G') then
- call igraphsecond (t3)
- tmvbx = tmvbx + (t3 - t2)
- end if
-c
- orth1 = .false.
-c
-c %------------------------------%
-c | Compute the B-norm of r_{j}. |
-c %------------------------------%
-c
- if (bmat .eq. 'G') then
- rnorm = ddot (n, resid, 1, workd(ipj), 1)
- rnorm = sqrt(abs(rnorm))
- else if (bmat .eq. 'I') then
- rnorm = dnrm2(n, resid, 1)
- end if
-c
-c %-----------------------------------------------------------%
-c | STEP 5: Re-orthogonalization / Iterative refinement phase |
-c | Maximum NITER_ITREF tries. |
-c | |
-c | s = V_{j}^T * B * r_{j} |
-c | r_{j} = r_{j} - V_{j}*s |
-c | alphaj = alphaj + s_{j} |
-c | |
-c | The stopping criteria used for iterative refinement is |
-c | discussed in Parlett's book SEP, page 107 and in Gragg & |
-c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. |
-c | Determine if we need to correct the residual. The goal is |
-c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || |
-c %-----------------------------------------------------------%
-c
- if (rnorm .gt. 0.717*wnorm) go to 100
- nrorth = nrorth + 1
-c
-c %---------------------------------------------------%
-c | Enter the Iterative refinement phase. If further |
-c | refinement is necessary, loop back here. The loop |
-c | variable is ITER. Perform a step of Classical |
-c | Gram-Schmidt using all the Arnoldi vectors V_{j} |
-c %---------------------------------------------------%
-c
- 80 continue
-c
- if (msglvl .gt. 2) then
- xtemp(1) = wnorm
- xtemp(2) = rnorm
- call igraphdvout (logfil, 2, xtemp, ndigit,
- & '_saitr: re-orthonalization ; wnorm and rnorm are')
- end if
-c
-c %----------------------------------------------------%
-c | Compute V_{j}^T * B * r_{j}. |
-c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). |
-c %----------------------------------------------------%
-c
- call dgemv ('T', n, j, one, v, ldv, workd(ipj), 1,
- & zero, workd(irj), 1)
-c
-c %----------------------------------------------%
-c | Compute the correction to the residual: |
-c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). |
-c | The correction to H is v(:,1:J)*H(1:J,1:J) + |
-c | v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j, but only |
-c | H(j,j) is updated. |
-c %----------------------------------------------%
-c
- call dgemv ('N', n, j, -one, v, ldv, workd(irj), 1,
- & one, resid, 1)
-c
- if (j .eq. 1 .or. rstart) h(j,1) = zero
- h(j,2) = h(j,2) + workd(irj + j - 1)
-c
- orth2 = .true.
- call igraphsecond (t2)
- if (bmat .eq. 'G') then
- nbx = nbx + 1
- call dcopy (n, resid, 1, workd(irj), 1)
- ipntr(1) = irj
- ipntr(2) = ipj
- ido = 2
-c
-c %-----------------------------------%
-c | Exit in order to compute B*r_{j}. |
-c | r_{j} is the corrected residual. |
-c %-----------------------------------%
-c
- go to 9000
- else if (bmat .eq. 'I') then
- call dcopy (n, resid, 1, workd(ipj), 1)
- end if
- 90 continue
-c
-c %---------------------------------------------------%
-c | Back from reverse communication if ORTH2 = .true. |
-c %---------------------------------------------------%
-c
- if (bmat .eq. 'G') then
- call igraphsecond (t3)
- tmvbx = tmvbx + (t3 - t2)
- end if
-c
-c %-----------------------------------------------------%
-c | Compute the B-norm of the corrected residual r_{j}. |
-c %-----------------------------------------------------%
-c
- if (bmat .eq. 'G') then
- rnorm1 = ddot (n, resid, 1, workd(ipj), 1)
- rnorm1 = sqrt(abs(rnorm1))
- else if (bmat .eq. 'I') then
- rnorm1 = dnrm2(n, resid, 1)
- end if
-c
- if (msglvl .gt. 0 .and. iter .gt. 0) then
- call igraphivout (logfil, 1, [j], ndigit,
- & '_saitr: Iterative refinement for Arnoldi residual')
- if (msglvl .gt. 2) then
- xtemp(1) = rnorm
- xtemp(2) = rnorm1
- call igraphdvout (logfil, 2, xtemp, ndigit,
- & '_saitr: iterative refinement ; rnorm and rnorm1 are')
- end if
- end if
-c
-c %-----------------------------------------%
-c | Determine if we need to perform another |
-c | step of re-orthogonalization. |
-c %-----------------------------------------%
-c
- if (rnorm1 .gt. 0.717*rnorm) then
-c
-c %--------------------------------%
-c | No need for further refinement |
-c %--------------------------------%
-c
- rnorm = rnorm1
-c
- else
-c
-c %-------------------------------------------%
-c | Another step of iterative refinement step |
-c | is required. NITREF is used by stat.h |
-c %-------------------------------------------%
-c
- nitref = nitref + 1
- rnorm = rnorm1
- iter = iter + 1
- if (iter .le. 1) go to 80
-c
-c %-------------------------------------------------%
-c | Otherwise RESID is numerically in the span of V |
-c %-------------------------------------------------%
-c
- do 95 jj = 1, n
- resid(jj) = zero
- 95 continue
- rnorm = zero
- end if
-c
-c %----------------------------------------------%
-c | Branch here directly if iterative refinement |
-c | wasn't necessary or after at most NITER_REF |
-c | steps of iterative refinement. |
-c %----------------------------------------------%
-c
- 100 continue
-c
- rstart = .false.
- orth2 = .false.
-c
- call igraphsecond (t5)
- titref = titref + (t5 - t4)
-c
-c %----------------------------------------------------------%
-c | Make sure the last off-diagonal element is non negative |
-c | If not perform a similarity transformation on H(1:j,1:j) |
-c | and scale v(:,j) by -1. |
-c %----------------------------------------------------------%
-c
- if (h(j,1) .lt. zero) then
- h(j,1) = -h(j,1)
- if ( j .lt. k+np) then
- call dscal(n, -one, v(1,j+1), 1)
- else
- call dscal(n, -one, resid, 1)
- end if
- end if
-c
-c %------------------------------------%
-c | STEP 6: Update j = j+1; Continue |
-c %------------------------------------%
-c
- j = j + 1
- if (j .gt. k+np) then
- call igraphsecond (t1)
- tsaitr = tsaitr + (t1 - t0)
- ido = 99
-c
- if (msglvl .gt. 1) then
- call igraphdvout (logfil, k+np, h(1,2), ndigit,
- & '_saitr: main diagonal of matrix H of step K+NP.')
- if (k+np .gt. 1) then
- call igraphdvout (logfil, k+np-1, h(2,1), ndigit,
- & '_saitr: sub diagonal of matrix H of step K+NP.')
- end if
- end if
-c
- go to 9000
- end if
-c
-c %--------------------------------------------------------%
-c | Loop back to extend the factorization by another step. |
-c %--------------------------------------------------------%
-c
- go to 1000
-c
-c %---------------------------------------------------------------%
-c | |
-c | E N D O F M A I N I T E R A T I O N L O O P |
-c | |
-c %---------------------------------------------------------------%
-c
- 9000 continue
- return
-c
-c %---------------%
-c | End of igraphdsaitr |
-c %---------------%
-c
- end
diff --git a/src/dsapps.f b/src/dsapps.f
deleted file mode 100644
index 850e3fd..0000000
--- a/src/dsapps.f
+++ /dev/null
@@ -1,516 +0,0 @@
-c-----------------------------------------------------------------------
-c\BeginDoc
-c
-c\Name: igraphdsapps
-c
-c\Description:
-c Given the Arnoldi factorization
-c
-c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T,
-c
-c apply NP shifts implicitly resulting in
-c
-c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q
-c
-c where Q is an orthogonal matrix of order KEV+NP. Q is the product of
-c rotations resulting from the NP bulge chasing sweeps. The updated Arnoldi
-c factorization becomes:
-c
-c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T.
-c
-c\Usage:
-c call igraphdsapps
-c ( N, KEV, NP, SHIFT, V, LDV, H, LDH, RESID, Q, LDQ, WORKD )
-c
-c\Arguments
-c N Integer. (INPUT)
-c Problem size, i.e. dimension of matrix A.
-c
-c KEV Integer. (INPUT)
-c INPUT: KEV+NP is the size of the input matrix H.
-c OUTPUT: KEV is the size of the updated matrix HNEW.
-c
-c NP Integer. (INPUT)
-c Number of implicit shifts to be applied.
-c
-c SHIFT Double precision array of length NP. (INPUT)
-c The shifts to be applied.
-c
-c V Double precision N by (KEV+NP) array. (INPUT/OUTPUT)
-c INPUT: V contains the current KEV+NP Arnoldi vectors.
-c OUTPUT: VNEW = V(1:n,1:KEV); the updated Arnoldi vectors
-c are in the first KEV columns of V.
-c
-c LDV Integer. (INPUT)
-c Leading dimension of V exactly as declared in the calling
-c program.
-c
-c H Double precision (KEV+NP) by 2 array. (INPUT/OUTPUT)
-c INPUT: H contains the symmetric tridiagonal matrix of the
-c Arnoldi factorization with the subdiagonal in the 1st column
-c starting at H(2,1) and the main diagonal in the 2nd column.
-c OUTPUT: H contains the updated tridiagonal matrix in the
-c KEV leading submatrix.
-c
-c LDH Integer. (INPUT)
-c Leading dimension of H exactly as declared in the calling
-c program.
-c
-c RESID Double precision array of length (N). (INPUT/OUTPUT)
-c INPUT: RESID contains the the residual vector r_{k+p}.
-c OUTPUT: RESID is the updated residual vector rnew_{k}.
-c
-c Q Double precision KEV+NP by KEV+NP work array. (WORKSPACE)
-c Work array used to accumulate the rotations during the bulge
-c chase sweep.
-c
-c LDQ Integer. (INPUT)
-c Leading dimension of Q exactly as declared in the calling
-c program.
-c
-c WORKD Double precision work array of length 2*N. (WORKSPACE)
-c Distributed array used in the application of the accumulated
-c orthogonal matrix Q.
-c
-c\EndDoc
-c
-c-----------------------------------------------------------------------
-c
-c\BeginLib
-c
-c\Local variables:
-c xxxxxx real
-c
-c\References:
-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
-c pp 357-385.
-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
-c Restarted Arnoldi Iteration", Rice University Technical Report
-c TR95-13, Department of Computational and Applied Mathematics.
-c
-c\Routines called:
-c igraphivout ARPACK utility routine that prints integers.
-c igraphsecond ARPACK utility routine for timing.
-c igraphdvout ARPACK utility routine that prints vectors.
-c dlamch LAPACK routine that determines machine constants.
-c dlartg LAPACK Givens rotation construction routine.
-c dlacpy LAPACK matrix copy routine.
-c dlaset LAPACK matrix initialization routine.
-c dgemv Level 2 BLAS routine for matrix vector multiplication.
-c daxpy Level 1 BLAS that computes a vector triad.
-c dcopy Level 1 BLAS that copies one vector to another.
-c dscal Level 1 BLAS that scales a vector.
-c
-c\Author
-c Danny Sorensen Phuong Vu
-c Richard Lehoucq CRPC / Rice University
-c Dept. of Computational & Houston, Texas
-c Applied Mathematics
-c Rice University
-c Houston, Texas
-c
-c\Revision history:
-c 12/16/93: Version ' 2.1'
-c
-c\SCCS Information: @(#)
-c FILE: sapps.F SID: 2.5 DATE OF SID: 4/19/96 RELEASE: 2
-c
-c\Remarks
-c 1. In this version, each shift is applied to all the subblocks of
-c the tridiagonal matrix H and not just to the submatrix that it
-c comes from. This routine assumes that the subdiagonal elements
-c of H that are stored in h(1:kev+np,1) are nonegative upon input
-c and enforce this condition upon output. This version incorporates
-c deflation. See code for documentation.
-c
-c\EndLib
-c
-c-----------------------------------------------------------------------
-c
- subroutine igraphdsapps
- & ( n, kev, np, shift, v, ldv, h, ldh, resid, q, ldq, workd )
-c
-c %----------------------------------------------------%
-c | Include files for debugging and timing information |
-c %----------------------------------------------------%
-c
- include 'debug.h'
- include 'stat.h'
-c
-c %------------------%
-c | Scalar Arguments |
-c %------------------%
-c
- integer kev, ldh, ldq, ldv, n, np
-c
-c %-----------------%
-c | Array Arguments |
-c %-----------------%
-c
- Double precision
- & h(ldh,2), q(ldq,kev+np), resid(n), shift(np),
- & v(ldv,kev+np), workd(2*n)
-c
-c %------------%
-c | Parameters |
-c %------------%
-c
- Double precision
- & one, zero
- parameter (one = 1.0D+0, zero = 0.0D+0)
-c
-c %---------------%
-c | Local Scalars |
-c %---------------%
-c
- integer i, iend, istart, itop, j, jj, kplusp, msglvl
- logical first
- Double precision
- & a1, a2, a3, a4, big, c, epsmch, f, g, r, s
- save epsmch, first
-c
-c
-c %----------------------%
-c | External Subroutines |
-c %----------------------%
-c
- external daxpy, dcopy, dscal, dlacpy, dlartg, dlaset,
- & igraphdvout, igraphivout, igraphsecond, dgemv
-c
-c %--------------------%
-c | External Functions |
-c %--------------------%
-c
- Double precision
- & dlamch
- external dlamch
-c
-c %----------------------%
-c | Intrinsics Functions |
-c %----------------------%
-c
- intrinsic abs
-c
-c %----------------%
-c | Data statments |
-c %----------------%
-c
- data first / .true. /
-c
-c %-----------------------%
-c | Executable Statements |
-c %-----------------------%
-c
- if (first) then
- epsmch = dlamch('Epsilon-Machine')
- first = .false.
- end if
- itop = 1
-c
-c %-------------------------------%
-c | Initialize timing statistics |
-c | & message level for debugging |
-c %-------------------------------%
-c
- call igraphsecond (t0)
- msglvl = msapps
-c
- kplusp = kev + np
-c
-c %----------------------------------------------%
-c | Initialize Q to the identity matrix of order |
-c | kplusp used to accumulate the rotations. |
-c %----------------------------------------------%
-c
- call dlaset ('All', kplusp, kplusp, zero, one, q, ldq)
-c
-c %----------------------------------------------%
-c | Quick return if there are no shifts to apply |
-c %----------------------------------------------%
-c
- if (np .eq. 0) go to 9000
-c
-c %----------------------------------------------------------%
-c | Apply the np shifts implicitly. Apply each shift to the |
-c | whole matrix and not just to the submatrix from which it |
-c | comes. |
-c %----------------------------------------------------------%
-c
- do 90 jj = 1, np
-c
- istart = itop
-c
-c %----------------------------------------------------------%
-c | Check for splitting and deflation. Currently we consider |
-c | an off-diagonal element h(i+1,1) negligible if |
-c | h(i+1,1) .le. epsmch*( |h(i,2)| + |h(i+1,2)| ) |
-c | for i=1:KEV+NP-1. |
-c | If above condition tests true then we set h(i+1,1) = 0. |
-c | Note that h(1:KEV+NP,1) are assumed to be non negative. |
-c %----------------------------------------------------------%
-c
- 20 continue
-c
-c %------------------------------------------------%
-c | The following loop exits early if we encounter |
-c | a negligible off diagonal element. |
-c %------------------------------------------------%
-c
- do 30 i = istart, kplusp-1
- big = abs(h(i,2)) + abs(h(i+1,2))
- if (h(i+1,1) .le. epsmch*big) then
- if (msglvl .gt. 0) then
- call igraphivout (logfil, 1, i, ndigit,
- & '_sapps: deflation at row/column no.')
- call igraphivout (logfil, 1, jj, ndigit,
- & '_sapps: occured before shift number.')
- call igraphdvout (logfil, 1, h(i+1,1), ndigit,
- & '_sapps: the corresponding off diagonal element')
- end if
- h(i+1,1) = zero
- iend = i
- go to 40
- end if
- 30 continue
- iend = kplusp
- 40 continue
-c
- if (istart .lt. iend) then
-c
-c %--------------------------------------------------------%
-c | Construct the plane rotation G'(istart,istart+1,theta) |
-c | that attempts to drive h(istart+1,1) to zero. |
-c %--------------------------------------------------------%
-c
- f = h(istart,2) - shift(jj)
- g = h(istart+1,1)
- call dlartg (f, g, c, s, r)
-c
-c %-------------------------------------------------------%
-c | Apply rotation to the left and right of H; |
-c | H <- G' * H * G, where G = G(istart,istart+1,theta). |
-c | This will create a "bulge". |
-c %-------------------------------------------------------%
-c
- a1 = c*h(istart,2) + s*h(istart+1,1)
- a2 = c*h(istart+1,1) + s*h(istart+1,2)
- a4 = c*h(istart+1,2) - s*h(istart+1,1)
- a3 = c*h(istart+1,1) - s*h(istart,2)
- h(istart,2) = c*a1 + s*a2
- h(istart+1,2) = c*a4 - s*a3
- h(istart+1,1) = c*a3 + s*a4
-c
-c %----------------------------------------------------%
-c | Accumulate the rotation in the matrix Q; Q <- Q*G |
-c %----------------------------------------------------%
-c
- do 60 j = 1, min(istart+jj,kplusp)
- a1 = c*q(j,istart) + s*q(j,istart+1)
- q(j,istart+1) = - s*q(j,istart) + c*q(j,istart+1)
- q(j,istart) = a1
- 60 continue
-c
-c
-c %----------------------------------------------%
-c | The following loop chases the bulge created. |
-c | Note that the previous rotation may also be |
-c | done within the following loop. But it is |
-c | kept separate to make the distinction among |
-c | the bulge chasing sweeps and the first plane |
-c | rotation designed to drive h(istart+1,1) to |
-c | zero. |
-c %----------------------------------------------%
-c
- do 70 i = istart+1, iend-1
-c
-c %----------------------------------------------%
-c | Construct the plane rotation G'(i,i+1,theta) |
-c | that zeros the i-th bulge that was created |
-c | by G(i-1,i,theta). g represents the bulge. |
-c %----------------------------------------------%
-c
- f = h(i,1)
- g = s*h(i+1,1)
-c
-c %----------------------------------%
-c | Final update with G(i-1,i,theta) |
-c %----------------------------------%
-c
- h(i+1,1) = c*h(i+1,1)
- call dlartg (f, g, c, s, r)
-c
-c %-------------------------------------------%
-c | The following ensures that h(1:iend-1,1), |
-c | the first iend-2 off diagonal of elements |
-c | H, remain non negative. |
-c %-------------------------------------------%
-c
- if (r .lt. zero) then
- r = -r
- c = -c
- s = -s
- end if
-c
-c %--------------------------------------------%
-c | Apply rotation to the left and right of H; |
-c | H <- G * H * G', where G = G(i,i+1,theta) |
-c %--------------------------------------------%
-c
- h(i,1) = r
-c
- a1 = c*h(i,2) + s*h(i+1,1)
- a2 = c*h(i+1,1) + s*h(i+1,2)
- a3 = c*h(i+1,1) - s*h(i,2)
- a4 = c*h(i+1,2) - s*h(i+1,1)
-c
- h(i,2) = c*a1 + s*a2
- h(i+1,2) = c*a4 - s*a3
- h(i+1,1) = c*a3 + s*a4
-c
-c %----------------------------------------------------%
-c | Accumulate the rotation in the matrix Q; Q <- Q*G |
-c %----------------------------------------------------%
-c
- do 50 j = 1, min( j+jj, kplusp )
- a1 = c*q(j,i) + s*q(j,i+1)
- q(j,i+1) = - s*q(j,i) + c*q(j,i+1)
- q(j,i) = a1
- 50 continue
-c
- 70 continue
-c
- end if
-c
-c %--------------------------%
-c | Update the block pointer |
-c %--------------------------%
-c
- istart = iend + 1
-c
-c %------------------------------------------%
-c | Make sure that h(iend,1) is non-negative |
-c | If not then set h(iend,1) <-- -h(iend,1) |
-c | and negate the last column of Q. |
-c | We have effectively carried out a |
-c | similarity on transformation H |
-c %------------------------------------------%
-c
- if (h(iend,1) .lt. zero) then
- h(iend,1) = -h(iend,1)
- call dscal(kplusp, -one, q(1,iend), 1)
- end if
-c
-c %--------------------------------------------------------%
-c | Apply the same shift to the next block if there is any |
-c %--------------------------------------------------------%
-c
- if (iend .lt. kplusp) go to 20
-c
-c %-----------------------------------------------------%
-c | Check if we can increase the the start of the block |
-c %-----------------------------------------------------%
-c
- do 80 i = itop, kplusp-1
- if (h(i+1,1) .gt. zero) go to 90
- itop = itop + 1
- 80 continue
-c
-c %-----------------------------------%
-c | Finished applying the jj-th shift |
-c %-----------------------------------%
-c
- 90 continue
-c
-c %------------------------------------------%
-c | All shifts have been applied. Check for |
-c | more possible deflation that might occur |
-c | after the last shift is applied. |
-c %------------------------------------------%
-c
- do 100 i = itop, kplusp-1
- big = abs(h(i,2)) + abs(h(i+1,2))
- if (h(i+1,1) .le. epsmch*big) then
- if (msglvl .gt. 0) then
- call igraphivout (logfil, 1, i, ndigit,
- & '_sapps: deflation at row/column no.')
- call igraphdvout (logfil, 1, h(i+1,1), ndigit,
- & '_sapps: the corresponding off diagonal element')
- end if
- h(i+1,1) = zero
- end if
- 100 continue
-c
-c %-------------------------------------------------%
-c | Compute the (kev+1)-st column of (V*Q) and |
-c | temporarily store the result in WORKD(N+1:2*N). |
-c | This is not necessary if h(kev+1,1) = 0. |
-c %-------------------------------------------------%
-c
- if ( h(kev+1,1) .gt. zero )
- & call dgemv ('N', n, kplusp, one, v, ldv,
- & q(1,kev+1), 1, zero, workd(n+1), 1)
-c
-c %-------------------------------------------------------%
-c | Compute column 1 to kev of (V*Q) in backward order |
-c | taking advantage that Q is an upper triangular matrix |
-c | with lower bandwidth np. |
-c | Place results in v(:,kplusp-kev:kplusp) temporarily. |
-c %-------------------------------------------------------%
-c
- do 130 i = 1, kev
- call dgemv ('N', n, kplusp-i+1, one, v, ldv,
- & q(1,kev-i+1), 1, zero, workd, 1)
- call dcopy (n, workd, 1, v(1,kplusp-i+1), 1)
- 130 continue
-c
-c %-------------------------------------------------%
-c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). |
-c %-------------------------------------------------%
-c
- call dlacpy ('All', n, kev, v(1,np+1), ldv, v, ldv)
-c
-c %--------------------------------------------%
-c | Copy the (kev+1)-st column of (V*Q) in the |
-c | appropriate place if h(kev+1,1) .ne. zero. |
-c %--------------------------------------------%
-c
- if ( h(kev+1,1) .gt. zero )
- & call dcopy (n, workd(n+1), 1, v(1,kev+1), 1)
-c
-c %-------------------------------------%
-c | Update the residual vector: |
-c | r <- sigmak*r + betak*v(:,kev+1) |
-c | where |
-c | sigmak = (e_{kev+p}'*Q)*e_{kev} |
-c | betak = e_{kev+1}'*H*e_{kev} |
-c %-------------------------------------%
-c
- call dscal (n, q(kplusp,kev), resid, 1)
- if (h(kev+1,1) .gt. zero)
- & call daxpy (n, h(kev+1,1), v(1,kev+1), 1, resid, 1)
-c
- if (msglvl .gt. 1) then
- call igraphdvout (logfil, 1, q(kplusp,kev), ndigit,
- & '_sapps: sigmak of the updated residual vector')
- call igraphdvout (logfil, 1, h(kev+1,1), ndigit,
- & '_sapps: betak of the updated residual vector')
- call igraphdvout (logfil, kev, h(1,2), ndigit,
- & '_sapps: updated main diagonal of H for next iteration')
- if (kev .gt. 1) then
- call igraphdvout (logfil, kev-1, h(2,1), ndigit,
- & '_sapps: updated sub diagonal of H for next iteration')
- end if
- end if
-c
- call igraphsecond (t1)
- tsapps = tsapps + (t1 - t0)
-c
- 9000 continue
- return
-c
-c %---------------%
-c | End of igraphdsapps |
-c %---------------%
-c
- end
diff --git a/src/dsaup2.f b/src/dsaup2.f
deleted file mode 100644
index 116dd31..0000000
--- a/src/dsaup2.f
+++ /dev/null
@@ -1,853 +0,0 @@
-c-----------------------------------------------------------------------
-c\BeginDoc
-c
-c\Name: igraphdsaup2
-c
-c\Description:
-c Intermediate level interface called by igraphdsaupd.
-c
-c\Usage:
-c call igraphdsaup2
-c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD,
-c ISHIFT, MXITER, V, LDV, H, LDH, RITZ, BOUNDS, Q, LDQ, WORKL,
-c IPNTR, WORKD, INFO )
-c
-c\Arguments
-c
-c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in igraphdsaupd.
-c MODE, ISHIFT, MXITER: see the definition of IPARAM in igraphdsaupd.
-c
-c NP Integer. (INPUT/OUTPUT)
-c Contains the number of implicit shifts to apply during
-c each Arnoldi/Lanczos iteration.
-c If ISHIFT=1, NP is adjusted dynamically at each iteration
-c to accelerate convergence and prevent stagnation.
-c This is also roughly equal to the number of matrix-vector
-c products (involving the operator OP) per Arnoldi iteration.
-c The logic for adjusting is contained within the current
-c subroutine.
-c If ISHIFT=0, NP is the number of shifts the user needs
-c to provide via reverse comunication. 0 < NP < NCV-NEV.
-c NP may be less than NCV-NEV since a leading block of the current
-c upper Tridiagonal matrix has split off and contains "unwanted"
-c Ritz values.
-c Upon termination of the IRA iteration, NP contains the number
-c of "converged" wanted Ritz values.
-c
-c IUPD Integer. (INPUT)
-c IUPD .EQ. 0: use explicit restart instead implicit update.
-c IUPD .NE. 0: use implicit update.
-c
-c V Double precision N by (NEV+NP) array. (INPUT/OUTPUT)
-c The Lanczos basis vectors.
-c
-c LDV Integer. (INPUT)
-c Leading dimension of V exactly as declared in the calling
-c program.
-c
-c H Double precision (NEV+NP) by 2 array. (OUTPUT)
-c H is used to store the generated symmetric tridiagonal matrix
-c The subdiagonal is stored in the first column of H starting
-c at H(2,1). The main diagonal is stored in the igraphsecond column
-c of H starting at H(1,2). If igraphdsaup2 converges store the
-c B-norm of the final residual vector in H(1,1).
-c
-c LDH Integer. (INPUT)
-c Leading dimension of H exactly as declared in the calling
-c program.
-c
-c RITZ Double precision array of length NEV+NP. (OUTPUT)
-c RITZ(1:NEV) contains the computed Ritz values of OP.
-c
-c BOUNDS Double precision array of length NEV+NP. (OUTPUT)
-c BOUNDS(1:NEV) contain the error bounds corresponding to RITZ.
-c
-c Q Double precision (NEV+NP) by (NEV+NP) array. (WORKSPACE)
-c Private (replicated) work array used to accumulate the
-c rotation in the shift application step.
-c
-c LDQ Integer. (INPUT)
-c Leading dimension of Q exactly as declared in the calling
-c program.
-c
-c WORKL Double precision array of length at least 3*(NEV+NP). (INPUT/WORKSPACE)
-c Private (replicated) array on each PE or array allocated on
-c the front end. It is used in the computation of the
-c tridiagonal eigenvalue problem, the calculation and
-c application of the shifts and convergence checking.
-c If ISHIFT .EQ. O and IDO .EQ. 3, the first NP locations
-c of WORKL are used in reverse communication to hold the user
-c supplied shifts.
-c
-c IPNTR Integer array of length 3. (OUTPUT)
-c Pointer to mark the starting locations in the WORKD for
-c vectors used by the Lanczos iteration.
-c -------------------------------------------------------------
-c IPNTR(1): pointer to the current operand vector X.
-c IPNTR(2): pointer to the current result vector Y.
-c IPNTR(3): pointer to the vector B * X when used in one of
-c the spectral transformation modes. X is the current
-c operand.
-c -------------------------------------------------------------
-c
-c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION)
-c Distributed array to be used in the basic Lanczos iteration
-c for reverse communication. The user should not use WORKD
-c as temporary workspace during the iteration !!!!!!!!!!
-c See Data Distribution Note in igraphdsaupd.
-c
-c INFO Integer. (INPUT/OUTPUT)
-c If INFO .EQ. 0, a randomly initial residual vector is used.
-c If INFO .NE. 0, RESID contains the initial residual vector,
-c possibly from a previous run.
-c Error flag on output.
-c = 0: Normal return.
-c = 1: All possible eigenvalues of OP has been found.
-c NP returns the size of the invariant subspace
-c spanning the operator OP.
-c = 2: No shifts could be applied.
-c = -8: Error return from trid. eigenvalue calculation;
-c This should never happen.
-c = -9: Starting vector is zero.
-c = -9999: Could not build an Lanczos factorization.
-c Size that was built in returned in NP.
-c
-c\EndDoc
-c
-c-----------------------------------------------------------------------
-c
-c\BeginLib
-c
-c\References:
-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
-c pp 357-385.
-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
-c Restarted Arnoldi Iteration", Rice University Technical Report
-c TR95-13, Department of Computational and Applied Mathematics.
-c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall,
-c 1980.
-c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program",
-c Computer Physics Communications, 53 (1989), pp 169-179.
-c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to
-c Implement the Spectral Transformation", Math. Comp., 48 (1987),
-c pp 663-673.
-c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos
-c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems",
-c SIAM J. Matr. Anal. Apps., January (1993).
-c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines
-c for Updating the QR decomposition", ACM TOMS, December 1990,
-c Volume 16 Number 4, pp 369-377.
-c
-c\Routines called:
-c igraphdgetv0 ARPACK initial vector generation routine.
-c igraphdsaitr ARPACK Lanczos factorization routine.
-c igraphdsapps ARPACK application of implicit shifts routine.
-c igraphdsconv ARPACK convergence of Ritz values routine.
-c igraphdseigt ARPACK compute Ritz values and error bounds routine.
-c igraphdsgets ARPACK reorder Ritz values and error bounds routine.
-c igraphdsortr ARPACK sorting routine.
-c igraphivout ARPACK utility routine that prints integers.
-c igraphsecond ARPACK utility routine for timing.
-c igraphdvout ARPACK utility routine that prints vectors.
-c dlamch LAPACK routine that determines machine constants.
-c dcopy Level 1 BLAS that copies one vector to another.
-c ddot Level 1 BLAS that computes the scalar product of two vectors.
-c dnrm2 Level 1 BLAS that computes the norm of a vector.
-c dscal Level 1 BLAS that scales a vector.
-c dswap Level 1 BLAS that swaps two vectors.
-c
-c\Author
-c Danny Sorensen Phuong Vu
-c Richard Lehoucq CRPC / Rice University
-c Dept. of Computational & Houston, Texas
-c Applied Mathematics
-c Rice University
-c Houston, Texas
-c
-c\Revision history:
-c 12/15/93: Version ' 2.4'
-c xx/xx/95: Version ' 2.4'. (R.B. Lehoucq)
-c
-c\SCCS Information: @(#)
-c FILE: saup2.F SID: 2.6 DATE OF SID: 8/16/96 RELEASE: 2
-c
-c\EndLib
-c
-c-----------------------------------------------------------------------
-c
- subroutine igraphdsaup2
- & ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd,
- & ishift, mxiter, v, ldv, h, ldh, ritz, bounds,
- & q, ldq, workl, ipntr, workd, info )
-c
-c %----------------------------------------------------%
-c | Include files for debugging and timing information |
-c %----------------------------------------------------%
-c
- include 'debug.h'
- include 'stat.h'
-c
-c %------------------%
-c | Scalar Arguments |
-c %------------------%
-c
- character bmat*1, which*2
- integer ido, info, ishift, iupd, ldh, ldq, ldv, mxiter,
- & n, mode, nev, np
- Double precision
- & tol
-c
-c %-----------------%
-c | Array Arguments |
-c %-----------------%
-c
- integer ipntr(3)
- Double precision
- & bounds(nev+np), h(ldh,2), q(ldq,nev+np), resid(n),
- & ritz(nev+np), v(ldv,nev+np), workd(3*n),
- & workl(3*(nev+np))
-c
-c %------------%
-c | Parameters |
-c %------------%
-c
- Double precision
- & one, zero
- parameter (one = 1.0D+0, zero = 0.0D+0)
-c
-c %---------------%
-c | Local Scalars |
-c %---------------%
-c
- character wprime*2
- logical cnorm, getv0, initv, update, ushift
- integer ierr, iter, j, kplusp, msglvl, nconv, nevbef, nev0,
- & np0, nptemp, nevd2, nevm2, kp(3)
- Double precision
- & rnorm, temp, eps23
- save cnorm, getv0, initv, update, ushift,
- & iter, kplusp, msglvl, nconv, nev0, np0,
- & rnorm, eps23
-c
-c %----------------------%
-c | External Subroutines |
-c %----------------------%
-c
- external dcopy, igraphdgetv0, igraphdsaitr, dscal,
- & igraphdsconv, igraphdseigt, igraphdsgets,
- & igraphdsapps, igraphdsortr, igraphdvout, igraphivout,
- & igraphsecond, dswap
-c
-c %--------------------%
-c | External Functions |
-c %--------------------%
-c
- Double precision
- & ddot, dnrm2, dlamch
- external ddot, dnrm2, dlamch
-c
-c %---------------------%
-c | Intrinsic Functions |
-c %---------------------%
-c
- intrinsic min
-c
-c %-----------------------%
-c | Executable Statements |
-c %-----------------------%
-c
- if (ido .eq. 0) then
-c
-c %-------------------------------%
-c | Initialize timing statistics |
-c | & message level for debugging |
-c %-------------------------------%
-c
- call igraphsecond (t0)
- msglvl = msaup2
-c
-c %---------------------------------%
-c | Set machine dependent constant. |
-c %---------------------------------%
-c
- eps23 = dlamch('Epsilon-Machine')
- eps23 = eps23**(2.0D+0/3.0D+0)
-c
-c %-------------------------------------%
-c | nev0 and np0 are integer variables |
-c | hold the initial values of NEV & NP |
-c %-------------------------------------%
-c
- nev0 = nev
- np0 = np
-c
-c %-------------------------------------%
-c | kplusp is the bound on the largest |
-c | Lanczos factorization built. |
-c | nconv is the current number of |
-c | "converged" eigenvlues. |
-c | iter is the counter on the current |
-c | iteration step. |
-c %-------------------------------------%
-c
- kplusp = nev0 + np0
- nconv = 0
- iter = 0
-c
-c %--------------------------------------------%
-c | Set flags for computing the first NEV steps |
-c | of the Lanczos factorization. |
-c %--------------------------------------------%
-c
- getv0 = .true.
- update = .false.
- ushift = .false.
- cnorm = .false.
-c
- if (info .ne. 0) then
-c
-c %--------------------------------------------%
-c | User provides the initial residual vector. |
-c %--------------------------------------------%
-c
- initv = .true.
- info = 0
- else
- initv = .false.
- end if
- end if
-c
-c %---------------------------------------------%
-c | Get a possibly random starting vector and |
-c | force it into the range of the operator OP. |
-c %---------------------------------------------%
-c
- 10 continue
-c
- if (getv0) then
- call igraphdgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid,
- & rnorm, ipntr, workd, info)
-c
- if (ido .ne. 99) go to 9000
-c
- if (rnorm .eq. zero) then
-c
-c %-----------------------------------------%
-c | The initial vector is zero. Error exit. |
-c %-----------------------------------------%
-c
- info = -9
- go to 1200
- end if
- getv0 = .false.
- ido = 0
- end if
-c
-c %------------------------------------------------------------%
-c | Back from reverse communication: continue with update step |
-c %------------------------------------------------------------%
-c
- if (update) go to 20
-c
-c %-------------------------------------------%
-c | Back from computing user specified shifts |
-c %-------------------------------------------%
-c
- if (ushift) go to 50
-c
-c %-------------------------------------%
-c | Back from computing residual norm |
-c | at the end of the current iteration |
-c %-------------------------------------%
-c
- if (cnorm) go to 100
-c
-c %----------------------------------------------------------%
-c | Compute the first NEV steps of the Lanczos factorization |
-c %----------------------------------------------------------%
-c
- call igraphdsaitr (ido, bmat, n, 0, nev0, mode, resid, rnorm, v,
- & ldv, h, ldh, ipntr, workd, info)
-c
-c %---------------------------------------------------%
-c | ido .ne. 99 implies use of reverse communication |
-c | to compute operations involving OP and possibly B |
-c %---------------------------------------------------%
-c
- if (ido .ne. 99) go to 9000
-c
- if (info .gt. 0) then
-c
-c %-----------------------------------------------------%
-c | igraphdsaitr was unable to build an Lanczos factorization |
-c | of length NEV0. INFO is returned with the size of |
-c | the factorization built. Exit main loop. |
-c %-----------------------------------------------------%
-c
- np = info
- mxiter = iter
- info = -9999
- go to 1200
- end if
-c
-c %--------------------------------------------------------------%
-c | |
-c | M A I N LANCZOS I T E R A T I O N L O O P |
-c | Each iteration implicitly restarts the Lanczos |
-c | factorization in place. |
-c | |
-c %--------------------------------------------------------------%
-c
- 1000 continue
-c
- iter = iter + 1
-c
- if (msglvl .gt. 0) then
- call igraphivout (logfil, 1, [iter], ndigit,
- & '_saup2: **** Start of major iteration number ****')
- end if
- if (msglvl .gt. 1) then
- call igraphivout (logfil, 1, [nev], ndigit,
- & '_saup2: The length of the current Lanczos factorization')
- call igraphivout (logfil, 1, [np], ndigit,
- & '_saup2: Extend the Lanczos factorization by')
- end if
-c
-c %------------------------------------------------------------%
-c | Compute NP additional steps of the Lanczos factorization. |
-c %------------------------------------------------------------%
-c
- ido = 0
- 20 continue
- update = .true.
-c
- call igraphdsaitr (ido, bmat, n, nev, np, mode, resid, rnorm,
- & v, ldv, h, ldh, ipntr, workd, info)
-c
-c %---------------------------------------------------%
-c | ido .ne. 99 implies use of reverse communication |
-c | to compute operations involving OP and possibly B |
-c %---------------------------------------------------%
-c
- if (ido .ne. 99) go to 9000
-c
- if (info .gt. 0) then
-c
-c %-----------------------------------------------------%
-c | igraphdsaitr was unable to build an Lanczos factorization |
-c | of length NEV0+NP0. INFO is returned with the size |
-c | of the factorization built. Exit main loop. |
-c %-----------------------------------------------------%
-c
- np = info
- mxiter = iter
- info = -9999
- go to 1200
- end if
- update = .false.
-c
- if (msglvl .gt. 1) then
- call igraphdvout (logfil, 1, [rnorm], ndigit,
- & '_saup2: Current B-norm of residual for factorization')
- end if
-c
-c %--------------------------------------------------------%
-c | Compute the eigenvalues and corresponding error bounds |
-c | of the current symmetric tridiagonal matrix. |
-c %--------------------------------------------------------%
-c
- call igraphdseigt (rnorm, kplusp, h, ldh, ritz, bounds, workl,
- & ierr)
-c
- if (ierr .ne. 0) then
- info = -8
- go to 1200
- end if
-c
-c %----------------------------------------------------%
-c | Make a copy of eigenvalues and corresponding error |
-c | bounds obtained from _seigt. |
-c %----------------------------------------------------%
-c
- call dcopy(kplusp, ritz, 1, workl(kplusp+1), 1)
- call dcopy(kplusp, bounds, 1, workl(2*kplusp+1), 1)
-c
-c %---------------------------------------------------%
-c | Select the wanted Ritz values and their bounds |
-c | to be used in the convergence test. |
-c | The selection is based on the requested number of |
-c | eigenvalues instead of the current NEV and NP to |
-c | prevent possible misconvergence. |
-c | * Wanted Ritz values := RITZ(NP+1:NEV+NP) |
-c | * Shifts := RITZ(1:NP) := WORKL(1:NP) |
-c %---------------------------------------------------%
-c
- nev = nev0
- np = np0
- call igraphdsgets (ishift, which, nev, np, ritz, bounds, workl)
-c
-c %-------------------%
-c | Convergence test. |
-c %-------------------%
-c
- call dcopy (nev, bounds(np+1), 1, workl(np+1), 1)
- call igraphdsconv (nev, ritz(np+1), workl(np+1), tol, nconv)
-c
- if (msglvl .gt. 2) then
- kp(1) = nev
- kp(2) = np
- kp(3) = nconv
- call igraphivout (logfil, 3, kp, ndigit,
- & '_saup2: NEV, NP, NCONV are')
- call igraphdvout (logfil, kplusp, ritz, ndigit,
- & '_saup2: The eigenvalues of H')
- call igraphdvout (logfil, kplusp, bounds, ndigit,
- & '_saup2: Ritz estimates of the current NCV Ritz values')
- end if
-c
-c %---------------------------------------------------------%
-c | Count the number of unwanted Ritz values that have zero |
-c | Ritz estimates. If any Ritz estimates are equal to zero |
-c | then a leading block of H of order equal to at least |
-c | the number of Ritz values with zero Ritz estimates has |
-c | split off. None of these Ritz values may be removed by |
-c | shifting. Decrease NP the number of shifts to apply. If |
-c | no shifts may be applied, then prepare to exit |
-c %---------------------------------------------------------%
-c
- nptemp = np
- do 30 j=1, nptemp
- if (bounds(j) .eq. zero) then
- np = np - 1
- nev = nev + 1
- end if
- 30 continue
-c
- if ( (nconv .ge. nev0) .or.
- & (iter .gt. mxiter) .or.
- & (np .eq. 0) ) then
-c
-c %------------------------------------------------%
-c | Prepare to exit. Put the converged Ritz values |
-c | and corresponding bounds in RITZ(1:NCONV) and |
-c | BOUNDS(1:NCONV) respectively. Then sort. Be |
-c | careful when NCONV > NP since we don't want to |
-c | swap overlapping locations. |
-c %------------------------------------------------%
-c
- if (which .eq. 'BE') then
-c
-c %-----------------------------------------------------%
-c | Both ends of the spectrum are requested. |
-c | Sort the eigenvalues into algebraically decreasing |
-c | order first then swap low end of the spectrum next |
-c | to high end in appropriate locations. |
-c | NOTE: when np < floor(nev/2) be careful not to swap |
-c | overlapping locations. |
-c %-----------------------------------------------------%
-c
- wprime = 'SA'
- call igraphdsortr (wprime, .true., kplusp, ritz, bounds)
- nevd2 = nev / 2
- nevm2 = nev - nevd2
- if ( nev .gt. 1 ) then
- call dswap ( min(nevd2,np), ritz(nevm2+1), 1,
- & ritz( max(kplusp-nevd2+1,kplusp-np+1) ), 1)
- call dswap ( min(nevd2,np), bounds(nevm2+1), 1,
- & bounds( max(kplusp-nevd2+1,kplusp-np)+1 ), 1)
- end if
-c
- else
-c
-c %--------------------------------------------------%
-c | LM, SM, LA, SA case. |
-c | Sort the eigenvalues of H into the an order that |
-c | is opposite to WHICH, and apply the resulting |
-c | order to BOUNDS. The eigenvalues are sorted so |
-c | that the wanted part are always within the first |
-c | NEV locations. |
-c %--------------------------------------------------%
-c
- if (which .eq. 'LM') wprime = 'SM'
- if (which .eq. 'SM') wprime = 'LM'
- if (which .eq. 'LA') wprime = 'SA'
- if (which .eq. 'SA') wprime = 'LA'
-c
- call igraphdsortr (wprime, .true., kplusp, ritz, bounds)
-c
- end if
-c
-c %--------------------------------------------------%
-c | Scale the Ritz estimate of each Ritz value |
-c | by 1 / max(eps23,magnitude of the Ritz value). |
-c %--------------------------------------------------%
-c
- do 35 j = 1, nev0
- temp = max( eps23, abs(ritz(j)) )
- bounds(j) = bounds(j)/temp
- 35 continue
-c
-c %----------------------------------------------------%
-c | Sort the Ritz values according to the scaled Ritz |
-c | esitmates. This will push all the converged ones |
-c | towards the front of ritzr, ritzi, bounds |
-c | (in the case when NCONV < NEV.) |
-c %----------------------------------------------------%
-c
- wprime = 'LA'
- call igraphdsortr(wprime, .true., nev0, bounds, ritz)
-c
-c %----------------------------------------------%
-c | Scale the Ritz estimate back to its original |
-c | value. |
-c %----------------------------------------------%
-c
- do 40 j = 1, nev0
- temp = max( eps23, abs(ritz(j)) )
- bounds(j) = bounds(j)*temp
- 40 continue
-c
-c %--------------------------------------------------%
-c | Sort the "converged" Ritz values again so that |
-c | the "threshold" values and their associated Ritz |
-c | estimates appear at the appropriate position in |
-c | ritz and bound. |
-c %--------------------------------------------------%
-c
- if (which .eq. 'BE') then
-c
-c %------------------------------------------------%
-c | Sort the "converged" Ritz values in increasing |
-c | order. The "threshold" values are in the |
-c | middle. |
-c %------------------------------------------------%
-c
- wprime = 'LA'
- call igraphdsortr(wprime, .true., nconv, ritz, bounds)
-c
- else
-c
-c %----------------------------------------------%
-c | In LM, SM, LA, SA case, sort the "converged" |
-c | Ritz values according to WHICH so that the |
-c | "threshold" value appears at the front of |
-c | ritz. |
-c %----------------------------------------------%
-
- call igraphdsortr(which, .true., nconv, ritz, bounds)
-c
- end if
-c
-c %------------------------------------------%
-c | Use h( 1,1 ) as storage to communicate |
-c | rnorm to _seupd if needed |
-c %------------------------------------------%
-c
- h(1,1) = rnorm
-c
- if (msglvl .gt. 1) then
- call igraphdvout (logfil, kplusp, ritz, ndigit,
- & '_saup2: Sorted Ritz values.')
- call igraphdvout (logfil, kplusp, bounds, ndigit,
- & '_saup2: Sorted ritz estimates.')
- end if
-c
-c %------------------------------------%
-c | Max iterations have been exceeded. |
-c %------------------------------------%
-c
- if (iter .gt. mxiter .and. nconv .lt. nev) info = 1
-c
-c %---------------------%
-c | No shifts to apply. |
-c %---------------------%
-c
- if (np .eq. 0 .and. nconv .lt. nev0) info = 2
-c
- np = nconv
- go to 1100
-c
- else if (nconv .lt. nev .and. ishift .eq. 1) then
-c
-c %---------------------------------------------------%
-c | Do not have all the requested eigenvalues yet. |
-c | To prevent possible stagnation, adjust the number |
-c | of Ritz values and the shifts. |
-c %---------------------------------------------------%
-c
- nevbef = nev
- nev = nev + min (nconv, np/2)
- if (nev .eq. 1 .and. kplusp .ge. 6) then
- nev = kplusp / 2
- else if (nev .eq. 1 .and. kplusp .gt. 2) then
- nev = 2
- end if
- np = kplusp - nev
-c
-c %---------------------------------------%
-c | If the size of NEV was just increased |
-c | resort the eigenvalues. |
-c %---------------------------------------%
-c
- if (nevbef .lt. nev)
- & call igraphdsgets (ishift, which, nev, np, ritz, bounds,
- & workl)
-c
- end if
-c
- if (msglvl .gt. 0) then
- call igraphivout (logfil, 1, [nconv], ndigit,
- & '_saup2: no. of "converged" Ritz values at this iter.')
- if (msglvl .gt. 1) then
- kp(1) = nev
- kp(2) = np
- call igraphivout (logfil, 2, kp, ndigit,
- & '_saup2: NEV and NP are')
- call igraphdvout (logfil, nev, ritz(np+1), ndigit,
- & '_saup2: "wanted" Ritz values.')
- call igraphdvout (logfil, nev, bounds(np+1), ndigit,
- & '_saup2: Ritz estimates of the "wanted" values ')
- end if
- end if
-
-c
- if (ishift .eq. 0) then
-c
-c %-----------------------------------------------------%
-c | User specified shifts: reverse communication to |
-c | compute the shifts. They are returned in the first |
-c | NP locations of WORKL. |
-c %-----------------------------------------------------%
-c
- ushift = .true.
- ido = 3
- go to 9000
- end if
-c
- 50 continue
-c
-c %------------------------------------%
-c | Back from reverse communication; |
-c | User specified shifts are returned |
-c | in WORKL(1:*NP) |
-c %------------------------------------%
-c
- ushift = .false.
-c
-c
-c %---------------------------------------------------------%
-c | Move the NP shifts to the first NP locations of RITZ to |
-c | free up WORKL. This is for the non-exact shift case; |
-c | in the exact shift case, igraphdsgets already handles this. |
-c %---------------------------------------------------------%
-c
- if (ishift .eq. 0) call dcopy (np, workl, 1, ritz, 1)
-c
- if (msglvl .gt. 2) then
- call igraphivout (logfil, 1, [np], ndigit,
- & '_saup2: The number of shifts to apply ')
- call igraphdvout (logfil, np, workl, ndigit,
- & '_saup2: shifts selected')
- if (ishift .eq. 1) then
- call igraphdvout (logfil, np, bounds, ndigit,
- & '_saup2: corresponding Ritz estimates')
- end if
- end if
-c
-c %---------------------------------------------------------%
-c | Apply the NP0 implicit shifts by QR bulge chasing. |
-c | Each shift is applied to the entire tridiagonal matrix. |
-c | The first 2*N locations of WORKD are used as workspace. |
-c | After igraphdsapps is done, we have a Lanczos |
-c | factorization of length NEV. |
-c %---------------------------------------------------------%
-c
- call igraphdsapps (n, nev, np, ritz, v, ldv, h, ldh, resid,
- & q, ldq, workd)
-c
-c %---------------------------------------------%
-c | Compute the B-norm of the updated residual. |
-c | Keep B*RESID in WORKD(1:N) to be used in |
-c | the first step of the next call to igraphdsaitr. |
-c %---------------------------------------------%
-c
- cnorm = .true.
- call igraphsecond (t2)
- if (bmat .eq. 'G') then
- nbx = nbx + 1
- call dcopy (n, resid, 1, workd(n+1), 1)
- ipntr(1) = n + 1
- ipntr(2) = 1
- ido = 2
-c
-c %----------------------------------%
-c | Exit in order to compute B*RESID |
-c %----------------------------------%
-c
- go to 9000
- else if (bmat .eq. 'I') then
- call dcopy (n, resid, 1, workd, 1)
- end if
-c
- 100 continue
-c
-c %----------------------------------%
-c | Back from reverse communication; |
-c | WORKD(1:N) := B*RESID |
-c %----------------------------------%
-c
- if (bmat .eq. 'G') then
- call igraphsecond (t3)
- tmvbx = tmvbx + (t3 - t2)
- end if
-c
- if (bmat .eq. 'G') then
- rnorm = ddot (n, resid, 1, workd, 1)
- rnorm = sqrt(abs(rnorm))
- else if (bmat .eq. 'I') then
- rnorm = dnrm2(n, resid, 1)
- end if
- cnorm = .false.
- 130 continue
-c
- if (msglvl .gt. 2) then
- call igraphdvout (logfil, 1, [rnorm], ndigit,
- & '_saup2: B-norm of residual for NEV factorization')
- call igraphdvout (logfil, nev, h(1,2), ndigit,
- & '_saup2: main diagonal of compressed H matrix')
- call igraphdvout (logfil, nev-1, h(2,1), ndigit,
- & '_saup2: subdiagonal of compressed H matrix')
- end if
-c
- go to 1000
-c
-c %---------------------------------------------------------------%
-c | |
-c | E N D O F M A I N I T E R A T I O N L O O P |
-c | |
-c %---------------------------------------------------------------%
-c
- 1100 continue
-c
- mxiter = iter
- nev = nconv
-c
- 1200 continue
- ido = 99
-c
-c %------------%
-c | Error exit |
-c %------------%
-c
- call igraphsecond (t1)
- tsaup2 = t1 - t0
-c
- 9000 continue
- return
-c
-c %---------------%
-c | End of igraphdsaup2 |
-c %---------------%
-c
- end
diff --git a/src/dsaupd.f b/src/dsaupd.f
deleted file mode 100644
index 7e85781..0000000
--- a/src/dsaupd.f
+++ /dev/null
@@ -1,653 +0,0 @@
-c-----------------------------------------------------------------------
-c\BeginDoc
-c
-c\Name: igraphdsaupd
-c
-c\Description:
-c
-c Reverse communication interface for the Implicitly Restarted Arnoldi
-c Iteration. For symmetric problems this reduces to a variant of the Lanczos
-c method. This method has been designed to compute approximations to a
-c few eigenpairs of a linear operator OP that is real and symmetric
-c with respect to a real positive semi-definite symmetric matrix B,
-c i.e.
-c
-c B*OP = (OP')*B.
-c
-c Another way to express this condition is
-c
-c < x,OPy > = < OPx,y > where < z,w > = z'Bw .
-c
-c In the standard eigenproblem B is the identity matrix.
-c ( A' denotes transpose of A)
-c
-c The computed approximate eigenvalues are called Ritz values and
-c the corresponding approximate eigenvectors are called Ritz vectors.
-c
-c igraphdsaupd is usually called iteratively to solve one of the
-c following problems:
-c
-c Mode 1: A*x = lambda*x, A symmetric
-c ===> OP = A and B = I.
-c
-c Mode 2: A*x = lambda*M*x, A symmetric, M symmetric positive definite
-c ===> OP = inv[M]*A and B = M.
-c ===> (If M can be factored see remark 3 below)
-c
-c Mode 3: K*x = lambda*M*x, K symmetric, M symmetric positive semi-definite
-c ===> OP = (inv[K - sigma*M])*M and B = M.
-c ===> Shift-and-Invert mode
-c
-c Mode 4: K*x = lambda*KG*x, K symmetric positive semi-definite,
-c KG symmetric indefinite
-c ===> OP = (inv[K - sigma*KG])*K and B = K.
-c ===> Buckling mode
-c
-c Mode 5: A*x = lambda*M*x, A symmetric, M symmetric positive semi-definite
-c ===> OP = inv[A - sigma*M]*[A + sigma*M] and B = M.
-c ===> Cayley transformed mode
-c
-c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v
-c should be accomplished either by a direct method
-c using a sparse matrix factorization and solving
-c
-c [A - sigma*M]*w = v or M*w = v,
-c
-c or through an iterative method for solving these
-c systems. If an iterative method is used, the
-c convergence test must be more stringent than
-c the accuracy requirements for the eigenvalue
-c approximations.
-c
-c\Usage:
-c call igraphdsaupd
-c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM,
-c IPNTR, WORKD, WORKL, LWORKL, INFO )
-c
-c\Arguments
-c IDO Integer. (INPUT/OUTPUT)
-c Reverse communication flag. IDO must be zero on the first
-c call to igraphdsaupd. IDO will be set internally to
-c indicate the type of operation to be performed. Control is
-c then given back to the calling routine which has the
-c responsibility to carry out the requested operation and call
-c igraphdsaupd with the result. The operand is given in
-c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)).
-c (If Mode = 2 see remark 5 below)
-c -------------------------------------------------------------
-c IDO = 0: first call to the reverse communication interface
-c IDO = -1: compute Y = OP * X where
-c IPNTR(1) is the pointer into WORKD for X,
-c IPNTR(2) is the pointer into WORKD for Y.
-c This is for the initialization phase to force the
-c starting vector into the range of OP.
-c IDO = 1: compute Y = OP * X where
-c IPNTR(1) is the pointer into WORKD for X,
-c IPNTR(2) is the pointer into WORKD for Y.
-c In mode 3,4 and 5, the vector B * X is already
-c available in WORKD(ipntr(3)). It does not
-c need to be recomputed in forming OP * X.
-c IDO = 2: compute Y = B * X where
-c IPNTR(1) is the pointer into WORKD for X,
-c IPNTR(2) is the pointer into WORKD for Y.
-c IDO = 3: compute the IPARAM(8) shifts where
-c IPNTR(11) is the pointer into WORKL for
-c placing the shifts. See remark 6 below.
-c IDO = 99: done
-c -------------------------------------------------------------
-c
-c BMAT Character*1. (INPUT)
-c BMAT specifies the type of the matrix B that defines the
-c semi-inner product for the operator OP.
-c B = 'I' -> standard eigenvalue problem A*x = lambda*x
-c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x
-c
-c N Integer. (INPUT)
-c Dimension of the eigenproblem.
-c
-c WHICH Character*2. (INPUT)
-c Specify which of the Ritz values of OP to compute.
-c
-c 'LA' - compute the NEV largest (algebraic) eigenvalues.
-c 'SA' - compute the NEV smallest (algebraic) eigenvalues.
-c 'LM' - compute the NEV largest (in magnitude) eigenvalues.
-c 'SM' - compute the NEV smallest (in magnitude) eigenvalues.
-c 'BE' - compute NEV eigenvalues, half from each end of the
-c spectrum. When NEV is odd, compute one more from the
-c high end than from the low end.
-c (see remark 1 below)
-c
-c NEV Integer. (INPUT)
-c Number of eigenvalues of OP to be computed. 0 < NEV < N.
-c
-c TOL Double precision scalar. (INPUT)
-c Stopping criterion: the relative accuracy of the Ritz value
-c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)).
-c If TOL .LE. 0. is passed a default is set:
-c DEFAULT = DLAMCH('EPS') (machine precision as computed
-c by the LAPACK auxiliary subroutine DLAMCH).
-c
-c RESID Double precision array of length N. (INPUT/OUTPUT)
-c On INPUT:
-c If INFO .EQ. 0, a random initial residual vector is used.
-c If INFO .NE. 0, RESID contains the initial residual vector,
-c possibly from a previous run.
-c On OUTPUT:
-c RESID contains the final residual vector.
-c
-c NCV Integer. (INPUT)
-c Number of columns of the matrix V (less than or equal to N).
-c This will indicate how many Lanczos vectors are generated
-c at each iteration. After the startup phase in which NEV
-c Lanczos vectors are generated, the algorithm generates
-c NCV-NEV Lanczos vectors at each subsequent update iteration.
-c Most of the cost in generating each Lanczos vector is in the
-c matrix-vector product OP*x. (See remark 4 below).
-c
-c V Double precision N by NCV array. (OUTPUT)
-c The NCV columns of V contain the Lanczos basis vectors.
-c
-c LDV Integer. (INPUT)
-c Leading dimension of V exactly as declared in the calling
-c program.
-c
-c IPARAM Integer array of length 11. (INPUT/OUTPUT)
-c IPARAM(1) = ISHIFT: method for selecting the implicit shifts.
-c The shifts selected at each iteration are used to restart
-c the Arnoldi iteration in an implicit fashion.
-c -------------------------------------------------------------
-c ISHIFT = 0: the shifts are provided by the user via
-c reverse communication. The NCV eigenvalues of
-c the current tridiagonal matrix T are returned in
-c the part of WORKL array corresponding to RITZ.
-c See remark 6 below.
-c ISHIFT = 1: exact shifts with respect to the reduced
-c tridiagonal matrix T. This is equivalent to
-c restarting the iteration with a starting vector
-c that is a linear combination of Ritz vectors
-c associated with the "wanted" Ritz values.
-c -------------------------------------------------------------
-c
-c IPARAM(2) = LEVEC
-c No longer referenced. See remark 2 below.
-c
-c IPARAM(3) = MXITER
-c On INPUT: maximum number of Arnoldi update iterations allowed.
-c On OUTPUT: actual number of Arnoldi update iterations taken.
-c
-c IPARAM(4) = NB: blocksize to be used in the recurrence.
-c The code currently works only for NB = 1.
-c
-c IPARAM(5) = NCONV: number of "converged" Ritz values.
-c This represents the number of Ritz values that satisfy
-c the convergence criterion.
-c
-c IPARAM(6) = IUPD
-c No longer referenced. Implicit restarting is ALWAYS used.
-c
-c IPARAM(7) = MODE
-c On INPUT determines what type of eigenproblem is being solved.
-c Must be 1,2,3,4,5; See under \Description of igraphdsaupd for the
-c five modes available.
-c
-c IPARAM(8) = NP
-c When ido = 3 and the user provides shifts through reverse
-c communication (IPARAM(1)=0), igraphdsaupd returns NP, the number
-c of shifts the user is to provide. 0 < NP <=NCV-NEV. See Remark
-c 6 below.
-c
-c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO,
-c OUTPUT: NUMOP = total number of OP*x operations,
-c NUMOPB = total number of B*x operations if BMAT='G',
-c NUMREO = total number of steps of re-orthogonalization.
-c
-c IPNTR Integer array of length 11. (OUTPUT)
-c Pointer to mark the starting locations in the WORKD and WORKL
-c arrays for matrices/vectors used by the Lanczos iteration.
-c -------------------------------------------------------------
-c IPNTR(1): pointer to the current operand vector X in WORKD.
-c IPNTR(2): pointer to the current result vector Y in WORKD.
-c IPNTR(3): pointer to the vector B * X in WORKD when used in
-c the shift-and-invert mode.
-c IPNTR(4): pointer to the next available location in WORKL
-c that is untouched by the program.
-c IPNTR(5): pointer to the NCV by 2 tridiagonal matrix T in WORKL.
-c IPNTR(6): pointer to the NCV RITZ values array in WORKL.
-c IPNTR(7): pointer to the Ritz estimates in array WORKL associated
-c with the Ritz values located in RITZ in WORKL.
-c IPNTR(11): pointer to the NP shifts in WORKL. See Remark 6 below.
-c
-c Note: IPNTR(8:10) is only referenced by igraphdseupd. See Remark 2.
-c IPNTR(8): pointer to the NCV RITZ values of the original system.
-c IPNTR(9): pointer to the NCV corresponding error bounds.
-c IPNTR(10): pointer to the NCV by NCV matrix of eigenvectors
-c of the tridiagonal matrix T. Only referenced by
-c igraphdseupd if RVEC = .TRUE. See Remarks.
-c -------------------------------------------------------------
-c
-c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION)
-c Distributed array to be used in the basic Arnoldi iteration
-c for reverse communication. The user should not use WORKD
-c as temporary workspace during the iteration. Upon termination
-c WORKD(1:N) contains B*RESID(1:N). If the Ritz vectors are desired
-c subroutine igraphdseupd uses this output.
-c See Data Distribution Note below.
-c
-c WORKL Double precision work array of length LWORKL. (OUTPUT/WORKSPACE)
-c Private (replicated) array on each PE or array allocated on
-c the front end. See Data Distribution Note below.
-c
-c LWORKL Integer. (INPUT)
-c LWORKL must be at least NCV**2 + 8*NCV .
-c
-c INFO Integer. (INPUT/OUTPUT)
-c If INFO .EQ. 0, a randomly initial residual vector is used.
-c If INFO .NE. 0, RESID contains the initial residual vector,
-c possibly from a previous run.
-c Error flag on output.
-c = 0: Normal exit.
-c = 1: Maximum number of iterations taken.
-c All possible eigenvalues of OP has been found. IPARAM(5)
-c returns the number of wanted converged Ritz values.
-c = 2: No longer an informational error. Deprecated starting
-c with release 2 of ARPACK.
-c = 3: No shifts could be applied during a cycle of the
-c Implicitly restarted Arnoldi iteration. One possibility
-c is to increase the size of NCV relative to NEV.
-c See remark 4 below.
-c = -1: N must be positive.
-c = -2: NEV must be positive.
-c = -3: NCV must be greater than NEV and less than or equal to N.
-c = -4: The maximum number of Arnoldi update iterations allowed
-c must be greater than zero.
-c = -5: WHICH must be one of 'LM', 'SM', 'LA', 'SA' or 'BE'.
-c = -6: BMAT must be one of 'I' or 'G'.
-c = -7: Length of private work array WORKL is not sufficient.
-c = -8: Error return from trid. eigenvalue calculation;
-c Informatinal error from LAPACK routine dsteqr.
-c = -9: Starting vector is zero.
-c = -10: IPARAM(7) must be 1,2,3,4,5.
-c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatable.
-c = -12: IPARAM(1) must be equal to 0 or 1.
-c = -13: NEV and WHICH = 'BE' are incompatable.
-c = -9999: Could not build an Arnoldi factorization.
-c IPARAM(5) returns the size of the current Arnoldi
-c factorization. The user is advised to check that
-c enough workspace and array storage has been allocated.
-c
-c
-c\Remarks
-c 1. The converged Ritz values are always returned in ascending
-c algebraic order. The computed Ritz values are approximate
-c eigenvalues of OP. The selection of WHICH should be made
-c with this in mind when Mode = 3,4,5. After convergence,
-c approximate eigenvalues of the original problem may be obtained
-c with the ARPACK subroutine igraphdseupd.
-c
-c 2. If the Ritz vectors corresponding to the converged Ritz values
-c are needed, the user must call igraphdseupd immediately following completion
-c of igraphdsaupd. This is new starting with version 2.1 of ARPACK.
-c
-c 3. If M can be factored into a Cholesky factorization M = LL'
-c then Mode = 2 should not be selected. Instead one should use
-c Mode = 1 with OP = inv(L)*A*inv(L'). Appropriate triangular
-c linear systems should be solved with L and L' rather
-c than computing inverses. After convergence, an approximate
-c eigenvector z of the original problem is recovered by solving
-c L'z = x where x is a Ritz vector of OP.
-c
-c 4. At present there is no a-priori analysis to guide the selection
-c of NCV relative to NEV. The only formal requrement is that NCV > NEV.
-c However, it is recommended that NCV .ge. 2*NEV. If many problems of
-c the same type are to be solved, one should experiment with increasing
-c NCV while keeping NEV fixed for a given test problem. This will
-c usually decrease the required number of OP*x operations but it
-c also increases the work and storage required to maintain the orthogonal
-c basis vectors. The optimal "cross-over" with respect to CPU time
-c is problem dependent and must be determined empirically.
-c
-c 5. If IPARAM(7) = 2 then in the Reverse commuication interface the user
-c must do the following. When IDO = 1, Y = OP * X is to be computed.
-c When IPARAM(7) = 2 OP = inv(B)*A. After computing A*X the user
-c must overwrite X with A*X. Y is then the solution to the linear set
-c of equations B*Y = A*X.
-c
-c 6. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the
-c NP = IPARAM(8) shifts in locations:
-c 1 WORKL(IPNTR(11))
-c 2 WORKL(IPNTR(11)+1)
-c .
-c .
-c .
-c NP WORKL(IPNTR(11)+NP-1).
-c
-c The eigenvalues of the current tridiagonal matrix are located in
-c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1). They are in the
-c order defined by WHICH. The associated Ritz estimates are located in
-c WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , WORKL(IPNTR(8)+NCV-1).
-c
-c-----------------------------------------------------------------------
-c
-c\Data Distribution Note:
-c
-c Fortran-D syntax:
-c ================
-c REAL RESID(N), V(LDV,NCV), WORKD(3*N), WORKL(LWORKL)
-c DECOMPOSE D1(N), D2(N,NCV)
-c ALIGN RESID(I) with D1(I)
-c ALIGN V(I,J) with D2(I,J)
-c ALIGN WORKD(I) with D1(I) range (1:N)
-c ALIGN WORKD(I) with D1(I-N) range (N+1:2*N)
-c ALIGN WORKD(I) with D1(I-2*N) range (2*N+1:3*N)
-c DISTRIBUTE D1(BLOCK), D2(BLOCK,:)
-c REPLICATED WORKL(LWORKL)
-c
-c Cray MPP syntax:
-c ===============
-c REAL RESID(N), V(LDV,NCV), WORKD(N,3), WORKL(LWORKL)
-c SHARED RESID(BLOCK), V(BLOCK,:), WORKD(BLOCK,:)
-c REPLICATED WORKL(LWORKL)
-c
-c
-c\BeginLib
-c
-c\References:
-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
-c pp 357-385.
-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
-c Restarted Arnoldi Iteration", Rice University Technical Report
-c TR95-13, Department of Computational and Applied Mathematics.
-c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall,
-c 1980.
-c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program",
-c Computer Physics Communications, 53 (1989), pp 169-179.
-c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to
-c Implement the Spectral Transformation", Math. Comp., 48 (1987),
-c pp 663-673.
-c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos
-c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems",
-c SIAM J. Matr. Anal. Apps., January (1993).
-c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines
-c for Updating the QR decomposition", ACM TOMS, December 1990,
-c Volume 16 Number 4, pp 369-377.
-c 8. R.B. Lehoucq, D.C. Sorensen, "Implementation of Some Spectral
-c Transformations in a k-Step Arnoldi Method". In Preparation.
-c
-c\Routines called:
-c igraphdsaup2 ARPACK routine that implements the Implicitly Restarted
-c Arnoldi Iteration.
-c igraphdstats ARPACK routine that initialize timing and other statistics
-c variables.
-c igraphivout ARPACK utility routine that prints integers.
-c igraphsecond ARPACK utility routine for timing.
-c igraphdvout ARPACK utility routine that prints vectors.
-c dlamch LAPACK routine that determines machine constants.
-c
-c\Authors
-c Danny Sorensen Phuong Vu
-c Richard Lehoucq CRPC / Rice University
-c Dept. of Computational & Houston, Texas
-c Applied Mathematics
-c Rice University
-c Houston, Texas
-c
-c\Revision history:
-c 12/15/93: Version ' 2.4'
-c
-c\SCCS Information: @(#)
-c FILE: saupd.F SID: 2.7 DATE OF SID: 8/27/96 RELEASE: 2
-c
-c\Remarks
-c 1. None
-c
-c\EndLib
-c
-c-----------------------------------------------------------------------
-c
- subroutine igraphdsaupd
- & ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam,
- & ipntr, workd, workl, lworkl, info )
-c
-c %----------------------------------------------------%
-c | Include files for debugging and timing information |
-c %----------------------------------------------------%
-c
- include 'debug.h'
- include 'stat.h'
-c
-c %------------------%
-c | Scalar Arguments |
-c %------------------%
-c
- character bmat*1, which*2
- integer ido, info, ldv, lworkl, n, ncv, nev
- Double precision
- & tol
-c
-c %-----------------%
-c | Array Arguments |
-c %-----------------%
-c
- integer iparam(11), ipntr(11)
- Double precision
- & resid(n), v(ldv,ncv), workd(3*n), workl(lworkl)
-c
-c %------------%
-c | Parameters |
-c %------------%
-c
- Double precision
- & one, zero
- parameter (one = 1.0D+0, zero = 0.0D+0)
-c
-c %---------------%
-c | Local Scalars |
-c %---------------%
-c
- integer bounds, ierr, ih, iq, ishift, iupd, iw,
- & ldh, ldq, msglvl, mxiter, mode, nb,
- & nev0, next, np, ritz, j
- save bounds, ierr, ih, iq, ishift, iupd, iw,
- & ldh, ldq, msglvl, mxiter, mode, nb,
- & nev0, next, np, ritz
-c
-c %----------------------%
-c | External Subroutines |
-c %----------------------%
-c
- external igraphdsaup2, igraphdvout, igraphivout,
- & igraphsecond, igraphdstats
-c
-c %--------------------%
-c | External Functions |
-c %--------------------%
-c
- Double precision
- & dlamch
- external dlamch
-c
-c %-----------------------%
-c | Executable Statements |
-c %-----------------------%
-c
- if (ido .eq. 0) then
-c
-c %-------------------------------%
-c | Initialize timing statistics |
-c | & message level for debugging |
-c %-------------------------------%
-c
- call igraphdstats
- call igraphsecond (t0)
- msglvl = msaupd
-c
- ierr = 0
- ishift = iparam(1)
- mxiter = iparam(3)
- nb = iparam(4)
-c
-c %--------------------------------------------%
-c | Revision 2 performs only implicit restart. |
-c %--------------------------------------------%
-c
- iupd = 1
- mode = iparam(7)
-c
-c %----------------%
-c | Error checking |
-c %----------------%
-c
- if (n .le. 0) then
- ierr = -1
- else if (nev .le. 0) then
- ierr = -2
- else if (ncv .le. nev .or. ncv .gt. n) then
- ierr = -3
- end if
-c
-c %----------------------------------------------%
-c | NP is the number of additional steps to |
-c | extend the length NEV Lanczos factorization. |
-c %----------------------------------------------%
-c
- np = ncv - nev
-c
- if (mxiter .le. 0) ierr = -4
- if (which .ne. 'LM' .and.
- & which .ne. 'SM' .and.
- & which .ne. 'LA' .and.
- & which .ne. 'SA' .and.
- & which .ne. 'BE') ierr = -5
- if (bmat .ne. 'I' .and. bmat .ne. 'G') ierr = -6
-c
- if (lworkl .lt. ncv**2 + 8*ncv) ierr = -7
- if (mode .lt. 1 .or. mode .gt. 5) then
- ierr = -10
- else if (mode .eq. 1 .and. bmat .eq. 'G') then
- ierr = -11
- else if (ishift .lt. 0 .or. ishift .gt. 1) then
- ierr = -12
- else if (nev .eq. 1 .and. which .eq. 'BE') then
- ierr = -13
- end if
-c
-c %------------%
-c | Error Exit |
-c %------------%
-c
- if (ierr .ne. 0) then
- info = ierr
- ido = 99
- go to 9000
- end if
-c
-c %------------------------%
-c | Set default parameters |
-c %------------------------%
-c
- if (nb .le. 0) nb = 1
- if (tol .le. zero) tol = dlamch('EpsMach')
-c
-c %----------------------------------------------%
-c | NP is the number of additional steps to |
-c | extend the length NEV Lanczos factorization. |
-c | NEV0 is the local variable designating the |
-c | size of the invariant subspace desired. |
-c %----------------------------------------------%
-c
- np = ncv - nev
- nev0 = nev
-c
-c %-----------------------------%
-c | Zero out internal workspace |
-c %-----------------------------%
-c
- do 10 j = 1, ncv**2 + 8*ncv
- workl(j) = zero
- 10 continue
-c
-c %-------------------------------------------------------%
-c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q |
-c | etc... and the remaining workspace. |
-c | Also update pointer to be used on output. |
-c | Memory is laid out as follows: |
-c | workl(1:2*ncv) := generated tridiagonal matrix |
-c | workl(2*ncv+1:2*ncv+ncv) := ritz values |
-c | workl(3*ncv+1:3*ncv+ncv) := computed error bounds |
-c | workl(4*ncv+1:4*ncv+ncv*ncv) := rotation matrix Q |
-c | workl(4*ncv+ncv*ncv+1:7*ncv+ncv*ncv) := workspace |
-c %-------------------------------------------------------%
-c
- ldh = ncv
- ldq = ncv
- ih = 1
- ritz = ih + 2*ldh
- bounds = ritz + ncv
- iq = bounds + ncv
- iw = iq + ncv**2
- next = iw + 3*ncv
-c
- ipntr(4) = next
- ipntr(5) = ih
- ipntr(6) = ritz
- ipntr(7) = bounds
- ipntr(11) = iw
- end if
-c
-c %-------------------------------------------------------%
-c | Carry out the Implicitly restarted Lanczos Iteration. |
-c %-------------------------------------------------------%
-c
- call igraphdsaup2
- & ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd,
- & ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritz),
- & workl(bounds), workl(iq), ldq, workl(iw), ipntr, workd,
- & info )
-c
-c %--------------------------------------------------%
-c | ido .ne. 99 implies use of reverse communication |
-c | to compute operations involving OP or shifts. |
-c %--------------------------------------------------%
-c
- if (ido .eq. 3) iparam(8) = np
- if (ido .ne. 99) go to 9000
-c
- iparam(3) = mxiter
- iparam(5) = np
- iparam(9) = nopx
- iparam(10) = nbx
- iparam(11) = nrorth
-c
-c %------------------------------------%
-c | Exit if there was an informational |
-c | error within igraphdsaup2. |
-c %------------------------------------%
-c
- if (info .lt. 0) go to 9000
- if (info .eq. 2) info = 3
-c
- if (msglvl .gt. 0) then
- call igraphivout (logfil, 1, mxiter, ndigit,
- & '_saupd: number of update iterations taken')
- call igraphivout (logfil, 1, np, ndigit,
- & '_saupd: number of "converged" Ritz values')
- call igraphdvout (logfil, np, workl(Ritz), ndigit,
- & '_saupd: final Ritz values')
- call igraphdvout (logfil, np, workl(Bounds), ndigit,
- & '_saupd: corresponding error bounds')
- end if
-c
- call igraphsecond (t1)
- tsaupd = t1 - t0
-c
-c
- 9000 continue
-c
- return
-c
-c %---------------%
-c | End of igraphdsaupd |
-c %---------------%
-c
- end
diff --git a/src/dsconv.f b/src/dsconv.f
deleted file mode 100644
index d8bac2e..0000000
--- a/src/dsconv.f
+++ /dev/null
@@ -1,138 +0,0 @@
-c-----------------------------------------------------------------------
-c\BeginDoc
-c
-c\Name: igraphdsconv
-c
-c\Description:
-c Convergence testing for the symmetric Arnoldi eigenvalue routine.
-c
-c\Usage:
-c call igraphdsconv
-c ( N, RITZ, BOUNDS, TOL, NCONV )
-c
-c\Arguments
-c N Integer. (INPUT)
-c Number of Ritz values to check for convergence.
-c
-c RITZ Double precision array of length N. (INPUT)
-c The Ritz values to be checked for convergence.
-c
-c BOUNDS Double precision array of length N. (INPUT)
-c Ritz estimates associated with the Ritz values in RITZ.
-c
-c TOL Double precision scalar. (INPUT)
-c Desired relative accuracy for a Ritz value to be considered
-c "converged".
-c
-c NCONV Integer scalar. (OUTPUT)
-c Number of "converged" Ritz values.
-c
-c\EndDoc
-c
-c-----------------------------------------------------------------------
-c
-c\BeginLib
-c
-c\Routines called:
-c igraphsecond ARPACK utility routine for timing.
-c dlamch LAPACK routine that determines machine constants.
-c
-c\Author
-c Danny Sorensen Phuong Vu
-c Richard Lehoucq CRPC / Rice University
-c Dept. of Computational & Houston, Texas
-c Applied Mathematics
-c Rice University
-c Houston, Texas
-c
-c\SCCS Information: @(#)
-c FILE: sconv.F SID: 2.4 DATE OF SID: 4/19/96 RELEASE: 2
-c
-c\Remarks
-c 1. Starting with version 2.4, this routine no longer uses the
-c Parlett strategy using the gap conditions.
-c
-c\EndLib
-c
-c-----------------------------------------------------------------------
-c
- subroutine igraphdsconv (n, ritz, bounds, tol, nconv)
-c
-c %----------------------------------------------------%
-c | Include files for debugging and timing information |
-c %----------------------------------------------------%
-c
- include 'debug.h'
- include 'stat.h'
-c
-c %------------------%
-c | Scalar Arguments |
-c %------------------%
-c
- integer n, nconv
- Double precision
- & tol
-c
-c %-----------------%
-c | Array Arguments |
-c %-----------------%
-c
- Double precision
- & ritz(n), bounds(n)
-c
-c %---------------%
-c | Local Scalars |
-c %---------------%
-c
- integer i
- Double precision
- & temp, eps23
-c
-c %-------------------%
-c | External routines |
-c %-------------------%
-c
- Double precision
- & dlamch
- external dlamch
-
-c %---------------------%
-c | Intrinsic Functions |
-c %---------------------%
-c
- intrinsic abs
-c
-c %-----------------------%
-c | Executable Statements |
-c %-----------------------%
-c
- call igraphsecond (t0)
-c
- eps23 = dlamch('Epsilon-Machine')
- eps23 = eps23**(2.0D+0 / 3.0D+0)
-c
- nconv = 0
- do 10 i = 1, n
-c
-c %-----------------------------------------------------%
-c | The i-th Ritz value is considered "converged" |
-c | when: bounds(i) .le. TOL*max(eps23, abs(ritz(i))) |
-c %-----------------------------------------------------%
-c
- temp = max( eps23, abs(ritz(i)) )
- if ( bounds(i) .le. tol*temp ) then
- nconv = nconv + 1
- end if
-c
- 10 continue
-c
- call igraphsecond (t1)
- tsconv = tsconv + (t1 - t0)
-c
- return
-c
-c %---------------%
-c | End of igraphdsconv |
-c %---------------%
-c
- end
diff --git a/src/dseigt.f b/src/dseigt.f
deleted file mode 100644
index dc5dccd..0000000
--- a/src/dseigt.f
+++ /dev/null
@@ -1,181 +0,0 @@
-c-----------------------------------------------------------------------
-c\BeginDoc
-c
-c\Name: igraphdseigt
-c
-c\Description:
-c Compute the eigenvalues of the current symmetric tridiagonal matrix
-c and the corresponding error bounds given the current residual norm.
-c
-c\Usage:
-c call igraphdseigt
-c ( RNORM, N, H, LDH, EIG, BOUNDS, WORKL, IERR )
-c
-c\Arguments
-c RNORM Double precision scalar. (INPUT)
-c RNORM contains the residual norm corresponding to the current
-c symmetric tridiagonal matrix H.
-c
-c N Integer. (INPUT)
-c Size of the symmetric tridiagonal matrix H.
-c
-c H Double precision N by 2 array. (INPUT)
-c H contains the symmetric tridiagonal matrix with the
-c subdiagonal in the first column starting at H(2,1) and the
-c main diagonal in igraphsecond column.
-c
-c LDH Integer. (INPUT)
-c Leading dimension of H exactly as declared in the calling
-c program.
-c
-c EIG Double precision array of length N. (OUTPUT)
-c On output, EIG contains the N eigenvalues of H possibly
-c unsorted. The BOUNDS arrays are returned in the
-c same sorted order as EIG.
-c
-c BOUNDS Double precision array of length N. (OUTPUT)
-c On output, BOUNDS contains the error estimates corresponding
-c to the eigenvalues EIG. This is equal to RNORM times the
-c last components of the eigenvectors corresponding to the
-c eigenvalues in EIG.
-c
-c WORKL Double precision work array of length 3*N. (WORKSPACE)
-c Private (replicated) array on each PE or array allocated on
-c the front end.
-c
-c IERR Integer. (OUTPUT)
-c Error exit flag from igraphdstqrb.
-c
-c\EndDoc
-c
-c-----------------------------------------------------------------------
-c
-c\BeginLib
-c
-c\Local variables:
-c xxxxxx real
-c
-c\Routines called:
-c igraphdstqrb ARPACK routine that computes the eigenvalues and the
-c last components of the eigenvectors of a symmetric
-c and tridiagonal matrix.
-c igraphsecond ARPACK utility routine for timing.
-c igraphdvout ARPACK utility routine that prints vectors.
-c dcopy Level 1 BLAS that copies one vector to another.
-c
-c\Author
-c Danny Sorensen Phuong Vu
-c Richard Lehoucq CRPC / Rice University
-c Dept. of Computational & Houston, Texas
-c Applied Mathematics
-c Rice University
-c Houston, Texas
-c
-c\Revision history:
-c xx/xx/92: Version ' 2.4'
-c
-c\SCCS Information: @(#)
-c FILE: seigt.F SID: 2.4 DATE OF SID: 8/27/96 RELEASE: 2
-c
-c\Remarks
-c None
-c
-c\EndLib
-c
-c-----------------------------------------------------------------------
-c
- subroutine igraphdseigt
- & ( rnorm, n, h, ldh, eig, bounds, workl, ierr )
-c
-c %----------------------------------------------------%
-c | Include files for debugging and timing information |
-c %----------------------------------------------------%
-c
- include 'debug.h'
- include 'stat.h'
-c
-c %------------------%
-c | Scalar Arguments |
-c %------------------%
-c
- integer ierr, ldh, n
- Double precision
- & rnorm
-c
-c %-----------------%
-c | Array Arguments |
-c %-----------------%
-c
- Double precision
- & eig(n), bounds(n), h(ldh,2), workl(3*n)
-c
-c %------------%
-c | Parameters |
-c %------------%
-c
- Double precision
- & zero
- parameter (zero = 0.0D+0)
-c
-c %---------------%
-c | Local Scalars |
-c %---------------%
-c
- integer i, k, msglvl
-c
-c %----------------------%
-c | External Subroutines |
-c %----------------------%
-c
- external dcopy, igraphdstqrb, igraphdvout, igraphsecond
-c
-c %-----------------------%
-c | Executable Statements |
-c %-----------------------%
-c
-c %-------------------------------%
-c | Initialize timing statistics |
-c | & message level for debugging |
-c %-------------------------------%
-c
- call igraphsecond (t0)
- msglvl = mseigt
-c
- if (msglvl .gt. 0) then
- call igraphdvout (logfil, n, h(1,2), ndigit,
- & '_seigt: main diagonal of matrix H')
- if (n .gt. 1) then
- call igraphdvout (logfil, n-1, h(2,1), ndigit,
- & '_seigt: sub diagonal of matrix H')
- end if
- end if
-c
- call dcopy (n, h(1,2), 1, eig, 1)
- call dcopy (n-1, h(2,1), 1, workl, 1)
- call igraphdstqrb (n, eig, workl, bounds, workl(n+1), ierr)
- if (ierr .ne. 0) go to 9000
- if (msglvl .gt. 1) then
- call igraphdvout (logfil, n, bounds, ndigit,
- & '_seigt: last row of the eigenvector matrix for H')
- end if
-c
-c %-----------------------------------------------%
-c | Finally determine the error bounds associated |
-c | with the n Ritz values of H. |
-c %-----------------------------------------------%
-c
- do 30 k = 1, n
- bounds(k) = rnorm*abs(bounds(k))
- 30 continue
-c
- call igraphsecond (t1)
- tseigt = tseigt + (t1 - t0)
-c
- 9000 continue
- return
-c
-c %---------------%
-c | End of igraphdseigt |
-c %---------------%
-c
- end
diff --git a/src/dsesrt.f b/src/dsesrt.f
deleted file mode 100644
index 05e2c36..0000000
--- a/src/dsesrt.f
+++ /dev/null
@@ -1,217 +0,0 @@
-c-----------------------------------------------------------------------
-c\BeginDoc
-c
-c\Name: igraphdsesrt
-c
-c\Description:
-c Sort the array X in the order specified by WHICH and optionally
-c apply the permutation to the columns of the matrix A.
-c
-c\Usage:
-c call igraphdsesrt
-c ( WHICH, APPLY, N, X, NA, A, LDA)
-c
-c\Arguments
-c WHICH Character*2. (Input)
-c 'LM' -> X is sorted into increasing order of magnitude.
-c 'SM' -> X is sorted into decreasing order of magnitude.
-c 'LA' -> X is sorted into increasing order of algebraic.
-c 'SA' -> X is sorted into decreasing order of algebraic.
-c
-c APPLY Logical. (Input)
-c APPLY = .TRUE. -> apply the sorted order to A.
-c APPLY = .FALSE. -> do not apply the sorted order to A.
-c
-c N Integer. (INPUT)
-c Dimension of the array X.
-c
-c X Double precision array of length N. (INPUT/OUTPUT)
-c The array to be sorted.
-c
-c NA Integer. (INPUT)
-c Number of rows of the matrix A.
-c
-c A Double precision array of length NA by N. (INPUT/OUTPUT)
-c
-c LDA Integer. (INPUT)
-c Leading dimension of A.
-c
-c\EndDoc
-c
-c-----------------------------------------------------------------------
-c
-c\BeginLib
-c
-c\Routines
-c dswap Level 1 BLAS that swaps the contents of two vectors.
-c
-c\Authors
-c Danny Sorensen Phuong Vu
-c Richard Lehoucq CRPC / Rice University
-c Dept. of Computational & Houston, Texas
-c Applied Mathematics
-c Rice University
-c Houston, Texas
-c
-c\Revision history:
-c 12/15/93: Version ' 2.1'.
-c Adapted from the sort routine in LANSO and
-c the ARPACK code igraphdsortr
-c
-c\SCCS Information: @(#)
-c FILE: sesrt.F SID: 2.3 DATE OF SID: 4/19/96 RELEASE: 2
-c
-c\EndLib
-c
-c-----------------------------------------------------------------------
-c
- subroutine igraphdsesrt (which, apply, n, x, na, a, lda)
-c
-c %------------------%
-c | Scalar Arguments |
-c %------------------%
-c
- character*2 which
- logical apply
- integer lda, n, na
-c
-c %-----------------%
-c | Array Arguments |
-c %-----------------%
-c
- Double precision
- & x(0:n-1), a(lda, 0:n-1)
-c
-c %---------------%
-c | Local Scalars |
-c %---------------%
-c
- integer i, igap, j
- Double precision
- & temp
-c
-c %----------------------%
-c | External Subroutines |
-c %----------------------%
-c
- external dswap
-c
-c %-----------------------%
-c | Executable Statements |
-c %-----------------------%
-c
- igap = n / 2
-c
- if (which .eq. 'SA') then
-c
-c X is sorted into decreasing order of algebraic.
-c
- 10 continue
- if (igap .eq. 0) go to 9000
- do 30 i = igap, n-1
- j = i-igap
- 20 continue
-c
- if (j.lt.0) go to 30
-c
- if (x(j).lt.x(j+igap)) then
- temp = x(j)
- x(j) = x(j+igap)
- x(j+igap) = temp
- if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1)
- else
- go to 30
- endif
- j = j-igap
- go to 20
- 30 continue
- igap = igap / 2
- go to 10
-c
- else if (which .eq. 'SM') then
-c
-c X is sorted into decreasing order of magnitude.
-c
- 40 continue
- if (igap .eq. 0) go to 9000
- do 60 i = igap, n-1
- j = i-igap
- 50 continue
-c
- if (j.lt.0) go to 60
-c
- if (abs(x(j)).lt.abs(x(j+igap))) then
- temp = x(j)
- x(j) = x(j+igap)
- x(j+igap) = temp
- if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1)
- else
- go to 60
- endif
- j = j-igap
- go to 50
- 60 continue
- igap = igap / 2
- go to 40
-c
- else if (which .eq. 'LA') then
-c
-c X is sorted into increasing order of algebraic.
-c
- 70 continue
- if (igap .eq. 0) go to 9000
- do 90 i = igap, n-1
- j = i-igap
- 80 continue
-c
- if (j.lt.0) go to 90
-c
- if (x(j).gt.x(j+igap)) then
- temp = x(j)
- x(j) = x(j+igap)
- x(j+igap) = temp
- if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1)
- else
- go to 90
- endif
- j = j-igap
- go to 80
- 90 continue
- igap = igap / 2
- go to 70
-c
- else if (which .eq. 'LM') then
-c
-c X is sorted into increasing order of magnitude.
-c
- 100 continue
- if (igap .eq. 0) go to 9000
- do 120 i = igap, n-1
- j = i-igap
- 110 continue
-c
- if (j.lt.0) go to 120
-c
- if (abs(x(j)).gt.abs(x(j+igap))) then
- temp = x(j)
- x(j) = x(j+igap)
- x(j+igap) = temp
- if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1)
- else
- go to 120
- endif
- j = j-igap
- go to 110
- 120 continue
- igap = igap / 2
- go to 100
- end if
-c
- 9000 continue
- return
-c
-c %---------------%
-c | End of igraphdsesrt |
-c %---------------%
-c
- end
diff --git a/src/dseupd.f b/src/dseupd.f
deleted file mode 100644
index 0336c3a..0000000
--- a/src/dseupd.f
+++ /dev/null
@@ -1,905 +0,0 @@
-c\BeginDoc
-c
-c\Name: igraphdseupd
-c
-c\Description:
-c
-c This subroutine returns the converged approximations to eigenvalues
-c of A*z = lambda*B*z and (optionally):
-c
-c (1) the corresponding approximate eigenvectors,
-c
-c (2) an orthonormal (Lanczos) basis for the associated approximate
-c invariant subspace,
-c
-c (3) Both.
-c
-c There is negligible additional cost to obtain eigenvectors. An orthonormal
-c (Lanczos) basis is always computed. There is an additional storage cost
-c of n*nev if both are requested (in this case a separate array Z must be
-c supplied).
-c
-c These quantities are obtained from the Lanczos factorization computed
-c by DSAUPD for the linear operator OP prescribed by the MODE selection
-c (see IPARAM(7) in DSAUPD documentation.) DSAUPD must be called before
-c this routine is called. These approximate eigenvalues and vectors are
-c commonly called Ritz values and Ritz vectors respectively. They are
-c referred to as such in the comments that follow. The computed orthonormal
-c basis for the invariant subspace corresponding to these Ritz values is
-c referred to as a Lanczos basis.
-c
-c See documentation in the header of the subroutine DSAUPD for a definition
-c of OP as well as other terms and the relation of computed Ritz values
-c and vectors of OP with respect to the given problem A*z = lambda*B*z.
-c
-c The approximate eigenvalues of the original problem are returned in
-c ascending algebraic order. The user may elect to call this routine
-c once for each desired Ritz vector and store it peripherally if desired.
-c There is also the option of computing a selected set of these vectors
-c with a single call.
-c
-c\Usage:
-c call igraphdseupd
-c ( RVEC, HOWMNY, SELECT, D, Z, LDZ, SIGMA, BMAT, N, WHICH, NEV, TOL,
-c RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD, WORKL, LWORKL, INFO )
-c
-c RVEC LOGICAL (INPUT)
-c Specifies whether Ritz vectors corresponding to the Ritz value
-c approximations to the eigenproblem A*z = lambda*B*z are computed.
-c
-c RVEC = .FALSE. Compute Ritz values only.
-c
-c RVEC = .TRUE. Compute Ritz vectors.
-c
-c HOWMNY Character*1 (INPUT)
-c Specifies how many Ritz vectors are wanted and the form of Z
-c the matrix of Ritz vectors. See remark 1 below.
-c = 'A': compute NEV Ritz vectors;
-c = 'S': compute some of the Ritz vectors, specified
-c by the logical array SELECT.
-c
-c SELECT Logical array of dimension NEV. (INPUT)
-c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be
-c computed. To select the Ritz vector corresponding to a
-c Ritz value D(j), SELECT(j) must be set to .TRUE..
-c If HOWMNY = 'A' , SELECT is not referenced.
-c
-c D Double precision array of dimension NEV. (OUTPUT)
-c On exit, D contains the Ritz value approximations to the
-c eigenvalues of A*z = lambda*B*z. The values are returned
-c in ascending order. If IPARAM(7) = 3,4,5 then D represents
-c the Ritz values of OP computed by igraphdsaupd transformed to
-c those of the original eigensystem A*z = lambda*B*z. If
-c IPARAM(7) = 1,2 then the Ritz values of OP are the same
-c as the those of A*z = lambda*B*z.
-c
-c Z Double precision N by NEV array if HOWMNY = 'A'. (OUTPUT)
-c On exit, Z contains the B-orthonormal Ritz vectors of the
-c eigensystem A*z = lambda*B*z corresponding to the Ritz
-c value approximations.
-c If RVEC = .FALSE. then Z is not referenced.
-c NOTE: The array Z may be set equal to first NEV columns of the
-c Arnoldi/Lanczos basis array V computed by DSAUPD.
-c
-c LDZ Integer. (INPUT)
-c The leading dimension of the array Z. If Ritz vectors are
-c desired, then LDZ .ge. max( 1, N ). In any case, LDZ .ge. 1.
-c
-c SIGMA Double precision (INPUT)
-c If IPARAM(7) = 3,4,5 represents the shift. Not referenced if
-c IPARAM(7) = 1 or 2.
-c
-c
-c **** The remaining arguments MUST be the same as for the ****
-c **** call to DNAUPD that was just completed. ****
-c
-c NOTE: The remaining arguments
-c
-c BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR,
-c WORKD, WORKL, LWORKL, INFO
-c
-c must be passed directly to DSEUPD following the last call
-c to DSAUPD. These arguments MUST NOT BE MODIFIED between
-c the the last call to DSAUPD and the call to DSEUPD.
-c
-c Two of these parameters (WORKL, INFO) are also output parameters:
-c
-c WORKL Double precision work array of length LWORKL. (OUTPUT/WORKSPACE)
-c WORKL(1:4*ncv) contains information obtained in
-c igraphdsaupd. They are not changed by igraphdseupd.
-c WORKL(4*ncv+1:ncv*ncv+8*ncv) holds the
-c untransformed Ritz values, the computed error estimates,
-c and the associated eigenvector matrix of H.
-c
-c Note: IPNTR(8:10) contains the pointer into WORKL for addresses
-c of the above information computed by igraphdseupd.
-c -------------------------------------------------------------
-c IPNTR(8): pointer to the NCV RITZ values of the original system.
-c IPNTR(9): pointer to the NCV corresponding error bounds.
-c IPNTR(10): pointer to the NCV by NCV matrix of eigenvectors
-c of the tridiagonal matrix T. Only referenced by
-c igraphdseupd if RVEC = .TRUE. See Remarks.
-c -------------------------------------------------------------
-c
-c INFO Integer. (OUTPUT)
-c Error flag on output.
-c = 0: Normal exit.
-c = -1: N must be positive.
-c = -2: NEV must be positive.
-c = -3: NCV must be greater than NEV and less than or equal to N.
-c = -5: WHICH must be one of 'LM', 'SM', 'LA', 'SA' or 'BE'.
-c = -6: BMAT must be one of 'I' or 'G'.
-c = -7: Length of private work WORKL array is not sufficient.
-c = -8: Error return from trid. eigenvalue calculation;
-c Information error from LAPACK routine dsteqr.
-c = -9: Starting vector is zero.
-c = -10: IPARAM(7) must be 1,2,3,4,5.
-c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible.
-c = -12: NEV and WHICH = 'BE' are incompatible.
-c = -14: DSAUPD did not find any eigenvalues to sufficient
-c accuracy.
-c = -15: HOWMNY must be one of 'A' or 'S' if RVEC = .true.
-c = -16: HOWMNY = 'S' not yet implemented
-c
-c\BeginLib
-c
-c\References:
-c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
-c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
-c pp 357-385.
-c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
-c Restarted Arnoldi Iteration", Rice University Technical Report
-c TR95-13, Department of Computational and Applied Mathematics.
-c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall,
-c 1980.
-c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program",
-c Computer Physics Communications, 53 (1989), pp 169-179.
-c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to
-c Implement the Spectral Transformation", Math. Comp., 48 (1987),
-c pp 663-673.
-c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos
-c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems",
-c SIAM J. Matr. Anal. Apps., January (1993).
-c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines
-c for Updating the QR decomposition", ACM TOMS, December 1990,
-c Volume 16 Number 4, pp 369-377.
-c
-c\Remarks
-c 1. The converged Ritz values are always returned in increasing
-c (algebraic) order.
-c
-c 2. Currently only HOWMNY = 'A' is implemented. It is included at this
-c stage for the user who wants to incorporate it.
-c
-c\Routines called:
-c igraphdsesrt ARPACK routine that sorts an array X, and applies the
-c corresponding permutation to a matrix A.
-c igraphdsortr igraphdsortr ARPACK sorting routine.
-c igraphivout ARPACK utility routine that prints integers.
-c igraphdvout ARPACK utility routine that prints vectors.
-c dgeqr2 LAPACK routine that computes the QR factorization of
-c a matrix.
-c dlacpy LAPACK matrix copy routine.
-c dlamch LAPACK routine that determines machine constants.
-c dorm2r LAPACK routine that applies an orthogonal matrix in
-c factored form.
-c dsteqr LAPACK routine that computes eigenvalues and eigenvectors
-c of a tridiagonal matrix.
-c dger Level 2 BLAS rank one update to a matrix.
-c dcopy Level 1 BLAS that copies one vector to another .
-c dnrm2 Level 1 BLAS that computes the norm of a vector.
-c dscal Level 1 BLAS that scales a vector.
-c dswap Level 1 BLAS that swaps the contents of two vectors.
-
-c\Authors
-c Danny Sorensen Phuong Vu
-c Richard Lehoucq CRPC / Rice University
-c Chao Yang Houston, Texas
-c Dept. of Computational &
-c Applied Mathematics
-c Rice University
-c Houston, Texas
-c
-c\Revision history:
-c 12/15/93: Version ' 2.1'
-c
-c\SCCS Information: @(#)
-c FILE: seupd.F SID: 2.7 DATE OF SID: 8/27/96 RELEASE: 2
-c
-c\EndLib
-c
-c-----------------------------------------------------------------------
- subroutine igraphdseupd (rvec, howmny, select, d, z, ldz,
- & sigma, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam,
- & ipntr, workd, workl, lworkl, info )
-c
-c %----------------------------------------------------%
-c | Include files for debugging and timing information |
-c %----------------------------------------------------%
-c
- include 'debug.h'
- include 'stat.h'
-c
-c %------------------%
-c | Scalar Arguments |
-c %------------------%
-c
- character bmat, howmny, which*2
- logical rvec, select(ncv)
- integer info, ldz, ldv, lworkl, n, ncv, nev
- Double precision
- & sigma, tol
-c
-c %-----------------%
-c | Array Arguments |
-c %-----------------%
-c
- integer iparam(7), ipntr(11)
- Double precision
- & d(nev), resid(n), v(ldv,ncv), z(ldz, nev),
- & workd(2*n), workl(lworkl)
-c
-c %------------%
-c | Parameters |
-c %------------%
-c
- Double precision
- & one, zero
- parameter (one = 1.0D+0, zero = 0.0D+0)
-c
-c %---------------%
-c | Local Scalars |
-c %---------------%
-c
- character type*6
- integer bounds, ierr, ih, ihb, ihd, iq, iw, j, k,
- & ldh, ldq, mode, msglvl, nconv, next, ritz,
- & irz, ibd, ktrord, leftptr, rghtptr, ism, ilg
- Double precision
- & bnorm2, rnorm, temp, thres1, thres2, tempbnd, eps23
- logical reord
-c
-c %--------------%
-c | Local Arrays |
-c %--------------%
-c
- Double precision
- & kv(2)
-c
-c %----------------------%
-c | External Subroutines |
-c %----------------------%
-c
- external dcopy, dger, dgeqr2, dlacpy, dorm2r, dscal,
- & igraphdsesrt, dsteqr, dswap, igraphdvout,
- & igraphivout, igraphdsortr
-c
-c %--------------------%
-c | External Functions |
-c %--------------------%
-c
- Double precision
- & dnrm2, dlamch
- external dnrm2, dlamch
-c
-c %---------------------%
-c | Intrinsic Functions |
-c %---------------------%
-c
- intrinsic min
-c
-c %-----------------------%
-c | Executable Statements |
-c %-----------------------%
-c
-c %------------------------%
-c | Set default parameters |
-c %------------------------%
-c
- msglvl = mseupd
- mode = iparam(7)
- nconv = iparam(5)
- info = 0
-c
-c %--------------%
-c | Quick return |
-c %--------------%
-c
- if (nconv .eq. 0) go to 9000
- ierr = 0
-c
- if (nconv .le. 0) ierr = -14
- if (n .le. 0) ierr = -1
- if (nev .le. 0) ierr = -2
- if (ncv .le. nev .or. ncv .gt. n) ierr = -3
- if (which .ne. 'LM' .and.
- & which .ne. 'SM' .and.
- & which .ne. 'LA' .and.
- & which .ne. 'SA' .and.
- & which .ne. 'BE') ierr = -5
- if (bmat .ne. 'I' .and. bmat .ne. 'G') ierr = -6
- if ( (howmny .ne. 'A' .and.
- & howmny .ne. 'P' .and.
- & howmny .ne. 'S') .and. rvec )
- & ierr = -15
- if (rvec .and. howmny .eq. 'S') ierr = -16
-c
- if (rvec .and. lworkl .lt. ncv**2+8*ncv) ierr = -7
-c
- if (mode .eq. 1 .or. mode .eq. 2) then
- type = 'REGULR'
- else if (mode .eq. 3 ) then
- type = 'SHIFTI'
- else if (mode .eq. 4 ) then
- type = 'BUCKLE'
- else if (mode .eq. 5 ) then
- type = 'CAYLEY'
- else
- ierr = -10
- end if
- if (mode .eq. 1 .and. bmat .eq. 'G') ierr = -11
- if (nev .eq. 1 .and. which .eq. 'BE') ierr = -12
-c
-c %------------%
-c | Error Exit |
-c %------------%
-c
- if (ierr .ne. 0) then
- info = ierr
- go to 9000
- end if
-c
-c %-------------------------------------------------------%
-c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q |
-c | etc... and the remaining workspace. |
-c | Also update pointer to be used on output. |
-c | Memory is laid out as follows: |
-c | workl(1:2*ncv) := generated tridiagonal matrix H |
-c | The subdiagonal is stored in workl(2:ncv). |
-c | The dead spot is workl(1) but upon exiting |
-c | igraphdsaupd stores the B-norm of the last residual |
-c | vector in workl(1). We use this !!! |
-c | workl(2*ncv+1:2*ncv+ncv) := ritz values |
-c | The wanted values are in the first NCONV spots. |
-c | workl(3*ncv+1:3*ncv+ncv) := computed Ritz estimates |
-c | The wanted values are in the first NCONV spots. |
-c | NOTE: workl(1:4*ncv) is set by igraphdsaupd and is not |
-c | modified by igraphdseupd. |
-c %-------------------------------------------------------%
-c
-c %-------------------------------------------------------%
-c | The following is used and set by igraphdseupd. |
-c | workl(4*ncv+1:4*ncv+ncv) := used as workspace during |
-c | computation of the eigenvectors of H. Stores |
-c | the diagonal of H. Upon EXIT contains the NCV |
-c | Ritz values of the original system. The first |
-c | NCONV spots have the wanted values. If MODE = |
-c | 1 or 2 then will equal workl(2*ncv+1:3*ncv). |
-c | workl(5*ncv+1:5*ncv+ncv) := used as workspace during |
-c | computation of the eigenvectors of H. Stores |
-c | the subdiagonal of H. Upon EXIT contains the |
-c | NCV corresponding Ritz estimates of the |
-c | original system. The first NCONV spots have the |
-c | wanted values. If MODE = 1,2 then will equal |
-c | workl(3*ncv+1:4*ncv). |
-c | workl(6*ncv+1:6*ncv+ncv*ncv) := orthogonal Q that is |
-c | the eigenvector matrix for H as returned by |
-c | dsteqr. Not referenced if RVEC = .False. |
-c | Ordering follows that of workl(4*ncv+1:5*ncv) |
-c | workl(6*ncv+ncv*ncv+1:6*ncv+ncv*ncv+2*ncv) := |
-c | Workspace. Needed by dsteqr and by igraphdseupd. |
-c | GRAND total of NCV*(NCV+8) locations. |
-c %-------------------------------------------------------%
-c
-c
- ih = ipntr(5)
- ritz = ipntr(6)
- bounds = ipntr(7)
- ldh = ncv
- ldq = ncv
- ihd = bounds + ldh
- ihb = ihd + ldh
- iq = ihb + ldh
- iw = iq + ldh*ncv
- next = iw + 2*ncv
- ipntr(4) = next
- ipntr(8) = ihd
- ipntr(9) = ihb
- ipntr(10) = iq
-c
-c %----------------------------------------%
-c | irz points to the Ritz values computed |
-c | by _seigt before exiting _saup2. |
-c | ibd points to the Ritz estimates |
-c | computed by _seigt before exiting |
-c | _saup2. |
-c %----------------------------------------%
-c
- irz = ipntr(11)+ncv
- ibd = irz+ncv
-c
-c
-c %---------------------------------%
-c | Set machine dependent constant. |
-c %---------------------------------%
-c
- eps23 = dlamch('Epsilon-Machine')
- eps23 = eps23**(2.0D+0 / 3.0D+0)
-c
-c %---------------------------------------%
-c | RNORM is B-norm of the RESID(1:N). |
-c | BNORM2 is the 2 norm of B*RESID(1:N). |
-c | Upon exit of igraphdsaupd WORKD(1:N) has |
-c | B*RESID(1:N). |
-c %---------------------------------------%
-c
- rnorm = workl(ih)
- if (bmat .eq. 'I') then
- bnorm2 = rnorm
- else if (bmat .eq. 'G') then
- bnorm2 = dnrm2(n, workd, 1)
- end if
-c
- if (rvec) then
-c
-c %------------------------------------------------%
-c | Get the converged Ritz value on the boundary. |
-c | This value will be used to dermine whether we |
-c | need to reorder the eigenvalues and |
-c | eigenvectors comupted by _steqr, and is |
-c | referred to as the "threshold" value. |
-c | |
-c | A Ritz value gamma is said to be a wanted |
-c | one, if |
-c | abs(gamma) .ge. threshold, when WHICH = 'LM'; |
-c | abs(gamma) .le. threshold, when WHICH = 'SM'; |
-c | gamma .ge. threshold, when WHICH = 'LA'; |
-c | gamma .le. threshold, when WHICH = 'SA'; |
-c | gamma .le. thres1 .or. gamma .ge. thres2 |
-c | when WHICH = 'BE'; |
-c | |
-c | Note: converged Ritz values and associated |
-c | Ritz estimates have been placed in the first |
-c | NCONV locations in workl(ritz) and |
-c | workl(bounds) respectively. They have been |
-c | sorted (in _saup2) according to the WHICH |
-c | selection criterion. (Except in the case |
-c | WHICH = 'BE', they are sorted in an increasing |
-c | order.) |
-c %------------------------------------------------%
-c
- if (which .eq. 'LM' .or. which .eq. 'SM'
- & .or. which .eq. 'LA' .or. which .eq. 'SA' ) then
-c
- thres1 = workl(ritz)
-c
- if (msglvl .gt. 2) then
- call igraphdvout(logfil, 1, [thres1], ndigit,
- & '_seupd: Threshold eigenvalue used for re-ordering')
- end if
-c
- else if (which .eq. 'BE') then
-c
-c %------------------------------------------------%
-c | Ritz values returned from _saup2 have been |
-c | sorted in increasing order. Thus two |
-c | "threshold" values (one for the small end, one |
-c | for the large end) are in the middle. |
-c %------------------------------------------------%
-c
- ism = max(nev,nconv) / 2
- ilg = ism + 1
- thres1 = workl(ism)
- thres2 = workl(ilg)
-c
- if (msglvl .gt. 2) then
- kv(1) = thres1
- kv(2) = thres2
- call igraphdvout(logfil, 2, kv, ndigit,
- & '_seupd: Threshold eigenvalues used for re-ordering')
- end if
-c
- end if
-c
-c %----------------------------------------------------------%
-c | Check to see if all converged Ritz values appear within |
-c | the first NCONV diagonal elements returned from _seigt. |
-c | This is done in the following way: |
-c | |
-c | 1) For each Ritz value obtained from _seigt, compare it |
-c | with the threshold Ritz value computed above to |
-c | determine whether it is a wanted one. |
-c | |
-c | 2) If it is wanted, then check the corresponding Ritz |
-c | estimate to see if it has converged. If it has, set |
-c | correponding entry in the logical array SELECT to |
-c | .TRUE.. |
-c | |
-c | If SELECT(j) = .TRUE. and j > NCONV, then there is a |
-c | converged Ritz value that does not appear at the top of |
-c | the diagonal matrix computed by _seigt in _saup2. |
-c | Reordering is needed. |
-c %----------------------------------------------------------%
-c
- reord = .false.
- ktrord = 0
- do 10 j = 0, ncv-1
- select(j+1) = .false.
- if (which .eq. 'LM') then
- if (abs(workl(irz+j)) .ge. abs(thres1)) then
- tempbnd = max( eps23, abs(workl(irz+j)) )
- if (workl(ibd+j) .le. tol*tempbnd) then
- select(j+1) = .true.
- end if
- end if
- else if (which .eq. 'SM') then
- if (abs(workl(irz+j)) .le. abs(thres1)) then
- tempbnd = max( eps23, abs(workl(irz+j)) )
- if (workl(ibd+j) .le. tol*tempbnd) then
- select(j+1) = .true.
- end if
- end if
- else if (which .eq. 'LA') then
- if (workl(irz+j) .ge. thres1) then
- tempbnd = max( eps23, abs(workl(irz+j)) )
- if (workl(ibd+j) .le. tol*tempbnd) then
- select(j+1) = .true.
- end if
- end if
- else if (which .eq. 'SA') then
- if (workl(irz+j) .le. thres1) then
- tempbnd = max( eps23, abs(workl(irz+j)) )
- if (workl(ibd+j) .le. tol*tempbnd) then
- select(j+1) = .true.
- end if
- end if
- else if (which .eq. 'BE') then
- if ( workl(irz+j) .le. thres1 .or.
- & workl(irz+j) .ge. thres2 ) then
- tempbnd = max( eps23, abs(workl(irz+j)) )
- if (workl(ibd+j) .le. tol*tempbnd) then
- select(j+1) = .true.
- end if
- end if
- end if
- if (j+1 .gt. nconv ) reord = select(j+1) .or. reord
- if (select(j+1)) ktrord = ktrord + 1
- 10 continue
-
-c %-------------------------------------------%
-c | If KTRORD .ne. NCONV, something is wrong. |
-c %-------------------------------------------%
-c
- if (msglvl .gt. 2) then
- call igraphivout(logfil, 1, [ktrord], ndigit,
- & '_seupd: Number of specified eigenvalues')
- call igraphivout(logfil, 1, [nconv], ndigit,
- & '_seupd: Number of "converged" eigenvalues')
- end if
-c
-c %-----------------------------------------------------------%
-c | Call LAPACK routine _steqr to compute the eigenvalues and |
-c | eigenvectors of the final symmetric tridiagonal matrix H. |
-c | Initialize the eigenvector matrix Q to the identity. |
-c %-----------------------------------------------------------%
-c
- call dcopy (ncv-1, workl(ih+1), 1, workl(ihb), 1)
- call dcopy (ncv, workl(ih+ldh), 1, workl(ihd), 1)
-c
- call dsteqr ('Identity', ncv, workl(ihd), workl(ihb),
- & workl(iq), ldq, workl(iw), ierr)
-c
- if (ierr .ne. 0) then
- info = -8
- go to 9000
- end if
-c
- if (msglvl .gt. 1) then
- call dcopy (ncv, workl(iq+ncv-1), ldq, workl(iw), 1)
- call igraphdvout (logfil, ncv, workl(ihd), ndigit,
- & '_seupd: NCV Ritz values of the final H matrix')
- call igraphdvout (logfil, ncv, workl(iw), ndigit,
- & '_seupd: last row of the eigenvector matrix for H')
- end if
-c
- if (reord) then
-c
-c %---------------------------------------------%
-c | Reordered the eigenvalues and eigenvectors |
-c | computed by _steqr so that the "converged" |
-c | eigenvalues appear in the first NCONV |
-c | positions of workl(ihd), and the associated |
-c | eigenvectors appear in the first NCONV |
-c | columns. |
-c %---------------------------------------------%
-c
- leftptr = 1
- rghtptr = ncv
-c
- if (ncv .eq. 1) go to 30
-c
- 20 if (select(leftptr)) then
-c
-c %-------------------------------------------%
-c | Search, from the left, for the first Ritz |
-c | value that has not converged. |
-c %-------------------------------------------%
-c
- leftptr = leftptr + 1
-c
- else if ( .not. select(rghtptr)) then
-c
-c %----------------------------------------------%
-c | Search, from the right, the first Ritz value |
-c | that has converged. |
-c %----------------------------------------------%
-c
- rghtptr = rghtptr - 1
-c
- else
-c
-c %----------------------------------------------%
-c | Swap the Ritz value on the left that has not |
-c | converged with the Ritz value on the right |
-c | that has converged. Swap the associated |
-c | eigenvector of the tridiagonal matrix H as |
-c | well. |
-c %----------------------------------------------%
-c
- temp = workl(ihd+leftptr-1)
- workl(ihd+leftptr-1) = workl(ihd+rghtptr-1)
- workl(ihd+rghtptr-1) = temp
- call dcopy(ncv, workl(iq+ncv*(leftptr-1)), 1,
- & workl(iw), 1)
- call dcopy(ncv, workl(iq+ncv*(rghtptr-1)), 1,
- & workl(iq+ncv*(leftptr-1)), 1)
- call dcopy(ncv, workl(iw), 1,
- & workl(iq+ncv*(rghtptr-1)), 1)
- leftptr = leftptr + 1
- rghtptr = rghtptr - 1
-c
- end if
-c
- if (leftptr .lt. rghtptr) go to 20
-c
- 30 end if
-c
- if (msglvl .gt. 2) then
- call igraphdvout (logfil, ncv, workl(ihd), ndigit,
- & '_seupd: The eigenvalues of H--reordered')
- end if
-c
-c %----------------------------------------%
-c | Load the converged Ritz values into D. |
-c %----------------------------------------%
-c
- call dcopy(nconv, workl(ihd), 1, d, 1)
-c
- else
-c
-c %-----------------------------------------------------%
-c | Ritz vectors not required. Load Ritz values into D. |
-c %-----------------------------------------------------%
-c
- call dcopy (nconv, workl(ritz), 1, d, 1)
- call dcopy (ncv, workl(ritz), 1, workl(ihd), 1)
-c
- end if
-c
-c %------------------------------------------------------------------%
-c | Transform the Ritz values and possibly vectors and corresponding |
-c | Ritz estimates of OP to those of A*x=lambda*B*x. The Ritz values |
-c | (and corresponding data) are returned in ascending order. |
-c %------------------------------------------------------------------%
-c
- if (type .eq. 'REGULR') then
-c
-c %---------------------------------------------------------%
-c | Ascending sort of wanted Ritz values, vectors and error |
-c | bounds. Not necessary if only Ritz values are desired. |
-c %---------------------------------------------------------%
-c
- if (rvec) then
- call igraphdsesrt ('LA', rvec , nconv, d, ncv, workl(iq),
- & ldq)
- else
- call dcopy (ncv, workl(bounds), 1, workl(ihb), 1)
- end if
-c
- else
-c
-c %-------------------------------------------------------------%
-c | * Make a copy of all the Ritz values. |
-c | * Transform the Ritz values back to the original system. |
-c | For TYPE = 'SHIFTI' the transformation is |
-c | lambda = 1/theta + sigma |
-c | For TYPE = 'BUCKLE' the transformation is |
-c | lambda = sigma * theta / ( theta - 1 ) |
-c | For TYPE = 'CAYLEY' the transformation is |
-c | lambda = sigma * (theta + 1) / (theta - 1 ) |
-c | where the theta are the Ritz values returned by igraphdsaupd. |
-c | NOTES: |
-c | *The Ritz vectors are not affected by the transformation. |
-c | They are only reordered. |
-c %-------------------------------------------------------------%
-c
- call dcopy (ncv, workl(ihd), 1, workl(iw), 1)
- if (type .eq. 'SHIFTI') then
- do 40 k=1, ncv
- workl(ihd+k-1) = one / workl(ihd+k-1) + sigma
- 40 continue
- else if (type .eq. 'BUCKLE') then
- do 50 k=1, ncv
- workl(ihd+k-1) = sigma * workl(ihd+k-1) /
- & (workl(ihd+k-1) - one)
- 50 continue
- else if (type .eq. 'CAYLEY') then
- do 60 k=1, ncv
- workl(ihd+k-1) = sigma * (workl(ihd+k-1) + one) /
- & (workl(ihd+k-1) - one)
- 60 continue
- end if
-c
-c %-------------------------------------------------------------%
-c | * Store the wanted NCONV lambda values into D. |
-c | * Sort the NCONV wanted lambda in WORKL(IHD:IHD+NCONV-1) |
-c | into ascending order and apply sort to the NCONV theta |
-c | values in the transformed system. We'll need this to |
-c | compute Ritz estimates in the original system. |
-c | * Finally sort the lambda's into ascending order and apply |
-c | to Ritz vectors if wanted. Else just sort lambda's into |
-c | ascending order. |
-c | NOTES: |
-c | *workl(iw:iw+ncv-1) contain the theta ordered so that they |
-c | match the ordering of the lambda. We'll use them again for |
-c | Ritz vector purification. |
-c %-------------------------------------------------------------%
-c
- call dcopy (nconv, workl(ihd), 1, d, 1)
- call igraphdsortr ('LA', .true., nconv, workl(ihd), workl(iw))
- if (rvec) then
- call igraphdsesrt ('LA', rvec , nconv, d, ncv, workl(iq),
- & ldq)
- else
- call dcopy (ncv, workl(bounds), 1, workl(ihb), 1)
- call dscal (ncv, bnorm2/rnorm, workl(ihb), 1)
- call igraphdsortr ('LA', .true., nconv, d, workl(ihb))
- end if
-c
- end if
-c
-c %------------------------------------------------%
-c | Compute the Ritz vectors. Transform the wanted |
-c | eigenvectors of the symmetric tridiagonal H by |
-c | the Lanczos basis matrix V. |
-c %------------------------------------------------%
-c
- if (rvec .and. howmny .eq. 'A') then
-c
-c %----------------------------------------------------------%
-c | Compute the QR factorization of the matrix representing |
-c | the wanted invariant subspace located in the first NCONV |
-c | columns of workl(iq,ldq). |
-c %----------------------------------------------------------%
-c
- call dgeqr2 (ncv, nconv, workl(iq), ldq, workl(iw+ncv),
- & workl(ihb), ierr)
-c
-c
-c %--------------------------------------------------------%
-c | * Postmultiply V by Q. |
-c | * Copy the first NCONV columns of VQ into Z. |
-c | The N by NCONV matrix Z is now a matrix representation |
-c | of the approximate invariant subspace associated with |
-c | the Ritz values in workl(ihd). |
-c %--------------------------------------------------------%
-c
- call dorm2r ('Right', 'Notranspose', n, ncv, nconv, workl(iq),
- & ldq, workl(iw+ncv), v, ldv, workd(n+1), ierr)
- call dlacpy ('All', n, nconv, v, ldv, z, ldz)
-c
-c %-----------------------------------------------------%
-c | In order to compute the Ritz estimates for the Ritz |
-c | values in both systems, need the last row of the |
-c | eigenvector matrix. Remember, it's in factored form |
-c %-----------------------------------------------------%
-c
- do 65 j = 1, ncv-1
- workl(ihb+j-1) = zero
- 65 continue
- workl(ihb+ncv-1) = one
- call dorm2r ('Left', 'Transpose', ncv, 1, nconv, workl(iq),
- & ldq, workl(iw+ncv), workl(ihb), ncv, temp, ierr)
-c
- else if (rvec .and. howmny .eq. 'S') then
-c
-c Not yet implemented. See remark 2 above.
-c
- end if
-c
- if (type .eq. 'REGULR' .and. rvec) then
-c
- do 70 j=1, ncv
- workl(ihb+j-1) = rnorm * abs( workl(ihb+j-1) )
- 70 continue
-c
- else if (type .ne. 'REGULR' .and. rvec) then
-c
-c %-------------------------------------------------%
-c | * Determine Ritz estimates of the theta. |
-c | If RVEC = .true. then compute Ritz estimates |
-c | of the theta. |
-c | If RVEC = .false. then copy Ritz estimates |
-c | as computed by igraphdsaupd. |
-c | * Determine Ritz estimates of the lambda. |
-c %-------------------------------------------------%
-c
- call dscal (ncv, bnorm2, workl(ihb), 1)
- if (type .eq. 'SHIFTI') then
-c
- do 80 k=1, ncv
- workl(ihb+k-1) = abs( workl(ihb+k-1) ) / workl(iw+k-1)**2
- 80 continue
-c
- else if (type .eq. 'BUCKLE') then
-c
- do 90 k=1, ncv
- workl(ihb+k-1) = sigma * abs( workl(ihb+k-1) ) /
- & ( workl(iw+k-1)-one )**2
- 90 continue
-c
- else if (type .eq. 'CAYLEY') then
-c
- do 100 k=1, ncv
- workl(ihb+k-1) = abs( workl(ihb+k-1) /
- & workl(iw+k-1)*(workl(iw+k-1)-one) )
- 100 continue
-c
- end if
-c
- end if
-c
- if (type .ne. 'REGULR' .and. msglvl .gt. 1) then
- call igraphdvout (logfil, nconv, d, ndigit,
- & '_seupd: Untransformed converged Ritz values')
- call igraphdvout (logfil, nconv, workl(ihb), ndigit,
- & '_seupd: Ritz estimates of the untransformed Ritz values')
- else if (msglvl .gt. 1) then
- call igraphdvout (logfil, nconv, d, ndigit,
- & '_seupd: Converged Ritz values')
- call igraphdvout (logfil, nconv, workl(ihb), ndigit,
- & '_seupd: Associated Ritz estimates')
- end if
-c
-c %-------------------------------------------------%
-c | Ritz vector purification step. Formally perform |
-c | one of inverse subspace iteration. Only used |
-c | for MODE = 3,4,5. See reference 7 |
-c %-------------------------------------------------%
-c
- if (rvec .and. (type .eq. 'SHIFTI' .or. type .eq. 'CAYLEY')) then
-c
- do 110 k=0, nconv-1
- workl(iw+k) = workl(iq+k*ldq+ncv-1) / workl(iw+k)
- 110 continue
-c
- else if (rvec .and. type .eq. 'BUCKLE') then
-c
- do 120 k=0, nconv-1
- workl(iw+k) = workl(iq+k*ldq+ncv-1) / (workl(iw+k)-one)
- 120 continue
-c
- end if
-c
- if (type .ne. 'REGULR')
- & call dger (n, nconv, one, resid, 1, workl(iw), 1, z, ldz)
-c
- 9000 continue
-c
- return
-c
-c %---------------%
-c | End of igraphdseupd |
-c %---------------%
-c
- end
diff --git a/src/dsgets.f b/src/dsgets.f
deleted file mode 100644
index 2b0794f..0000000
--- a/src/dsgets.f
+++ /dev/null
@@ -1,220 +0,0 @@
-c-----------------------------------------------------------------------
-c\BeginDoc
-c
-c\Name: igraphdsgets
-c
-c\Description:
-c Given the eigenvalues of the symmetric tridiagonal matrix H,
-c computes the NP shifts AMU that are zeros of the polynomial of
-c degree NP which filters out components of the unwanted eigenvectors
-c corresponding to the AMU's based on some given criteria.
-c
-c NOTE: This is called even in the case of user specified shifts in
-c order to sort the eigenvalues, and error bounds of H for later use.
-c
-c\Usage:
-c call igraphdsgets
-c ( ISHIFT, WHICH, KEV, NP, RITZ, BOUNDS, SHIFTS )
-c
-c\Arguments
-c ISHIFT Integer. (INPUT)
-c Method for selecting the implicit shifts at each iteration.
-c ISHIFT = 0: user specified shifts
-c ISHIFT = 1: exact shift with respect to the matrix H.
-c
-c WHICH Character*2. (INPUT)
-c Shift selection criteria.
-c 'LM' -> KEV eigenvalues of largest magnitude are retained.
-c 'SM' -> KEV eigenvalues of smallest magnitude are retained.
-c 'LA' -> KEV eigenvalues of largest value are retained.
-c 'SA' -> KEV eigenvalues of smallest value are retained.
-c 'BE' -> KEV eigenvalues, half from each end of the spectrum.
-c If KEV is odd, compute one more from the high end.
-c
-c KEV Integer. (INPUT)
-c KEV+NP is the size of the matrix H.
-c
-c NP Integer. (INPUT)
-c Number of implicit shifts to be computed.
-c
-c RITZ Double precision array of length KEV+NP. (INPUT/OUTPUT)
-c On INPUT, RITZ contains the eigenvalues of H.
-c On OUTPUT, RITZ are sorted so that the unwanted eigenvalues
-c are in the first NP locations and the wanted part is in
-c the last KEV locations. When exact shifts are selected, the
-c unwanted part corresponds to the shifts to be applied.
-c
-c BOUNDS Double precision array of length KEV+NP. (INPUT/OUTPUT)
-c Error bounds corresponding to the ordering in RITZ.
-c
-c SHIFTS Double precision array of length NP. (INPUT/OUTPUT)
-c On INPUT: contains the user specified shifts if ISHIFT = 0.
-c On OUTPUT: contains the shifts sorted into decreasing order
-c of magnitude with respect to the Ritz estimates contained in
-c BOUNDS. If ISHIFT = 0, SHIFTS is not modified on exit.
-c
-c\EndDoc
-c
-c-----------------------------------------------------------------------
-c
-c\BeginLib
-c
-c\Local variables:
-c xxxxxx real
-c
-c\Routines called:
-c igraphdsortr ARPACK utility sorting routine.
-c igraphivout ARPACK utility routine that prints integers.
-c igraphsecond ARPACK utility routine for timing.
-c igraphdvout ARPACK utility routine that prints vectors.
-c dcopy Level 1 BLAS that copies one vector to another.
-c dswap Level 1 BLAS that swaps the contents of two vectors.
-c
-c\Author
-c Danny Sorensen Phuong Vu
-c Richard Lehoucq CRPC / Rice University
-c Dept. of Computational & Houston, Texas
-c Applied Mathematics
-c Rice University
-c Houston, Texas
-c
-c\Revision history:
-c xx/xx/93: Version ' 2.1'
-c
-c\SCCS Information: @(#)
-c FILE: sgets.F SID: 2.4 DATE OF SID: 4/19/96 RELEASE: 2
-c
-c\Remarks
-c
-c\EndLib
-c
-c-----------------------------------------------------------------------
-c
- subroutine igraphdsgets ( ishift, which, kev, np, ritz, bounds,
- & shifts )
-c
-c %----------------------------------------------------%
-c | Include files for debugging and timing information |
-c %----------------------------------------------------%
-c
- include 'debug.h'
- include 'stat.h'
-c
-c %------------------%
-c | Scalar Arguments |
-c %------------------%
-c
- character*2 which
- integer ishift, kev, np
-c
-c %-----------------%
-c | Array Arguments |
-c %-----------------%
-c
- Double precision
- & bounds(kev+np), ritz(kev+np), shifts(np)
-c
-c %------------%
-c | Parameters |
-c %------------%
-c
- Double precision
- & one, zero
- parameter (one = 1.0D+0, zero = 0.0D+0)
-c
-c %---------------%
-c | Local Scalars |
-c %---------------%
-c
- integer kevd2, msglvl
-c
-c %----------------------%
-c | External Subroutines |
-c %----------------------%
-c
- external dswap, dcopy, igraphdsortr, igraphsecond
-c
-c %---------------------%
-c | Intrinsic Functions |
-c %---------------------%
-c
- intrinsic max, min
-c
-c %-----------------------%
-c | Executable Statements |
-c %-----------------------%
-c
-c %-------------------------------%
-c | Initialize timing statistics |
-c | & message level for debugging |
-c %-------------------------------%
-c
- call igraphsecond (t0)
- msglvl = msgets
-c
- if (which .eq. 'BE') then
-c
-c %-----------------------------------------------------%
-c | Both ends of the spectrum are requested. |
-c | Sort the eigenvalues into algebraically increasing |
-c | order first then swap high end of the spectrum next |
-c | to low end in appropriate locations. |
-c | NOTE: when np < floor(kev/2) be careful not to swap |
-c | overlapping locations. |
-c %-----------------------------------------------------%
-c
- call igraphdsortr ('LA', .true., kev+np, ritz, bounds)
- kevd2 = kev / 2
- if ( kev .gt. 1 ) then
- call dswap ( min(kevd2,np), ritz, 1,
- & ritz( max(kevd2,np)+1 ), 1)
- call dswap ( min(kevd2,np), bounds, 1,
- & bounds( max(kevd2,np)+1 ), 1)
- end if
-c
- else
-c
-c %----------------------------------------------------%
-c | LM, SM, LA, SA case. |
-c | Sort the eigenvalues of H into the desired order |
-c | and apply the resulting order to BOUNDS. |
-c | The eigenvalues are sorted so that the wanted part |
-c | are always in the last KEV locations. |
-c %----------------------------------------------------%
-c
- call igraphdsortr (which, .true., kev+np, ritz, bounds)
- end if
-c
- if (ishift .eq. 1 .and. np .gt. 0) then
-c
-c %-------------------------------------------------------%
-c | Sort the unwanted Ritz values used as shifts so that |
-c | the ones with largest Ritz estimates are first. |
-c | This will tend to minimize the effects of the |
-c | forward instability of the iteration when the shifts |
-c | are applied in subroutine igraphdsapps. |
-c %-------------------------------------------------------%
-c
- call igraphdsortr ('SM', .true., np, bounds, ritz)
- call dcopy (np, ritz, 1, shifts, 1)
- end if
-c
- call igraphsecond (t1)
- tsgets = tsgets + (t1 - t0)
-c
- if (msglvl .gt. 0) then
- call igraphivout (logfil, 1, kev, ndigit, '_sgets: KEV is')
- call igraphivout (logfil, 1, np, ndigit, '_sgets: NP is')
- call igraphdvout (logfil, kev+np, ritz, ndigit,
- & '_sgets: Eigenvalues of current H matrix')
- call igraphdvout (logfil, kev+np, bounds, ndigit,
- & '_sgets: Associated Ritz estimates')
- end if
-c
- return
-c
-c %---------------%
-c | End of igraphdsgets |
-c %---------------%
-c
- end
diff --git a/src/dsortc.f b/src/dsortc.f
deleted file mode 100644
index a356adc..0000000
--- a/src/dsortc.f
+++ /dev/null
@@ -1,344 +0,0 @@
-c-----------------------------------------------------------------------
-c\BeginDoc
-c
-c\Name: igraphdsortc
-c
-c\Description:
-c Sorts the complex array in XREAL and XIMAG into the order
-c specified by WHICH and optionally applies the permutation to the
-c real array Y. It is assumed that if an element of XIMAG is
-c nonzero, then its negative is also an element. In other words,
-c both members of a complex conjugate pair are to be sorted and the
-c pairs are kept adjacent to each other.
-c
-c\Usage:
-c call igraphdsortc
-c ( WHICH, APPLY, N, XREAL, XIMAG, Y )
-c
-c\Arguments
-c WHICH Character*2. (Input)
-c 'LM' -> sort XREAL,XIMAG into increasing order of magnitude.
-c 'SM' -> sort XREAL,XIMAG into decreasing order of magnitude.
-c 'LR' -> sort XREAL into increasing order of algebraic.
-c 'SR' -> sort XREAL into decreasing order of algebraic.
-c 'LI' -> sort XIMAG into increasing order of magnitude.
-c 'SI' -> sort XIMAG into decreasing order of magnitude.
-c NOTE: If an element of XIMAG is non-zero, then its negative
-c is also an element.
-c
-c APPLY Logical. (Input)
-c APPLY = .TRUE. -> apply the sorted order to array Y.
-c APPLY = .FALSE. -> do not apply the sorted order to array Y.
-c
-c N Integer. (INPUT)
-c Size of the arrays.
-c
-c XREAL, Double precision array of length N. (INPUT/OUTPUT)
-c XIMAG Real and imaginary part of the array to be sorted.
-c
-c Y Double precision array of length N. (INPUT/OUTPUT)
-c
-c\EndDoc
-c
-c-----------------------------------------------------------------------
-c
-c\BeginLib
-c
-c\Author
-c Danny Sorensen Phuong Vu
-c Richard Lehoucq CRPC / Rice University
-c Dept. of Computational & Houston, Texas
-c Applied Mathematics
-c Rice University
-c Houston, Texas
-c
-c\Revision history:
-c xx/xx/92: Version ' 2.1'
-c Adapted from the sort routine in LANSO.
-c
-c\SCCS Information: @(#)
-c FILE: sortc.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2
-c
-c\EndLib
-c
-c-----------------------------------------------------------------------
-c
- subroutine igraphdsortc (which, apply, n, xreal, ximag, y)
-c
-c %------------------%
-c | Scalar Arguments |
-c %------------------%
-c
- character*2 which
- logical apply
- integer n
-c
-c %-----------------%
-c | Array Arguments |
-c %-----------------%
-c
- Double precision
- & xreal(0:n-1), ximag(0:n-1), y(0:n-1)
-c
-c %---------------%
-c | Local Scalars |
-c %---------------%
-c
- integer i, igap, j
- Double precision
- & temp, temp1, temp2
-c
-c %--------------------%
-c | External Functions |
-c %--------------------%
-c
- Double precision
- & dlapy2
- external dlapy2
-c
-c %-----------------------%
-c | Executable Statements |
-c %-----------------------%
-c
- igap = n / 2
-c
- if (which .eq. 'LM') then
-c
-c %------------------------------------------------------%
-c | Sort XREAL,XIMAG into increasing order of magnitude. |
-c %------------------------------------------------------%
-c
- 10 continue
- if (igap .eq. 0) go to 9000
-c
- do 30 i = igap, n-1
- j = i-igap
- 20 continue
-c
- if (j.lt.0) go to 30
-c
- temp1 = dlapy2(xreal(j),ximag(j))
- temp2 = dlapy2(xreal(j+igap),ximag(j+igap))
-c
- if (temp1.gt.temp2) then
- temp = xreal(j)
- xreal(j) = xreal(j+igap)
- xreal(j+igap) = temp
-c
- temp = ximag(j)
- ximag(j) = ximag(j+igap)
- ximag(j+igap) = temp
-c
- if (apply) then
- temp = y(j)
- y(j) = y(j+igap)
- y(j+igap) = temp
- end if
- else
- go to 30
- end if
- j = j-igap
- go to 20
- 30 continue
- igap = igap / 2
- go to 10
-c
- else if (which .eq. 'SM') then
-c
-c %------------------------------------------------------%
-c | Sort XREAL,XIMAG into decreasing order of magnitude. |
-c %------------------------------------------------------%
-c
- 40 continue
- if (igap .eq. 0) go to 9000
-c
- do 60 i = igap, n-1
- j = i-igap
- 50 continue
-c
- if (j .lt. 0) go to 60
-c
- temp1 = dlapy2(xreal(j),ximag(j))
- temp2 = dlapy2(xreal(j+igap),ximag(j+igap))
-c
- if (temp1.lt.temp2) then
- temp = xreal(j)
- xreal(j) = xreal(j+igap)
- xreal(j+igap) = temp
-c
- temp = ximag(j)
- ximag(j) = ximag(j+igap)
- ximag(j+igap) = temp
-c
- if (apply) then
- temp = y(j)
- y(j) = y(j+igap)
- y(j+igap) = temp
- end if
- else
- go to 60
- endif
- j = j-igap
- go to 50
- 60 continue
- igap = igap / 2
- go to 40
-c
- else if (which .eq. 'LR') then
-c
-c %------------------------------------------------%
-c | Sort XREAL into increasing order of algebraic. |
-c %------------------------------------------------%
-c
- 70 continue
- if (igap .eq. 0) go to 9000
-c
- do 90 i = igap, n-1
- j = i-igap
- 80 continue
-c
- if (j.lt.0) go to 90
-c
- if (xreal(j).gt.xreal(j+igap)) then
- temp = xreal(j)
- xreal(j) = xreal(j+igap)
- xreal(j+igap) = temp
-c
- temp = ximag(j)
- ximag(j) = ximag(j+igap)
- ximag(j+igap) = temp
-c
- if (apply) then
- temp = y(j)
- y(j) = y(j+igap)
- y(j+igap) = temp
- end if
- else
- go to 90
- endif
- j = j-igap
- go to 80
- 90 continue
- igap = igap / 2
- go to 70
-c
- else if (which .eq. 'SR') then
-c
-c %------------------------------------------------%
-c | Sort XREAL into decreasing order of algebraic. |
-c %------------------------------------------------%
-c
- 100 continue
- if (igap .eq. 0) go to 9000
- do 120 i = igap, n-1
- j = i-igap
- 110 continue
-c
- if (j.lt.0) go to 120
-c
- if (xreal(j).lt.xreal(j+igap)) then
- temp = xreal(j)
- xreal(j) = xreal(j+igap)
- xreal(j+igap) = temp
-c
- temp = ximag(j)
- ximag(j) = ximag(j+igap)
- ximag(j+igap) = temp
-c
- if (apply) then
- temp = y(j)
- y(j) = y(j+igap)
- y(j+igap) = temp
- end if
- else
- go to 120
- endif
- j = j-igap
- go to 110
- 120 continue
- igap = igap / 2
- go to 100
-c
- else if (which .eq. 'LI') then
-c
-c %------------------------------------------------%
-c | Sort XIMAG into increasing order of magnitude. |
-c %------------------------------------------------%
-c
- 130 continue
- if (igap .eq. 0) go to 9000
- do 150 i = igap, n-1
- j = i-igap
- 140 continue
-c
- if (j.lt.0) go to 150
-c
- if (abs(ximag(j)).gt.abs(ximag(j+igap))) then
- temp = xreal(j)
- xreal(j) = xreal(j+igap)
- xreal(j+igap) = temp
-c
- temp = ximag(j)
- ximag(j) = ximag(j+igap)
- ximag(j+igap) = temp
-c
- if (apply) then
- temp = y(j)
- y(j) = y(j+igap)
- y(j+igap) = temp
- end if
- else
- go to 150
- endif
- j = j-igap
- go to 140
- 150 continue
- igap = igap / 2
- go to 130
-c
- else if (which .eq. 'SI') then
-c
-c %------------------------------------------------%
-c | Sort XIMAG into decreasing order of magnitude. |
-c %------------------------------------------------%
-c
- 160 continue
- if (igap .eq. 0) go to 9000
- do 180 i = igap, n-1
- j = i-igap
- 170 continue
-c
- if (j.lt.0) go to 180
-c
- if (abs(ximag(j)).lt.abs(ximag(j+igap))) then
- temp = xreal(j)
- xreal(j) = xreal(j+igap)
- xreal(j+igap) = temp
-c
- temp = ximag(j)
- ximag(j) = ximag(j+igap)
- ximag(j+igap) = temp
-c
- if (apply) then
- temp = y(j)
- y(j) = y(j+igap)
- y(j+igap) = temp
- end if
- else
- go to 180
- endif
- j = j-igap
- go to 170
- 180 continue
- igap = igap / 2
- go to 160
- end if
-c
- 9000 continue
- return
-c
-c %---------------%
-c | End of igraphdsortc |
-c %---------------%
-c
- end
diff --git a/src/dsortr.f b/src/dsortr.f
deleted file mode 100644
index d75bd61..0000000
--- a/src/dsortr.f
+++ /dev/null
@@ -1,218 +0,0 @@
-c-----------------------------------------------------------------------
-c\BeginDoc
-c
-c\Name: igraphdsortr
-c
-c\Description:
-c Sort the array X1 in the order specified by WHICH and optionally
-c applies the permutation to the array X2.
-c
-c\Usage:
-c call igraphdsortr
-c ( WHICH, APPLY, N, X1, X2 )
-c
-c\Arguments
-c WHICH Character*2. (Input)
-c 'LM' -> X1 is sorted into increasing order of magnitude.
-c 'SM' -> X1 is sorted into decreasing order of magnitude.
-c 'LA' -> X1 is sorted into increasing order of algebraic.
-c 'SA' -> X1 is sorted into decreasing order of algebraic.
-c
-c APPLY Logical. (Input)
-c APPLY = .TRUE. -> apply the sorted order to X2.
-c APPLY = .FALSE. -> do not apply the sorted order to X2.
-c
-c N Integer. (INPUT)
-c Size of the arrays.
-c
-c X1 Double precision array of length N. (INPUT/OUTPUT)
-c The array to be sorted.
-c
-c X2 Double precision array of length N. (INPUT/OUTPUT)
-c Only referenced if APPLY = .TRUE.
-c
-c\EndDoc
-c
-c-----------------------------------------------------------------------
-c
-c\BeginLib
-c
-c\Author
-c Danny Sorensen Phuong Vu
-c Richard Lehoucq CRPC / Rice University
-c Dept. of Computational & Houston, Texas
-c Applied Mathematics
-c Rice University
-c Houston, Texas
-c
-c\Revision history:
-c 12/16/93: Version ' 2.1'.
-c Adapted from the sort routine in LANSO.
-c
-c\SCCS Information: @(#)
-c FILE: sortr.F SID: 2.3 DATE OF SID: 4/19/96 RELEASE: 2
-c
-c\EndLib
-c
-c-----------------------------------------------------------------------
-c
- subroutine igraphdsortr (which, apply, n, x1, x2)
-c
-c %------------------%
-c | Scalar Arguments |
-c %------------------%
-c
- character*2 which
- logical apply
- integer n
-c
-c %-----------------%
-c | Array Arguments |
-c %-----------------%
-c
- Double precision
- & x1(0:n-1), x2(0:n-1)
-c
-c %---------------%
-c | Local Scalars |
-c %---------------%
-c
- integer i, igap, j
- Double precision
- & temp
-c
-c %-----------------------%
-c | Executable Statements |
-c %-----------------------%
-c
- igap = n / 2
-c
- if (which .eq. 'SA') then
-c
-c X1 is sorted into decreasing order of algebraic.
-c
- 10 continue
- if (igap .eq. 0) go to 9000
- do 30 i = igap, n-1
- j = i-igap
- 20 continue
-c
- if (j.lt.0) go to 30
-c
- if (x1(j).lt.x1(j+igap)) then
- temp = x1(j)
- x1(j) = x1(j+igap)
- x1(j+igap) = temp
- if (apply) then
- temp = x2(j)
- x2(j) = x2(j+igap)
- x2(j+igap) = temp
- end if
- else
- go to 30
- endif
- j = j-igap
- go to 20
- 30 continue
- igap = igap / 2
- go to 10
-c
- else if (which .eq. 'SM') then
-c
-c X1 is sorted into decreasing order of magnitude.
-c
- 40 continue
- if (igap .eq. 0) go to 9000
- do 60 i = igap, n-1
- j = i-igap
- 50 continue
-c
- if (j.lt.0) go to 60
-c
- if (abs(x1(j)).lt.abs(x1(j+igap))) then
- temp = x1(j)
- x1(j) = x1(j+igap)
- x1(j+igap) = temp
- if (apply) then
- temp = x2(j)
- x2(j) = x2(j+igap)
- x2(j+igap) = temp
- end if
- else
- go to 60
- endif
- j = j-igap
- go to 50
- 60 continue
- igap = igap / 2
- go to 40
-c
- else if (which .eq. 'LA') then
-c
-c X1 is sorted into increasing order of algebraic.
-c
- 70 continue
- if (igap .eq. 0) go to 9000
- do 90 i = igap, n-1
- j = i-igap
- 80 continue
-c
- if (j.lt.0) go to 90
-c
- if (x1(j).gt.x1(j+igap)) then
- temp = x1(j)
- x1(j) = x1(j+igap)
- x1(j+igap) = temp
- if (apply) then
- temp = x2(j)
- x2(j) = x2(j+igap)
- x2(j+igap) = temp
- end if
- else
- go to 90
- endif
- j = j-igap
- go to 80
- 90 continue
- igap = igap / 2
- go to 70
-c
- else if (which .eq. 'LM') then
-c
-c X1 is sorted into increasing order of magnitude.
-c
- 100 continue
- if (igap .eq. 0) go to 9000
- do 120 i = igap, n-1
- j = i-igap
- 110 continue
-c
- if (j.lt.0) go to 120
-c
- if (abs(x1(j)).gt.abs(x1(j+igap))) then
- temp = x1(j)
- x1(j) = x1(j+igap)
- x1(j+igap) = temp
- if (apply) then
- temp = x2(j)
- x2(j) = x2(j+igap)
- x2(j+igap) = temp
- end if
- else
- go to 120
- endif
- j = j-igap
- go to 110
- 120 continue
- igap = igap / 2
- go to 100
- end if
-c
- 9000 continue
- return
-c
-c %---------------%
-c | End of igraphdsortr |
-c %---------------%
-c
- end
diff --git a/src/dstatn.f b/src/dstatn.f
deleted file mode 100644
index afd0a57..0000000
--- a/src/dstatn.f
+++ /dev/null
@@ -1,61 +0,0 @@
-c
-c %---------------------------------------------%
-c | Initialize statistic and timing information |
-c | for nonsymmetric Arnoldi code. |
-c %---------------------------------------------%
-c
-c\Author
-c Danny Sorensen Phuong Vu
-c Richard Lehoucq CRPC / Rice University
-c Dept. of Computational & Houston, Texas
-c Applied Mathematics
-c Rice University
-c Houston, Texas
-c
-c\SCCS Information: @(#)
-c FILE: statn.F SID: 2.4 DATE OF SID: 4/20/96 RELEASE: 2
-c
- subroutine igraphdstatn
-c
-c %--------------------------------%
-c | See stat.doc for documentation |
-c %--------------------------------%
-c
- include 'stat.h'
-c
-c %-----------------------%
-c | Executable Statements |
-c %-----------------------%
-c
- nopx = 0
- nbx = 0
- nrorth = 0
- nitref = 0
- nrstrt = 0
-c
- tnaupd = 0.0D+0
- tnaup2 = 0.0D+0
- tnaitr = 0.0D+0
- tneigh = 0.0D+0
- tngets = 0.0D+0
- tnapps = 0.0D+0
- tnconv = 0.0D+0
- titref = 0.0D+0
- tgetv0 = 0.0D+0
- trvec = 0.0D+0
-c
-c %----------------------------------------------------%
-c | User time including reverse communication overhead |
-c %----------------------------------------------------%
-c
- tmvopx = 0.0D+0
- tmvbx = 0.0D+0
-c
- return
-c
-c
-c %---------------%
-c | End of igraphdstatn |
-c %---------------%
-c
- end
diff --git a/src/dstats.f b/src/dstats.f
deleted file mode 100644
index 545ed19..0000000
--- a/src/dstats.f
+++ /dev/null
@@ -1,47 +0,0 @@
-c
-c\SCCS Information: @(#)
-c FILE: stats.F SID: 2.1 DATE OF SID: 4/19/96 RELEASE: 2
-c %---------------------------------------------%
-c | Initialize statistic and timing information |
-c | for symmetric Arnoldi code. |
-c %---------------------------------------------%
-
- subroutine igraphdstats
-
-c %--------------------------------%
-c | See stat.doc for documentation |
-c %--------------------------------%
- include 'stat.h'
-
-c %-----------------------%
-c | Executable Statements |
-c %-----------------------%
-
- nopx = 0
- nbx = 0
- nrorth = 0
- nitref = 0
- nrstrt = 0
-
- tsaupd = 0.0D+0
- tsaup2 = 0.0D+0
- tsaitr = 0.0D+0
- tseigt = 0.0D+0
- tsgets = 0.0D+0
- tsapps = 0.0D+0
- tsconv = 0.0D+0
- titref = 0.0D+0
- tgetv0 = 0.0D+0
- trvec = 0.0D+0
-
-c %----------------------------------------------------%
-c | User time including reverse communication overhead |
-c %----------------------------------------------------%
- tmvopx = 0.0D+0
- tmvbx = 0.0D+0
-
- return
-c
-c End of igraphdstats
-c
- end
diff --git a/src/dstqrb.f b/src/dstqrb.f
deleted file mode 100644
index eff1369..0000000
--- a/src/dstqrb.f
+++ /dev/null
@@ -1,594 +0,0 @@
-c-----------------------------------------------------------------------
-c\BeginDoc
-c
-c\Name: igraphdstqrb
-c
-c\Description:
-c Computes all eigenvalues and the last component of the eigenvectors
-c of a symmetric tridiagonal matrix using the implicit QL or QR method.
-c
-c This is mostly a modification of the LAPACK routine dsteqr.
-c See Remarks.
-c
-c\Usage:
-c call igraphdstqrb
-c ( N, D, E, Z, WORK, INFO )
-c
-c\Arguments
-c N Integer. (INPUT)
-c The number of rows and columns in the matrix. N >= 0.
-c
-c D Double precision array, dimension (N). (INPUT/OUTPUT)
-c On entry, D contains the diagonal elements of the
-c tridiagonal matrix.
-c On exit, D contains the eigenvalues, in ascending order.
-c If an error exit is made, the eigenvalues are correct
-c for indices 1,2,...,INFO-1, but they are unordered and
-c may not be the smallest eigenvalues of the matrix.
-c
-c E Double precision array, dimension (N-1). (INPUT/OUTPUT)
-c On entry, E contains the subdiagonal elements of the
-c tridiagonal matrix in positions 1 through N-1.
-c On exit, E has been destroyed.
-c
-c Z Double precision array, dimension (N). (OUTPUT)
-c On exit, Z contains the last row of the orthonormal
-c eigenvector matrix of the symmetric tridiagonal matrix.
-c If an error exit is made, Z contains the last row of the
-c eigenvector matrix associated with the stored eigenvalues.
-c
-c WORK Double precision array, dimension (max(1,2*N-2)). (WORKSPACE)
-c Workspace used in accumulating the transformation for
-c computing the last components of the eigenvectors.
-c
-c INFO Integer. (OUTPUT)
-c = 0: normal return.
-c < 0: if INFO = -i, the i-th argument had an illegal value.
-c > 0: if INFO = +i, the i-th eigenvalue has not converged
-c after a total of 30*N iterations.
-c
-c\Remarks
-c 1. None.
-c
-c-----------------------------------------------------------------------
-c
-c\BeginLib
-c
-c\Local variables:
-c xxxxxx real
-c
-c\Routines called:
-c daxpy Level 1 BLAS that computes a vector triad.
-c dcopy Level 1 BLAS that copies one vector to another.
-c dswap Level 1 BLAS that swaps the contents of two vectors.
-c lsame LAPACK character comparison routine.
-c dlae2 LAPACK routine that computes the eigenvalues of a 2-by-2
-c symmetric matrix.
-c dlaev2 LAPACK routine that eigendecomposition of a 2-by-2 symmetric
-c matrix.
-c dlamch LAPACK routine that determines machine constants.
-c dlanst LAPACK routine that computes the norm of a matrix.
-c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully.
-c dlartg LAPACK Givens rotation construction routine.
-c dlascl LAPACK routine for careful scaling of a matrix.
-c dlaset LAPACK matrix initialization routine.
-c dlasr LAPACK routine that applies an orthogonal transformation to
-c a matrix.
-c dlasrt LAPACK sorting routine.
-c dsteqr LAPACK routine that computes eigenvalues and eigenvectors
-c of a symmetric tridiagonal matrix.
-c xerbla LAPACK error handler routine.
-c
-c\Authors
-c Danny Sorensen Phuong Vu
-c Richard Lehoucq CRPC / Rice University
-c Dept. of Computational & Houston, Texas
-c Applied Mathematics
-c Rice University
-c Houston, Texas
-c
-c\SCCS Information: @(#)
-c FILE: stqrb.F SID: 2.5 DATE OF SID: 8/27/96 RELEASE: 2
-c
-c\Remarks
-c 1. Starting with version 2.5, this routine is a modified version
-c of LAPACK version 2.0 subroutine SSTEQR. No lines are deleted,
-c only commeted out and new lines inserted.
-c All lines commented out have "c$$$" at the beginning.
-c Note that the LAPACK version 1.0 subroutine SSTEQR contained
-c bugs.
-c
-c\EndLib
-c
-c-----------------------------------------------------------------------
-c
- subroutine igraphdstqrb ( n, d, e, z, work, info )
-c
-c %------------------%
-c | Scalar Arguments |
-c %------------------%
-c
- integer info, n
-c
-c %-----------------%
-c | Array Arguments |
-c %-----------------%
-c
- Double precision
- & d( n ), e( n-1 ), z( n ), work( 2*n-2 )
-c
-c .. parameters ..
- Double precision
- & zero, one, two, three
- parameter ( zero = 0.0D+0, one = 1.0D+0,
- & two = 2.0D+0, three = 3.0D+0 )
- integer maxit
- parameter ( maxit = 30 )
-c ..
-c .. 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
-c ..
-c .. external functions ..
- logical lsame
- Double precision
- & dlamch, dlanst, dlapy2
- external lsame, dlamch, dlanst, dlapy2
-c ..
-c .. external subroutines ..
- external dlae2, dlaev2, dlartg, dlascl, dlaset, dlasr,
- & dlasrt, dswap, xerbla
-c ..
-c .. intrinsic functions ..
- intrinsic abs, max, sign, sqrt
-c ..
-c .. executable statements ..
-c
-c test the input parameters.
-c
- info = 0
-c
-c$$$ IF( LSAME( COMPZ, 'N' ) ) THEN
-c$$$ ICOMPZ = 0
-c$$$ ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
-c$$$ ICOMPZ = 1
-c$$$ ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
-c$$$ ICOMPZ = 2
-c$$$ ELSE
-c$$$ ICOMPZ = -1
-c$$$ END IF
-c$$$ IF( ICOMPZ.LT.0 ) THEN
-c$$$ INFO = -1
-c$$$ ELSE IF( N.LT.0 ) THEN
-c$$$ INFO = -2
-c$$$ ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
-c$$$ $ N ) ) ) THEN
-c$$$ INFO = -6
-c$$$ END IF
-c$$$ IF( INFO.NE.0 ) THEN
-c$$$ CALL XERBLA( 'SSTEQR', -INFO )
-c$$$ RETURN
-c$$$ END IF
-c
-c *** New starting with version 2.5 ***
-c
- icompz = 2
-c *************************************
-c
-c quick return if possible
-c
- if( n.eq.0 )
- $ return
-c
- if( n.eq.1 ) then
- if( icompz.eq.2 ) z( 1 ) = one
- return
- end if
-c
-c determine the unit roundoff and over/underflow thresholds.
-c
- eps = dlamch( 'e' )
- eps2 = eps**2
- safmin = dlamch( 's' )
- safmax = one / safmin
- ssfmax = sqrt( safmax ) / three
- ssfmin = sqrt( safmin ) / eps2
-c
-c compute the eigenvalues and eigenvectors of the tridiagonal
-c matrix.
-c
-c$$ if( icompz.eq.2 )
-c$$$ $ call dlaset( 'full', n, n, zero, one, z, ldz )
-c
-c *** New starting with version 2.5 ***
-c
- if ( icompz .eq. 2 ) then
- do 5 j = 1, n-1
- z(j) = zero
- 5 continue
- z( n ) = one
- end if
-c *************************************
-c
- nmaxit = n*maxit
- jtot = 0
-c
-c determine where the matrix splits and choose ql or qr iteration
-c for each block, according to whether top or bottom diagonal
-c element is smaller.
-c
- l1 = 1
- nm1 = n - 1
-c
- 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
-c
- 30 continue
- l = l1
- lsv = l
- lend = m
- lendsv = lend
- l1 = m + 1
- if( lend.eq.l )
- $ go to 10
-c
-c scale submatrix in rows and columns l to lend
-c
- 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
-c
-c choose between ql and qr iteration
-c
- if( abs( d( lend ) ).lt.abs( d( l ) ) ) then
- lend = lsv
- l = lendsv
- end if
-c
- if( lend.gt.l ) then
-c
-c ql iteration
-c
-c look for small subdiagonal element.
-c
- 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
-c
- m = lend
-c
- 60 continue
- if( m.lt.lend )
- $ e( m ) = zero
- p = d( l )
- if( m.eq.l )
- $ go to 80
-c
-c if remaining matrix is 2-by-2, use dlae2 or dlaev2
-c to compute its eigensystem.
-c
- 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
-c$$$ call dlasr( 'r', 'v', 'b', n, 2, work( l ),
-c$$$ $ work( n-1+l ), z( 1, l ), ldz )
-c
-c *** New starting with version 2.5 ***
-c
- tst = z(l+1)
- z(l+1) = c*tst - s*z(l)
- z(l) = s*tst + c*z(l)
-c *************************************
- 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
-c
- if( jtot.eq.nmaxit )
- $ go to 140
- jtot = jtot + 1
-c
-c form shift.
-c
- g = ( d( l+1 )-p ) / ( two*e( l ) )
- r = dlapy2( g, one )
- g = d( m ) - p + ( e( l ) / ( g+sign( r, g ) ) )
-c
- s = one
- c = one
- p = zero
-c
-c inner loop
-c
- 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
-c
-c if eigenvectors are desired, then save rotations.
-c
- if( icompz.gt.0 ) then
- work( i ) = c
- work( n-1+i ) = -s
- end if
-c
- 70 continue
-c
-c if eigenvectors are desired, then apply saved rotations.
-c
- if( icompz.gt.0 ) then
- mm = m - l + 1
-c$$$ call dlasr( 'r', 'v', 'b', n, mm, work( l ), work( n-1+l ),
-c$$$ $ z( 1, l ), ldz )
-c
-c *** New starting with version 2.5 ***
-c
- call dlasr( 'r', 'v', 'b', 1, mm, work( l ),
- & work( n-1+l ), z( l ), 1 )
-c *************************************
- end if
-c
- d( l ) = d( l ) - p
- e( l ) = g
- go to 40
-c
-c eigenvalue found.
-c
- 80 continue
- d( l ) = p
-c
- l = l + 1
- if( l.le.lend )
- $ go to 40
- go to 140
-c
- else
-c
-c qr iteration
-c
-c look for small superdiagonal element.
-c
- 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
-c
- m = lend
-c
- 110 continue
- if( m.gt.lend )
- $ e( m-1 ) = zero
- p = d( l )
- if( m.eq.l )
- $ go to 130
-c
-c if remaining matrix is 2-by-2, use dlae2 or dlaev2
-c to compute its eigensystem.
-c
- 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 )
-c$$$ work( m ) = c
-c$$$ work( n-1+m ) = s
-c$$$ call dlasr( 'r', 'v', 'f', n, 2, work( m ),
-c$$$ $ work( n-1+m ), z( 1, l-1 ), ldz )
-c
-c *** New starting with version 2.5 ***
-c
- tst = z(l)
- z(l) = c*tst - s*z(l-1)
- z(l-1) = s*tst + c*z(l-1)
-c *************************************
- 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
-c
- if( jtot.eq.nmaxit )
- $ go to 140
- jtot = jtot + 1
-c
-c form shift.
-c
- g = ( d( l-1 )-p ) / ( two*e( l-1 ) )
- r = dlapy2( g, one )
- g = d( m ) - p + ( e( l-1 ) / ( g+sign( r, g ) ) )
-c
- s = one
- c = one
- p = zero
-c
-c inner loop
-c
- 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
-c
-c if eigenvectors are desired, then save rotations.
-c
- if( icompz.gt.0 ) then
- work( i ) = c
- work( n-1+i ) = s
- end if
-c
- 120 continue
-c
-c if eigenvectors are desired, then apply saved rotations.
-c
- if( icompz.gt.0 ) then
- mm = l - m + 1
-c$$$ call dlasr( 'r', 'v', 'f', n, mm, work( m ), work( n-1+m ),
-c$$$ $ z( 1, m ), ldz )
-c
-c *** New starting with version 2.5 ***
-c
- call dlasr( 'r', 'v', 'f', 1, mm, work( m ), work( n-1+m ),
- & z( m ), 1 )
-c *************************************
- end if
-c
- d( l ) = d( l ) - p
- e( lm1 ) = g
- go to 90
-c
-c eigenvalue found.
-c
- 130 continue
- d( l ) = p
-c
- l = l - 1
- if( l.ge.lend )
- $ go to 90
- go to 140
-c
- end if
-c
-c undo scaling if necessary
-c
- 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
-c
-c check for no convergence to an eigenvalue after a total
-c of n*maxit iterations.
-c
- 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
-c
-c order eigenvalues and eigenvectors.
-c
- 160 continue
- if( icompz.eq.0 ) then
-c
-c use quick sort
-c
- call dlasrt( 'i', n, d, info )
-c
- else
-c
-c use selection sort to minimize swaps of eigenvectors
-c
- 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
-c$$$ call dswap( n, z( 1, i ), 1, z( 1, k ), 1 )
-c *** New starting with version 2.5 ***
-c
- p = z(k)
- z(k) = z(i)
- z(i) = p
-c *************************************
- end if
- 180 continue
- end if
-c
- 190 continue
- return
-c
-c %---------------%
-c | End of igraphdstqrb |
-c %---------------%
-c
- end
diff --git a/src/dvout.f b/src/dvout.f
deleted file mode 100644
index 8bd7b1b..0000000
--- a/src/dvout.f
+++ /dev/null
@@ -1,122 +0,0 @@
-*-----------------------------------------------------------------------
-* Routine: DVOUT
-*
-* Purpose: Real vector output routine.
-*
-* Usage: CALL DVOUT (LOUT, N, SX, IDIGIT, IFMT)
-*
-* Arguments
-* N - Length of array SX. (Input)
-* SX - Real array to be printed. (Input)
-* IFMT - Format to be used in printing array SX. (Input)
-* IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In)
-* If IDIGIT .LT. 0, printing is done with 72 columns.
-* If IDIGIT .GT. 0, printing is done with 132 columns.
-*
-*-----------------------------------------------------------------------
-*
- SUBROUTINE IGRAPHDVOUT( LOUT, N, SX, IDIGIT, IFMT )
-* ...
-* ... SPECIFICATIONS FOR ARGUMENTS
-* ...
-* ... SPECIFICATIONS FOR LOCAL VARIABLES
-* .. Scalar Arguments ..
- CHARACTER*( * ) IFMT
- INTEGER IDIGIT, LOUT, N
-* ..
-* .. Array Arguments ..
- DOUBLE PRECISION SX( * )
-* ..
-* .. Local Scalars ..
- CHARACTER*80 LINE
- INTEGER I, K1, K2, LLL, NDIGIT
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC LEN, MIN, MIN0
-* ..
-* .. Executable Statements ..
-* ...
-* ... FIRST EXECUTABLE STATEMENT
-*
-*
-c$$$ LLL = MIN( LEN( IFMT ), 80 )
-c$$$ DO 10 I = 1, LLL
-c$$$ LINE( I: I ) = '-'
-c$$$ 10 CONTINUE
-c$$$*
-c$$$ DO 20 I = LLL + 1, 80
-c$$$ LINE( I: I ) = ' '
-c$$$ 20 CONTINUE
-c$$$*
-c$$$ WRITE( LOUT, FMT = 9999 )IFMT, LINE( 1: LLL )
-c$$$ 9999 FORMAT( / 1X, A, / 1X, A )
-c$$$*
-c$$$ IF( N.LE.0 )
-c$$$ $ RETURN
-c$$$ NDIGIT = IDIGIT
-c$$$ IF( IDIGIT.EQ.0 )
-c$$$ $ NDIGIT = 4
-c$$$*
-c$$$*=======================================================================
-c$$$* CODE FOR OUTPUT USING 72 COLUMNS FORMAT
-c$$$*=======================================================================
-c$$$*
-c$$$ IF( IDIGIT.LT.0 ) THEN
-c$$$ NDIGIT = -IDIGIT
-c$$$ IF( NDIGIT.LE.4 ) THEN
-c$$$ DO 30 K1 = 1, N, 5
-c$$$ K2 = MIN0( N, K1+4 )
-c$$$ WRITE( LOUT, FMT = 9998 )K1, K2, ( SX( I ), I = K1, K2 )
-c$$$ 30 CONTINUE
-c$$$ ELSE IF( NDIGIT.LE.6 ) THEN
-c$$$ DO 40 K1 = 1, N, 4
-c$$$ K2 = MIN0( N, K1+3 )
-c$$$ WRITE( LOUT, FMT = 9997 )K1, K2, ( SX( I ), I = K1, K2 )
-c$$$ 40 CONTINUE
-c$$$ ELSE IF( NDIGIT.LE.10 ) THEN
-c$$$ DO 50 K1 = 1, N, 3
-c$$$ K2 = MIN0( N, K1+2 )
-c$$$ WRITE( LOUT, FMT = 9996 )K1, K2, ( SX( I ), I = K1, K2 )
-c$$$ 50 CONTINUE
-c$$$ ELSE
-c$$$ DO 60 K1 = 1, N, 2
-c$$$ K2 = MIN0( N, K1+1 )
-c$$$ WRITE( LOUT, FMT = 9995 )K1, K2, ( SX( I ), I = K1, K2 )
-c$$$ 60 CONTINUE
-c$$$ END IF
-c$$$*
-c$$$*=======================================================================
-c$$$* CODE FOR OUTPUT USING 132 COLUMNS FORMAT
-c$$$*=======================================================================
-c$$$*
-c$$$ ELSE
-c$$$ IF( NDIGIT.LE.4 ) THEN
-c$$$ DO 70 K1 = 1, N, 10
-c$$$ K2 = MIN0( N, K1+9 )
-c$$$ WRITE( LOUT, FMT = 9998 )K1, K2, ( SX( I ), I = K1, K2 )
-c$$$ 70 CONTINUE
-c$$$ ELSE IF( NDIGIT.LE.6 ) THEN
-c$$$ DO 80 K1 = 1, N, 8
-c$$$ K2 = MIN0( N, K1+7 )
-c$$$ WRITE( LOUT, FMT = 9997 )K1, K2, ( SX( I ), I = K1, K2 )
-c$$$ 80 CONTINUE
-c$$$ ELSE IF( NDIGIT.LE.10 ) THEN
-c$$$ DO 90 K1 = 1, N, 6
-c$$$ K2 = MIN0( N, K1+5 )
-c$$$ WRITE( LOUT, FMT = 9996 )K1, K2, ( SX( I ), I = K1, K2 )
-c$$$ 90 CONTINUE
-c$$$ ELSE
-c$$$ DO 100 K1 = 1, N, 5
-c$$$ K2 = MIN0( N, K1+4 )
-c$$$ WRITE( LOUT, FMT = 9995 )K1, K2, ( SX( I ), I = K1, K2 )
-c$$$ 100 CONTINUE
-c$$$ END IF
-c$$$ END IF
-c$$$ WRITE( LOUT, FMT = 9994 )
-c$$$ RETURN
-c$$$ 9998 FORMAT( 1X, I4, ' - ', I4, ':', 1P, 10D12.3 )
-c$$$ 9997 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P, 8D14.5 )
-c$$$ 9996 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P, 6D18.9 )
-c$$$ 9995 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P, 5D24.13 )
-c$$$ 9994 FORMAT( 1X, ' ' )
- END
diff --git a/src/ivout.f b/src/ivout.f
deleted file mode 100644
index 3f6089c..0000000
--- a/src/ivout.f
+++ /dev/null
@@ -1,120 +0,0 @@
-C-----------------------------------------------------------------------
-C Routine: IVOUT
-C
-C Purpose: Integer vector output routine.
-C
-C Usage: CALL IVOUT (LOUT, N, IX, IDIGIT, IFMT)
-C
-C Arguments
-C N - Length of array IX. (Input)
-C IX - Integer array to be printed. (Input)
-C IFMT - Format to be used in printing array IX. (Input)
-C IDIGIT - Print up to ABS(IDIGIT) decimal digits / number. (Input)
-C If IDIGIT .LT. 0, printing is done with 72 columns.
-C If IDIGIT .GT. 0, printing is done with 132 columns.
-C
-C-----------------------------------------------------------------------
-C
- SUBROUTINE IGRAPHIVOUT (LOUT, N, IX, IDIGIT, IFMT)
-C ...
-C ... SPECIFICATIONS FOR ARGUMENTS
- INTEGER IX(*), N, IDIGIT, LOUT
- CHARACTER IFMT*(*)
-C ...
-C ... SPECIFICATIONS FOR LOCAL VARIABLES
- INTEGER I, NDIGIT, K1, K2, LLL
- CHARACTER*80 LINE
-* ...
-* ... SPECIFICATIONS INTRINSICS
- INTRINSIC MIN
-*
-C
-c$$$ LLL = MIN ( LEN ( IFMT ), 80 )
-c$$$ DO 1 I = 1, LLL
-c$$$ LINE(I:I) = '-'
-c$$$ 1 CONTINUE
-c$$$C
-c$$$ DO 2 I = LLL+1, 80
-c$$$ LINE(I:I) = ' '
-c$$$ 2 CONTINUE
-c$$$C
-c$$$ WRITE ( LOUT, 2000 ) IFMT, LINE(1:LLL)
-c$$$ 2000 FORMAT ( /1X, A /1X, A )
-c$$$C
-c$$$ IF (N .LE. 0) RETURN
-c$$$ NDIGIT = IDIGIT
-c$$$ IF (IDIGIT .EQ. 0) NDIGIT = 4
-c$$$C
-c$$$C=======================================================================
-c$$$C CODE FOR OUTPUT USING 72 COLUMNS FORMAT
-c$$$C=======================================================================
-c$$$C
-c$$$ IF (IDIGIT .LT. 0) THEN
-c$$$C
-c$$$ NDIGIT = -IDIGIT
-c$$$ IF (NDIGIT .LE. 4) THEN
-c$$$ DO 10 K1 = 1, N, 10
-c$$$ K2 = MIN0(N,K1+9)
-c$$$ WRITE(LOUT,1000) K1,K2,(IX(I),I=K1,K2)
-c$$$ 10 CONTINUE
-c$$$C
-c$$$ ELSE IF (NDIGIT .LE. 6) THEN
-c$$$ DO 30 K1 = 1, N, 7
-c$$$ K2 = MIN0(N,K1+6)
-c$$$ WRITE(LOUT,1001) K1,K2,(IX(I),I=K1,K2)
-c$$$ 30 CONTINUE
-c$$$C
-c$$$ ELSE IF (NDIGIT .LE. 10) THEN
-c$$$ DO 50 K1 = 1, N, 5
-c$$$ K2 = MIN0(N,K1+4)
-c$$$ WRITE(LOUT,1002) K1,K2,(IX(I),I=K1,K2)
-c$$$ 50 CONTINUE
-c$$$C
-c$$$ ELSE
-c$$$ DO 70 K1 = 1, N, 3
-c$$$ K2 = MIN0(N,K1+2)
-c$$$ WRITE(LOUT,1003) K1,K2,(IX(I),I=K1,K2)
-c$$$ 70 CONTINUE
-c$$$ END IF
-c$$$C
-c$$$C=======================================================================
-c$$$C CODE FOR OUTPUT USING 132 COLUMNS FORMAT
-c$$$C=======================================================================
-c$$$C
-c$$$ ELSE
-c$$$C
-c$$$ IF (NDIGIT .LE. 4) THEN
-c$$$ DO 90 K1 = 1, N, 20
-c$$$ K2 = MIN0(N,K1+19)
-c$$$ WRITE(LOUT,1000) K1,K2,(IX(I),I=K1,K2)
-c$$$ 90 CONTINUE
-c$$$C
-c$$$ ELSE IF (NDIGIT .LE. 6) THEN
-c$$$ DO 110 K1 = 1, N, 15
-c$$$ K2 = MIN0(N,K1+14)
-c$$$ WRITE(LOUT,1001) K1,K2,(IX(I),I=K1,K2)
-c$$$ 110 CONTINUE
-c$$$C
-c$$$ ELSE IF (NDIGIT .LE. 10) THEN
-c$$$ DO 130 K1 = 1, N, 10
-c$$$ K2 = MIN0(N,K1+9)
-c$$$ WRITE(LOUT,1002) K1,K2,(IX(I),I=K1,K2)
-c$$$ 130 CONTINUE
-c$$$C
-c$$$ ELSE
-c$$$ DO 150 K1 = 1, N, 7
-c$$$ K2 = MIN0(N,K1+6)
-c$$$ WRITE(LOUT,1003) K1,K2,(IX(I),I=K1,K2)
-c$$$ 150 CONTINUE
-c$$$ END IF
-c$$$ END IF
-c$$$ WRITE (LOUT,1004)
-c$$$C
-c$$$ 1000 FORMAT(1X,I4,' - ',I4,':',20(1X,I5))
-c$$$ 1001 FORMAT(1X,I4,' - ',I4,':',15(1X,I7))
-c$$$ 1002 FORMAT(1X,I4,' - ',I4,':',10(1X,I11))
-c$$$ 1003 FORMAT(1X,I4,' - ',I4,':',7(1X,I15))
-c$$$ 1004 FORMAT(1X,' ')
-c$$$C
- RETURN
- END
diff --git a/src/second.f b/src/second.f
deleted file mode 100644
index 37023c3..0000000
--- a/src/second.f
+++ /dev/null
@@ -1,35 +0,0 @@
- SUBROUTINE IGRAPHSECOND( T )
-*
- REAL T
-*
-* -- LAPACK auxiliary routine (preliminary version) --
-* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
-* Courant Institute, Argonne National Lab, and Rice University
-* July 26, 1991
-*
-* Purpose
-* =======
-*
-* SECOND returns the user time for a process in igraphseconds.
-* This version gets the time from the system function ETIME.
-*
-* .. Local Scalars ..
- REAL T1
-* ..
-* .. Local Arrays ..
- REAL TARRAY( 2 )
-* ..
-* .. External Functions ..
- REAL ETIME
-* ..
-* .. Executable Statements ..
-*
- TARRAY( 1 ) = 0.0
- T1 = ETIME( TARRAY )
- T = TARRAY( 1 )
-
- RETURN
-*
-* End of SECOND
-*
- END
diff --git a/src/wrap.f b/src/wrap.f
index 39c4720..8c39bb0 100644
--- a/src/wrap.f
+++ b/src/wrap.f
@@ -20,7 +20,7 @@ c
applyx = .false.
end if
c
- call igraphdsortr(which, applyx, n, x1, x2)
+ call dsortr(which, applyx, n, x1, x2)
c
return
c
@@ -45,7 +45,7 @@ c
applyx = .false.
end if
c
- call igraphdsortc(which, applyx, n, xreal, ximag, y)
+ call dsortc(which, applyx, n, xreal, ximag, y)
c
return
c
@@ -93,7 +93,7 @@ c
go to 100
110 continue
c
- call igraphdneupd(rvecx, howmny, selectx, dr, di, z, ldz,
+ call dneupd(rvecx, howmny, selectx, dr, di, z, ldz,
& sigmar, sigmai, workev, bmat, n, which, nev, tol,
& resid, ncv, v, ldv, iparam, ipntr, workd,
& workl, lworkl, info)
@@ -142,7 +142,7 @@ c
go to 100
110 continue
c
- call igraphdseupd(rvecx, howmny, selectx, d, z, ldz,
+ call dseupd(rvecx, howmny, selectx, d, z, ldz,
& sigma, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam,
& ipntr, workd, workl, lworkl, info )
c
--
2.21.1